refactoring interleave.scm

parent c8661573
......@@ -18,6 +18,7 @@ SOURCES = \
logic/guile-log/umatch.scm \
logic/guile-log/macros.scm \
logic/guile-log/run.scm \
logic/guile-log/undovar.scm \
logic/guile-log/interleave.scm \
logic/guile-log/tools.scm \
logic/guile-log/prompts.scm \
......
(define-module (logic guile-log interleave)
#:use-module (logic guile-log macros)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log undovar)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (syntax parse)
#:re-export (<let-with-true-guard>
<let-with-guard> <let-with-lr-guard> let-with-guard
let-with-lr-guard)
#:export (<or-i> <or-union> <and-i>
<//> <update> <update-val> <zip> <call>
<let-with-true-guard>
<let-with-guard> <let-with-lr-guard> let-with-guard
let-with-lr-guard <set!>))
(define-guile-log <let-with-guard>
(lambda (x)
(syntax-case x ()
((_ (cut state p cc) wind guard ((s v) ...) code ...)
#'(let ((s (make-variable v)) ...)
(call-with-values
(lambda () (gp-new-wind-level state))
(lambda (sstate wind)
(let ((guard
(lambda (sstate p cc f)
(gp-undo-safe-variable-guard s
(gp-rebased-level-ref
(- wind 1))
sstate)
...
(f sstate p cc))))
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(variable-set! s w))
((_ a (... ...))
#'((variable-ref s) a (... ...)))
(var
(identifier? #'var)
#'(variable-ref s))))))
...)
(parse<> (cut sstate p cc) (<and> code ...)))))))))))
(define-guile-log <let-with-true-guard>
(lambda (x)
(syntax-case x ()
((_ (cut state p cc) wind guard ((s v) ...) code ...)
#'(let ((s (make-variable v)) ...)
(call-with-values
(lambda () (gp-new-wind-level state))
(lambda (sstate wind)
(let ((guard
(lambda (sstate p cc f)
(gp-undo-safe-variable-guard s #t sstate)
...
(f sstate p cc))))
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(variable-set! s w))
((_ a (... ...))
#'((variable-ref s) a (... ...)))
(var
(identifier? #'var)
#'(variable-ref s))))))
...)
(parse<> (cut sstate p cc) (<and> code ...)))))))))))
(define-guile-log <let-with-lr-guard>
(lambda (x)
(syntax-case x ()
((_ (cut state p cc) wind lguard rguard ((s v) ...) code ...)
(with-syntax (((ss ...) (reverse #'(s ...))))
#`(let ((s (make-variable v)) ...)
(call-with-values
(lambda () (gp-new-wind-level state))
(lambda (sstate wind)
(let ((rguard
(lambda (sstate p cc f)
(gp-undo-safe-variable-rguard ss
(gp-rebased-level-ref (- wind 1))
sstate)
...
(gp-undo-safe-variable-guard ss (gp-rebased-level-ref
(- wind 1))
sstate)
...
(f sstate p cc)))
(lguard
(lambda (sstate p cc f)
(gp-undo-safe-variable-lguard s (gp-rebased-level-ref
(- wind 1)) sstate)
...
(f sstate p cc))))
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(variable-set! s w))
((_ a (... ...))
#'((variable-ref s) a (... ...)))
(var
(identifier? #'var)
#'(variable-ref s))))))
...)
(parse<> (cut sstate p cc) (<and> code ...))))))))))))
(define-syntax let-with-guard
(lambda (x)
(syntax-case x ()
((_ state wind guard ((s v) ...) code ...)
#'(let ((s (make-variable v)) ...)
(call-with-values
(lambda () (gp-new-wind-level state))
(lambda (state wind)
(let-syntax ((guard
(syntax-rules ()
((_ stat codee (... ...))
(begin
(gp-undo-safe-variable-guard
s
(gp-rebased-level-ref (- wind 1))
stat)
...
codee (... ...))))))
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(variable-set! s w))
((_ a (... ...))
#'((variable-ref s) a (... ...)))
(var
(identifier? #'var)
#'(variable-ref s))))))
...)
(let () code ...))))))))))
(define-syntax let-with-lr-guard
(lambda (x)
(syntax-case x ()
((_ state wind lguard rguard ((s v) ...) code ...)
(with-syntax (((ss ...) (reverse #'(s ...))))
#'(let ((s (make-variable v)) ...)
(call-with-values
(lambda () (gp-new-wind-level state))
(lambda (state wind)
(let-syntax ((lguard
(syntax-rules ()
((_ stat codee (... ...))
(begin
(gp-undo-safe-variable-lguard
s (gp-rebased-level-ref (- wind 1))
stat)
...
codee (... ...)))))
(rguard
(syntax-rules ()
((_ stat codee (... ...))
(begin
(gp-undo-safe-variable-rguard
ss (gp-rebased-level-ref (- wind 1))
stat)
...
(gp-undo-safe-variable-guard
ss (gp-rebased-level-ref (- wind 1))
stat)
...
codee (... ...))))))
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(variable-set! s w))
((_ a (... ...))
#'((variable-ref s) a (... ...)))
(var
(identifier? #'var)
#'(variable-ref s))))))
...)
(let () code ...)))))))))))
<set!>))
(define-guile-log <or-i>
(syntax-rules ()
......
......@@ -412,10 +412,12 @@ inline int gp_at_newframe(SCM *pt)
GP_GC_CAND(head);
GP_GETREF(val)[0] = SCM_PACK(head);
val = GP_GETREF(val)[1];
if(0 && GP(val))
goto retry_gp;
else
scm_gc_mark(val);
}
else
scm_gc_mark(GP_GETREF(val)[1]);
......
(define-module (logic guile-log undovar)
#:use-module (logic guile-log macros)
#:use-module (logic guile-log umatch)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:export (<let-with-true-guard>
<let-with-guard> <let-with-lr-guard> let-with-guard
let-with-lr-guard))
(define-guile-log <let-with-guard>
(lambda (x)
(syntax-case x ()
((_ (cut state p cc) wind guard ((s v) ...) code ...)
#'(let ((s (make-variable v)) ...)
(call-with-values
(lambda () (gp-new-wind-level state))
(lambda (sstate wind)
(let ((guard
(lambda (sstate p cc f)
(gp-undo-safe-variable-guard s
(gp-rebased-level-ref
(- wind 1))
sstate)
...
(f sstate p cc))))
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(variable-set! s w))
((_ a (... ...))
#'((variable-ref s) a (... ...)))
(var
(identifier? #'var)
#'(variable-ref s))))))
...)
(parse<> (cut sstate p cc) (<and> code ...)))))))))))
(define-guile-log <let-with-true-guard>
(lambda (x)
(syntax-case x ()
((_ (cut state p cc) wind guard ((s v) ...) code ...)
#'(let ((s (make-variable v)) ...)
(call-with-values
(lambda () (gp-new-wind-level state))
(lambda (sstate wind)
(let ((guard
(lambda (sstate p cc f)
(gp-undo-safe-variable-guard s #t sstate)
...
(f sstate p cc))))
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(variable-set! s w))
((_ a (... ...))
#'((variable-ref s) a (... ...)))
(var
(identifier? #'var)
#'(variable-ref s))))))
...)
(parse<> (cut sstate p cc) (<and> code ...)))))))))))
(define-guile-log <let-with-lr-guard>
(lambda (x)
(syntax-case x ()
((_ (cut state p cc) wind lguard rguard ((s v) ...) code ...)
(with-syntax (((ss ...) (reverse #'(s ...))))
#`(let ((s (make-variable v)) ...)
(call-with-values
(lambda () (gp-new-wind-level state))
(lambda (sstate wind)
(let ((rguard
(lambda (sstate p cc f)
(gp-undo-safe-variable-rguard ss
(gp-rebased-level-ref (- wind 1))
sstate)
...
(gp-undo-safe-variable-guard ss (gp-rebased-level-ref
(- wind 1))
sstate)
...
(f sstate p cc)))
(lguard
(lambda (sstate p cc f)
(gp-undo-safe-variable-lguard s (gp-rebased-level-ref
(- wind 1)) sstate)
...
(f sstate p cc))))
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(variable-set! s w))
((_ a (... ...))
#'((variable-ref s) a (... ...)))
(var
(identifier? #'var)
#'(variable-ref s))))))
...)
(parse<> (cut sstate p cc) (<and> code ...))))))))))))
(define-syntax let-with-guard
(lambda (x)
(syntax-case x ()
((_ state wind guard ((s v) ...) code ...)
#'(let ((s (make-variable v)) ...)
(call-with-values
(lambda () (gp-new-wind-level state))
(lambda (state wind)
(let-syntax ((guard
(syntax-rules ()
((_ stat codee (... ...))
(begin
(gp-undo-safe-variable-guard
s
(gp-rebased-level-ref (- wind 1))
stat)
...
codee (... ...))))))
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(variable-set! s w))
((_ a (... ...))
#'((variable-ref s) a (... ...)))
(var
(identifier? #'var)
#'(variable-ref s))))))
...)
(let () code ...))))))))))
(define-syntax let-with-lr-guard
(lambda (x)
(syntax-case x ()
((_ state wind lguard rguard ((s v) ...) code ...)
(with-syntax (((ss ...) (reverse #'(s ...))))
#'(let ((s (make-variable v)) ...)
(call-with-values
(lambda () (gp-new-wind-level state))
(lambda (state wind)
(let-syntax ((lguard
(syntax-rules ()
((_ stat codee (... ...))
(begin
(gp-undo-safe-variable-lguard
s (gp-rebased-level-ref (- wind 1))
stat)
...
codee (... ...)))))
(rguard
(syntax-rules ()
((_ stat codee (... ...))
(begin
(gp-undo-safe-variable-rguard
ss (gp-rebased-level-ref (- wind 1))
stat)
...
(gp-undo-safe-variable-guard
ss (gp-rebased-level-ref (- wind 1))
stat)
...
codee (... ...))))))
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(variable-set! s w))
((_ a (... ...))
#'((variable-ref s) a (... ...)))
(var
(identifier? #'var)
#'(variable-ref s))))))
...)
(let () code ...)))))))))))
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