recursive fix

parent d5fdf6e7
......@@ -1188,9 +1188,16 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(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))
(if (procedure? f)
(set-procedure-properties! fnew (procedure-properties f)))
(set-procedure-properties! fnew (sieve (procedure-properties f))))
fnew)
(define-syntax-rule (functorize f g l ...)
......
......@@ -466,6 +466,7 @@ Also it is possible to solve inifinite recursion.
(rec-action* lam x)))
(lam (a . b)
(<and>
(<let> ((a (<lookup> a))
(b (<lookup> b))
(h (rec-ref00 rec-action*)))
......@@ -473,10 +474,11 @@ Also it is possible to solve inifinite recursion.
(<code>
(vhash-truncate! h)
(rec-set0! rec-action* h))
(rec-action lam b)))
(rec-action lam b))))
(lam x
(<let> ((x (<lookup> x)))
(<and>
(cond
((gp-attvar-raw? x S)
(<let> ((v (gp-att-raw-var x S))
......@@ -492,7 +494,7 @@ Also it is possible to solve inifinite recursion.
((namespace? x)
(rec-action lam (namespace-val x)))
(else
<cc>)))))
<cc>))))))
(define rec-action (rec-lam-00 rec-action* unify-guard doit-id))
(define rec-action00 rec-action)
......@@ -514,22 +516,26 @@ Also it is possible to solve inifinite recursion.
(gp-cp-rec x '() s))
((x l s)
(define mp (make-hash-table))
(define track vlist-null)
(fluid-set! mpf mp)
(mpf mp)
(<wrap-s> rec-action00 s
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t)))
(with-atomic-rec
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t))))
x)
(rec-set0! rec-action* vlist-null)
(gp-cp++ #f x l s))))
(define (gp->scm-rec x s)
(define mp (make-hash-table))
(fluid-set! mpf mp)
(mpf mp)
(<wrap-s> rec-action00 s
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t)))
(with-atomic-rec
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t))))
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)))
......@@ -542,9 +548,11 @@ Also it is possible to solve inifinite recursion.
(define (id a b x s) x)
(define (analyze mp x s)
(<wrap-s> rec-action00 s
(with-atomic-rec
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t)))
x))
(<code> (hashq-set! mp (<lookup> y) #t))))
x)
(rec-set0! rec-action* vlist-null))
(let ((s0 s)
(fr (gp-newframe s)))
(let ((sy ((fluid-ref canon) s (lambda x #f) (lambda (s p y) (cons s y))
......
......@@ -450,9 +450,10 @@
(define qt (cons 'quoted 'var))
(define* (scm->pl s x #:optional (ns? #f) (quoted? #f) (ignore? #f) (numbervars? #f))
(define (first-redo h)
(set! first-map h)
(vlist-truncate! h))
(define (first-redo h) #f)
; (set! first-map h)
; (vlist-truncate! h))
(define first-map vlist-null)
(define action-map (make-hash-table))
......@@ -558,7 +559,7 @@
(if w
(format #f "ref[~a]" v)
(begin
(vhash-consq x #t first-map)
(set! first-map (vhash-consq x #t first-map))
(string-append
(format #f "{~a}" v)
(trail x #t)))))
......@@ -572,7 +573,7 @@
(if w
(format #f "ref[~a]" v)
(begin
(vhash-consq x #t first-map)
(set! first-map (vhash-consq x #t first-map))
(format #f "{~a}~a" v (trail)))))
#f))))
......
......@@ -782,7 +782,14 @@
(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* (make-fluid gp-cp+))
(define (gp-scm+ x s) (gp-cp++ #t x s))
......@@ -799,12 +806,19 @@
(define tr (make-hash-table))
(define datas '())
(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?)
(let lp ((x x))
(let ((x (gp-lookup x s)))
(cond
((hashq-ref (fluid-ref recurs-map) x #f)
((hashq-ref (recurs-map) x #f)
#t)
((gp-attvar-raw? x s)
......@@ -847,7 +861,7 @@
(let ((x (gp-lookup x s)))
(let lp2 ((first? #t))
(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)))
(if d
d
......@@ -968,7 +982,6 @@
(let ((unwinded (make-variable #f)))
(if (fluid? s)
(set! s (fluid-ref s)))
(pk 's s)
(gp-dynwind
(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