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)
(<and>
(<let> ((a (<lookup> a)) (<let> ((a (<lookup> a))
(b (<lookup> b)) (b (<lookup> 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.
(<code> (<code>
(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
(<let> ((x (<lookup> x))) (<let> ((x (<lookup> x)))
(<and>
(cond (cond
((gp-attvar-raw? x S) ((gp-attvar-raw? x S)
(<let> ((v (gp-att-raw-var x S)) (<let> ((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
<cc>))))) <cc>))))))
(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)
(<wrap-s> rec-action00 s (<wrap-s> rec-action00 s
(<lambda> (y) (with-atomic-rec
(<code> (hashq-set! mp (<lookup> y) #t))) (<lambda> (y)
(<code> (hashq-set! mp (<lookup> 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)
(<wrap-s> rec-action00 s (<wrap-s> rec-action00 s
(<lambda> (y) (with-atomic-rec
(<code> (hashq-set! mp (<lookup> y) #t))) (<lambda> (y)
(<code> (hashq-set! mp (<lookup> 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)
(<wrap-s> rec-action00 s (<wrap-s> rec-action00 s
(with-atomic-rec
(<lambda> (y) (<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t))) (<code> (hashq-set! mp (<lookup> 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!
Please register or to comment