fixed a bug in the guarded states code

parent 204b6c7f
......@@ -111,3 +111,58 @@ and-interleave
(loop p2 g2 gs))))))))
(define-guile-log <set!>
(syntax-rules ()
((_ meta s v)
(parse<> meta (<code> (set! s v))))))
(define-guile-log <letg>
(lambda (x)
(syntax-case x ()
((_ meta ((s v) ...) code ...)
(with-syntax (((g ...) (generate-temporaries #'(s ...)))
((ss ...) (generate-temporaries #'(s ...))))
#'(letg-aux-aux (g ...) (ss ...) (v ...)
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ v)
#'(g v))
((_ a (... ...))
#'(ss a (... ...)))
(var
(identifier? #'var)
#'ss)))))
...)
(parse<> meta (<and> code ...)))))))))
(define-syntax letg-aux
(syntax-rules ()
((_ () () () code)
code)
((_ (g . gs) (ss . sss) (v . vs) code)
(with-guarded-state 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))))
#'(begin
(define ss v)
(define g (with-guarded-globals g (ss) g))
(define-syntax s
(make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ v)
#'(g v))
((_ a (... ...))
#'(ss a (... ...)))
(var
(identifier? #'var)
#'ss)))))))))))
......@@ -10,7 +10,8 @@
<def> <<define>> <with-fail> <dynwind> parse<>
let<> <or-i> <stall> <continue> <take>
<state-ref> <state-set!> <lv*> <clear>
<and-i> and-interleave interleave)
<and-i> and-interleave interleave
<letg> define-guarded)
(re-export define-guile-log guile-log-macro? log-code-macro log-code-macro?)
......
......@@ -40,7 +40,7 @@
u-unify! u-scm u-unify-raw! u-cons u-dynwind umatch
gp-copy **um** gp-get-stack
push-setup que-setup
with-guarded-states))
with-guarded-states with-guarded-globals))
(define gp-module-init #f)
(define gp? #f)
......@@ -135,10 +135,22 @@
#'(let ((s v) ... (fr #t) (done #f))
(letrec ((guard (mk-guard fr done guard s ...)))
(dyn
(lambda () (set! fr #t))
(lambda ()
(set! fr #t)
(set! done #t)
(push-setup
(lambda ()
(set! done #f))))
(lambda () (set! fr #f)))
(let () code ...)))))))
(define-syntax with-guarded-globals
(lambda (x)
(syntax-case x ()
((_ guard (s ...) code ...)
#'(letrec ((guard (mk-guard fr done guard s ...)))
(let () code ...))))))
(define old gp-make-fluid)
......
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