<run> improved, does work better with call/cc using guarded variables

parent 73664eb1
......@@ -204,13 +204,13 @@ and-interleave
((_ (g . gs) (ss . sss) (v . vs) code)
(with-guarded-states g ((ss v))
(letg-aux gs sss vs code)))))
#;
(define-syntax define-guarded
(lambda (x)
(syntax-case x ()
((_ s v)
(with-syntax (((ss) (generate-temporaries #`(#,s)))
((g) (generate-temporaries #`(#,s))))
(with-syntax (((ss) (generate-temporaries #`(#,#'s)))
((g) (generate-temporaries #`(#,#'s))))
#'(begin
(define ss v)
(define g (with-guarded-globals g (ss) g))
......
......@@ -72,89 +72,90 @@
(define-syntax <run>
(syntax-rules (*)
((_ (v) code ...)
(let ((ret '())
(fr (gp-newframe)))
(<eval> (v)
(<and> code ...)
(lambda x
(gp-unwind fr)
(reverse ret))
(lambda (p)
(set! ret (cons (tr (u-scm v)) ret))
(u-abort p)))))
(let ((fr (gp-newframe)))
(with-guarded-states ret-set! ((ret '()))
(<eval> (v)
(<and> code ...)
(lambda x
(gp-unwind fr)
(reverse ret))
(lambda (p)
(ret-set! (cons (tr (u-scm v)) ret))
(u-abort p))))))
((_ (v ...) code ...)
(let ((ret '()) (fr (gp-newframe)))
(<eval> (v ...)
(<and> code ...)
(lambda x
(let ((r ret))
(set! ret '())
(gp-unwind fr)
(reverse r)))
(lambda (p)
(set! ret (cons (tr (u-scm (list v ...))) ret))
(u-abort p)))))
(let ((fr (gp-newframe)))
(with-guarded-states ret-set! ((ret '()))
(<eval> (v ...)
(<and> code ...)
(lambda x
(let ((r ret))
(ret-set! ret '())
(gp-unwind fr)
(reverse r)))
(lambda (p)
(ret-set! (cons (tr (u-scm (list v ...))) ret))
(u-abort p))))))
((_ * . l) (<run> . l))
((_ m (v) code ...)
(let ((n m)
(fr (gp-newframe))
(ret '()))
(<eval> (v)
(<and> code ...)
(lambda x
(let ((r ret))
(set! ret '())
(gp-unwind fr)
(reverse r)))
(lambda (p)
(if (= n 0)
(let ((r (reverse ret)))
(set! ret '())
(gp-set! *cc* (cons #f (lambda (mm)
(set! n mm)
(u-abort p))))
r)
(begin
(set! ret (cons (tr (u-scm v)) ret))
(set! n (- n 1))
(if (= n 0)
(let ((r (reverse ret)))
(set! ret '())
(gp-set! *cc* (cons #f (lambda (mm)
(set! n mm)
(u-abort p))))
r)
(u-abort p))))))))
(let ((fr (gp-newframe)))
(with-guarded-states n-ret-set! ((n m) (ret '()))
(<eval> (v)
(<and> code ...)
(lambda x
(let ((r ret))
(n-ret-set! 0 '())
(gp-unwind fr)
(reverse r)))
(lambda (p)
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(u-abort p))))
r)
(begin
(n-ret-set! (- n 1)
(cons (tr (u-scm v)) ret))
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(u-abort p))))
r)
(u-abort p)))))))))
((_ m (v ...) code ...)
(let ((n m) (ret '()) (fr (gp-newframe)))
(<eval> (v ...)
(<and> code ...)
(lambda x
(let ((r ret))
(set! ret '())
(gp-unwind fr)
(reverse r)))
(lambda (p)
(if (> n 0)
(begin
(set! ret (cons (tr (u-scm (list v ...))) ret))
(set! n (- n 1))
(if (= n 0)
(let ((r (reverse ret)))
(set! ret '())
(gp-set! *cc*
(cons #f (lambda (mm)
(set! n mm)
(u-abort p))))
r)
(u-abort p)))
(reverse ret))))))))
(let ((fr (gp-newframe)))
(with-guarded-states n-ret-set! ((n m) (ret '()))
(<eval> (v ...)
(<and> code ...)
(lambda x
(let ((r ret))
(n-ret-set! ret '())
(gp-unwind fr)
(reverse r)))
(lambda (p)
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(u-abort p))))
r)
(begin
(n-ret-set! (- n 1)
(cons (list (tr (u-scm v)) ...) ret))
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(u-abort p))))
r)
(u-abort p)))))))))))
......@@ -793,3 +794,5 @@
(gp-clear)
(gp-swap-to-a)
(gp-clear))
(log-code-macro '<fail>)
......@@ -145,6 +145,7 @@
(<=> #t x)))
'(#t))
(check?
(<ask>
(<conde>
......
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