Commit 56de6d39 by Stefan Israelsson Tampe

### recursive fix

parent d5fdf6e7
 ... @@ -1188,9 +1188,16 @@ MAKE SURE TO REVISIT THIS IDEA LATER ... @@ -1188,9 +1188,16 @@ MAKE SURE TO REVISIT THIS IDEA LATER (define (tr-meta f fnew) (define (tr-meta f fnew) (define (sieve l) (let lp ((l l)) (if (pair? l) (if (eq? (caar l) 'arity) (lp (cdr l)) (cons (car l) (lp (cdr l)))) '()))) (set-object-properties! fnew (object-properties f)) (set-object-properties! fnew (object-properties f)) (if (procedure? f) (if (procedure? f) (set-procedure-properties! fnew (procedure-properties f))) (set-procedure-properties! fnew (sieve (procedure-properties f)))) fnew) fnew) (define-syntax-rule (functorize f g l ...) (define-syntax-rule (functorize f g l ...) ... ...
 ... @@ -466,6 +466,7 @@ Also it is possible to solve inifinite recursion. ... @@ -466,6 +466,7 @@ Also it is possible to solve inifinite recursion. (rec-action* lam x))) (rec-action* lam x))) (lam (a . b) (lam (a . b) ( ( ((a ( a)) ( ((a ( a)) (b ( b)) (b ( b)) (h (rec-ref00 rec-action*))) (h (rec-ref00 rec-action*))) ... @@ -473,10 +474,11 @@ Also it is possible to solve inifinite recursion. ... @@ -473,10 +474,11 @@ Also it is possible to solve inifinite recursion. ( ( (vhash-truncate! h) (vhash-truncate! h) (rec-set0! rec-action* h)) (rec-set0! rec-action* h)) (rec-action lam b))) (rec-action lam b)))) (lam x (lam x ( ((x ( x))) ( ((x ( x))) ( (cond (cond ((gp-attvar-raw? x S) ((gp-attvar-raw? x S) ( ((v (gp-att-raw-var x S)) ( ((v (gp-att-raw-var x S)) ... @@ -492,7 +494,7 @@ Also it is possible to solve inifinite recursion. ... @@ -492,7 +494,7 @@ Also it is possible to solve inifinite recursion. ((namespace? x) ((namespace? x) (rec-action lam (namespace-val x))) (rec-action lam (namespace-val x))) (else (else ))))) )))))) (define rec-action (rec-lam-00 rec-action* unify-guard doit-id)) (define rec-action (rec-lam-00 rec-action* unify-guard doit-id)) (define rec-action00 rec-action) (define rec-action00 rec-action) ... @@ -514,22 +516,26 @@ Also it is possible to solve inifinite recursion. ... @@ -514,22 +516,26 @@ Also it is possible to solve inifinite recursion. (gp-cp-rec x '() s)) (gp-cp-rec x '() s)) ((x l s) ((x l s) (define mp (make-hash-table)) (define mp (make-hash-table)) (define track vlist-null) (mpf mp) (fluid-set! mpf mp) ( rec-action00 s ( rec-action00 s ( (y) (with-atomic-rec ( (hashq-set! mp ( y) #t))) ( (y) ( (hashq-set! mp ( y) #t)))) x) x) (rec-set0! rec-action* vlist-null) (gp-cp++ #f x l s)))) (gp-cp++ #f x l s)))) (define (gp->scm-rec x s) (define (gp->scm-rec x s) (define mp (make-hash-table)) (define mp (make-hash-table)) (fluid-set! mpf mp) (mpf mp) ( rec-action00 s ( rec-action00 s ( (y) (with-atomic-rec ( (hashq-set! mp ( y) #t))) ( (y) ( (hashq-set! mp ( y) #t)))) x) x) (gp-cp++ #t x s)) (rec-set0! rec-action* vlist-null) (let ((r (gp-cp++ #t x s))) r)) (define (pp . x) (car (reverse x))) (define (pp . x) (car (reverse x))) ... @@ -542,9 +548,11 @@ Also it is possible to solve inifinite recursion. ... @@ -542,9 +548,11 @@ Also it is possible to solve inifinite recursion. (define (id a b x s) x) (define (id a b x s) x) (define (analyze mp x s) (define (analyze mp x s) ( rec-action00 s ( rec-action00 s (with-atomic-rec ( (y) ( (y) ( (hashq-set! mp ( y) #t))) ( (hashq-set! mp ( y) #t)))) x)) x) (rec-set0! rec-action* vlist-null)) (let ((s0 s) (let ((s0 s) (fr (gp-newframe s))) (fr (gp-newframe s))) (let ((sy ((fluid-ref canon) s (lambda x #f) (lambda (s p y) (cons s y)) (let ((sy ((fluid-ref canon) s (lambda x #f) (lambda (s p y) (cons s y)) ... ...
 ... @@ -450,9 +450,10 @@ ... @@ -450,9 +450,10 @@ (define qt (cons 'quoted 'var)) (define qt (cons 'quoted 'var)) (define* (scm->pl s x #:optional (ns? #f) (quoted? #f) (ignore? #f) (numbervars? #f)) (define* (scm->pl s x #:optional (ns? #f) (quoted? #f) (ignore? #f) (numbervars? #f)) (define (first-redo h) (define (first-redo h) #f) (set! first-map h) (vlist-truncate! h)) ; (set! first-map h) ; (vlist-truncate! h)) (define first-map vlist-null) (define first-map vlist-null) (define action-map (make-hash-table)) (define action-map (make-hash-table)) ... @@ -558,7 +559,7 @@ ... @@ -558,7 +559,7 @@ (if w (if w (format #f "ref[~a]" v) (format #f "ref[~a]" v) (begin (begin (vhash-consq x #t first-map) (set! first-map (vhash-consq x #t first-map)) (string-append (string-append (format #f "{~a}" v) (format #f "{~a}" v) (trail x #t))))) (trail x #t))))) ... @@ -572,7 +573,7 @@ ... @@ -572,7 +573,7 @@ (if w (if w (format #f "ref[~a]" v) (format #f "ref[~a]" v) (begin (begin (vhash-consq x #t first-map) (set! first-map (vhash-consq x #t first-map)) (format #f "{~a}~a" v (trail))))) (format #f "{~a}~a" v (trail))))) #f)))) #f)))) ... ...
 ... @@ -782,7 +782,14 @@ ... @@ -782,7 +782,14 @@ (x (x (apply (fluid-ref *gp->scm*) x)))) (apply (fluid-ref *gp->scm*) x)))) (define recurs-map (make-fluid (make-hash-table))) (define recurs-map (let ((r (make-fluid (make-hash-table)))) (case-lambda (() (fluid-ref r)) ((x) (fluid-set! r x))))) (define (gp-cp+ . l) (apply gp-cp++ #f l)) (define (gp-cp+ . l) (apply gp-cp++ #f l)) (define *gp-cp* (make-fluid gp-cp+)) (define *gp-cp* (make-fluid gp-cp+)) (define (gp-scm+ x s) (gp-cp++ #t x s)) (define (gp-scm+ x s) (gp-cp++ #t x s)) ... @@ -799,12 +806,19 @@ ... @@ -799,12 +806,19 @@ (define tr (make-hash-table)) (define tr (make-hash-table)) (define datas '()) (define datas '()) (define first-map (make-hash-table)) (define first-map (make-hash-table)) (define ii 1) (define (pp x) (when (< ii 10) (pk 'gp->scm x) (pk 'gp->scm (object-address x))) (set! ii (+ ii 1)) x) (when (not scm?) (when (not scm?) (let lp ((x x)) (let lp ((x x)) (let ((x (gp-lookup x s))) (let ((x (gp-lookup x s))) (cond (cond ((hashq-ref (fluid-ref recurs-map) x #f) ((hashq-ref (recurs-map) x #f) #t) #t) ((gp-attvar-raw? x s) ((gp-attvar-raw? x s) ... @@ -847,7 +861,7 @@ ... @@ -847,7 +861,7 @@ (let ((x (gp-lookup x s))) (let ((x (gp-lookup x s))) (let lp2 ((first? #t)) (let lp2 ((first? #t)) (cond (cond ((and (hashq-ref (fluid-ref recurs-map) x #f) first?) ((and (hashq-ref (recurs-map) x #f) first?) (let ((d (hashq-ref first-map x #f))) (let ((d (hashq-ref first-map x #f))) (if d (if d d d ... @@ -968,7 +982,6 @@ ... @@ -968,7 +982,6 @@ (let ((unwinded (make-variable #f))) (let ((unwinded (make-variable #f))) (if (fluid? s) (if (fluid? s) (set! s (fluid-ref s))) (set! s (fluid-ref s))) (pk 's s) (gp-dynwind (gp-dynwind (lambda x (variable-set! unwinded #f)) (lambda x (variable-set! unwinded #f)) (lambda x (variable-set! unwinded #f)) (lambda x (variable-set! unwinded #f)) ... ...
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!