guile-log gts refined newfram/unwind/prune logic added

parent 72678813
...@@ -4,7 +4,9 @@ ...@@ -4,7 +4,9 @@
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:export (gp-clear gp-unify!- gp-unify-raw!- gp-newframe #:export (gp-clear gp-unify!- gp-unify-raw!-
gp-newframe
gp-newframe-choice
gp->scm gp-print gp-heap-var! gp->scm gp-print gp-heap-var!
gp-c-system gp-c-system
gp-make-var gp-make-var
...@@ -29,14 +31,16 @@ ...@@ -29,14 +31,16 @@
gp-module-init gp-module-init
gp-thread-safe-set! gp-thread-safe-set!
-gp-member -gp-right-of -next-to -einstein -gp-member -gp-right-of -next-to -einstein
gp-deterministic?
gp-current-stack-ref gp-current-stack-ref
gp-undo-safe-variable-guard gp-undo-safe-variable-guard
gp-undo-safe-variable-rguard gp-undo-safe-variable-rguard
gp-undo-safe-variable-lguard gp-undo-safe-variable-lguard
gp-prompt gp-abort gp-prompt gp-abort
gp-fluid-set gp-fluid-set
gp-prune
gp-prune-tail
gp-handlers-ref gp-handlers-ref
gp-handlers-set! gp-handlers-set!
gp-cont-ids-ref gp-cont-ids-ref
......
...@@ -1178,7 +1178,7 @@ add/run * vlist * ...@@ -1178,7 +1178,7 @@ add/run * vlist *
truncate! ref++ ref-- walk-lr-ii) truncate! ref++ ref-- walk-lr-ii)
(define g (define g
(lambda (s p cc . a) (lambda (s p cc . a)
(let ((fr (gp-newframe s)) (let ((fr (gp-newframe-choice s))
(del (fluid-ref delayers))) (del (fluid-ref delayers)))
(walk-lr s p a (walk-lr s p a
(lambda (p cut a vec last?) (lambda (p cut a vec last?)
...@@ -1188,10 +1188,12 @@ add/run * vlist * ...@@ -1188,10 +1188,12 @@ add/run * vlist *
(fluid-set! delayers del) (fluid-set! delayers del)
(p)))) (p))))
((get-f vec) s p cc cut a)) ((get-f vec) s p cc cut a))
((get-f vec) s p cc cut a))))))) (begin
(gp-unwind-tail fr)
((get-f vec) s p cc cut a))))))))
(define k (define k
(lambda (s p cc . a) (lambda (s p cc . a)
(let ((fr (gp-newframe s)) (let ((fr (gp-newframe-choice s))
(del (fluid-ref delayers))) (del (fluid-ref delayers)))
(walk-lr-ii s p a (walk-lr-ii s p a
(lambda (p cut a vec last?) (lambda (p cut a vec last?)
...@@ -1201,7 +1203,9 @@ add/run * vlist * ...@@ -1201,7 +1203,9 @@ add/run * vlist *
(fluid-set! delayers del) (fluid-set! delayers del)
(p)))) (p))))
((get-f vec) s p cc cut a)) ((get-f vec) s p cc cut a))
((get-f vec) s p cc cut a))))))) (begin
(gp-unwind-tail fr)
((get-f vec) s p cc cut a))))))))
(define gg (lambda x (apply g x))) (define gg (lambda x (apply g x)))
(define kk (lambda x (apply k x))) (define kk (lambda x (apply k x)))
...@@ -1649,7 +1653,7 @@ add/run * vlist * ...@@ -1649,7 +1653,7 @@ add/run * vlist *
(lambda (data) (lambda (data)
(let ((fr (<newframe>))) (let ((fr (<newframe>)))
(let* ((s (gp-unify! (get-c data) y S))) (let* ((s (gp-unify! (get-c data) y S)))
(<unwind> fr) (<unwind-tail> fr)
(if s #t #f)))) (if s #t #f))))
#t))) #t)))
...@@ -1659,7 +1663,7 @@ add/run * vlist * ...@@ -1659,7 +1663,7 @@ add/run * vlist *
(lambda (data) (lambda (data)
(let ((fr (<newframe>))) (let ((fr (<newframe>)))
(let ((s (gp-unify! (get-c data) y S))) (let ((s (gp-unify! (get-c data) y S)))
(<unwind> fr) (<unwind-tail> fr)
(if s #t #f)))) (if s #t #f))))
#f))) #f)))
...@@ -1668,7 +1672,7 @@ add/run * vlist * ...@@ -1668,7 +1672,7 @@ add/run * vlist *
(s2 (gp-newframe s1))) (s2 (gp-newframe s1)))
(with-fluids ((*current-stack* s2)) (with-fluids ((*current-stack* s2))
(let ((ret (code s1))) (let ((ret (code s1)))
(gp-unwind s1) (gp-unwind-tail s1)
ret)))) ret))))
(define (wapu ff mk-dyn . lams) (define (wapu ff mk-dyn . lams)
......
...@@ -178,13 +178,15 @@ ...@@ -178,13 +178,15 @@
(define walk-lr (vector-ref data 10)) (define walk-lr (vector-ref data 10))
(define g (define g
(lambda (s p cc . a) (lambda (s p cc . a)
(let ((fr (gp-newframe s))) (let ((fr (gp-newframe-choice s)))
(walk-lr s p a (walk-lr s p a
(lambda (p cut a vec last?) (lambda (p cut a vec last?)
(if (not last?) (if (not last?)
(let ((p (lambda () (gp-unwind fr) (p)))) (let ((p (lambda () (gp-unwind fr) (p))))
((get-f vec) s p cc cut a)) ((get-f vec) s p cc cut a))
((get-f vec) s p cc cut a))))))) (begin
(gp-unwind-tail fr)
((get-f vec) s p cc cut a))))))))
(setter g) (setter g)
(set-object-property! g 'dynamic-data data) (set-object-property! g 'dynamic-data data)
(set-procedure-property! g 'name f))) (set-procedure-property! g 'name f)))
......
...@@ -48,7 +48,7 @@ ...@@ -48,7 +48,7 @@
(define (f-interleave sin p cc as) (define (f-interleave sin p cc as)
(let-with-lr-guard sin wind lguard rguard ((l '()) (r '())) (let-with-lr-guard sin wind lguard rguard ((l '()) (r '()))
(lguard sin (lguard sin
(let ((sin (gp-newframe sin))) (let ((sin (gp-newframe-choice sin)))
(define fail (define fail
(lambda () (lambda ()
(let ((sin (gp-unwind sin))) (let ((sin (gp-unwind sin)))
...@@ -83,7 +83,7 @@ ...@@ -83,7 +83,7 @@
(define (f-interleave-union sin p cc as) (define (f-interleave-union sin p cc as)
(let-with-lr-guard sin wind lguard rguard ((l '()) (r '()) (gs '()) (gr '())) (let-with-lr-guard sin wind lguard rguard ((l '()) (r '()) (gs '()) (gr '()))
(lguard sin (lguard sin
(let ((s (gp-newframe sin))) (let ((s (gp-newframe-choice sin)))
(define fail (define fail
(lambda () (lambda ()
(let ((s (gp-unwind s))) (let ((s (gp-unwind s)))
...@@ -186,7 +186,7 @@ and-interleave ...@@ -186,7 +186,7 @@ and-interleave
(set! r (cons (mk-cont p2 ss) r)) (set! r (cons (mk-cont p2 ss) r))
(g2 ss fail (g2 ss fail
(lambda (sss p3) (lambda (sss p3)
(let ((fr (gp-newframe sss))) (let ((fr (gp-newframe-choice sss)))
(set! r (cons (mk-cont p3 sss) r)) (set! r (cons (mk-cont p3 sss) r))
(rg sss (cc sss (lambda () (rg sss (cc sss (lambda ()
(gp-unwind fr) (gp-unwind fr)
...@@ -239,7 +239,7 @@ and-interleave ...@@ -239,7 +239,7 @@ and-interleave
(let-with-lr-guard s wind lguard rguard (let-with-lr-guard s wind lguard rguard
((gg #f) (ggs gs) ... (vv #f) ... (vvs #f) ... ...) ((gg #f) (ggs gs) ... (vv #f) ... (vvs #f) ... ...)
(lguard s (lguard s
(let ((fr (gp-newframe s))) (let ((fr (gp-newframe-choice s)))
(g s p (g s p
(lambda (ss pp) (lambda (ss pp)
(cont-set! gg pp ss wind) (cont-set! gg pp ss wind)
...@@ -271,7 +271,7 @@ and-interleave ...@@ -271,7 +271,7 @@ and-interleave
(define (call s p cc lam x l) (define (call s p cc lam x l)
#;(use-logical s) #;(use-logical s)
(let ((s (gp-newframe s)) (let ((s (gp-newframe-choice s))
(wind (gp-windlevel-ref s))) (wind (gp-windlevel-ref s)))
((gp-lookup lam s) ((gp-lookup lam s)
s p (lambda (ss pp) s p (lambda (ss pp)
...@@ -293,32 +293,35 @@ and-interleave ...@@ -293,32 +293,35 @@ and-interleave
(call (</.> code ...) (list x ...) (list l ...)))))) (call (</.> code ...) (list x ...) (list l ...))))))
(<define> (<gc-call> X L Lam) (<define> (<gc-call> X L Lam)
(<let> ((pr (<newframe>))) (<let> ((p P)
(pr (<newframe>)))
(Lam) (Lam)
(<let> ((res (<cp> X L))) (<let> ((res (<cp> X L)))
(<code> (<unwind> pr)) (<code> (<unwind-tail> pr))
(<=> X res)))) (<with-fail> p (<=> X res)))))
(<define> (<gc-scm-call> X Lam) (<define> (<gc-scm-call> X Lam)
(<let> ((pr (<newframe>))) (<let> ((p P)
(pr (<newframe>)))
(Lam) (Lam)
(<let> ((res (<scm> X))) (<let> ((res (<scm> X)))
(<code> (<unwind> pr)) (<code> (<unwind-tail> pr))
(<=> X res)))) (<with-fail> p (<=> X res)))))
(<define> (<gc-list-call> X Lam) (<define> (<gc-list-call> X Lam)
(<let> ((pr (<newframe>))) (<let> ((p P)
(pr (<newframe>)))
(Lam) (Lam)
(<let> ((res (->list S X))) (<let> ((res (->list S X)))
(<pp> (length res)) (<pp> (length res))
(<code> (<unwind> pr)) (<code> (<unwind-tail> pr))
(<=> X res)))) (<with-fail> p (<=> X res)))))
(define-syntax-rule (fcall-m nm) (define-syntax-rule (fcall-m nm)
(define (nm s p cc lam x l f) (define (nm s p cc lam x l f)
(let-with-lr-guard s wind lguard rguard ((cc cc)) (let-with-lr-guard s wind lguard rguard ((cc cc))
(lguard s (lguard s
(let ((s (gp-newframe s))) (let ((s (gp-newframe-choice s)))
((gp-lookup lam s) ((gp-lookup lam s)
s p (lambda (ss pp) s p (lambda (ss pp)
(let ((state (gp-store-state ss))) (let ((state (gp-store-state ss)))
......
...@@ -33,7 +33,8 @@ ...@@ -33,7 +33,8 @@
<syntax-parameterize> <syntax-parameterize>
<car> <cdr> <logical++> <logical--> <car> <cdr> <logical++> <logical-->
define-guile-log-parser-tool define-guile-log-parser-tool
<newframe> <unwind> <unwind-tail> <newframe> <newframe-choice>
<unwind> <unwind-tail> <prune> <prune-tail>
<define-guile-log-rule> <define-guile-log-rule>
<get-fixed> <get-idfixed> <cp> <lookup> <wrap> <wrap-s> <get-fixed> <get-idfixed> <cp> <lookup> <wrap> <wrap-s>
<with-bind> <with-bind>
...@@ -106,7 +107,13 @@ ...@@ -106,7 +107,13 @@
(define-syntax-rule (<cdr> x) (gp-cdr (gp-lookup x S) S)) (define-syntax-rule (<cdr> x) (gp-cdr (gp-lookup x S) S))
(define-syntax-rule (<lookup> x) (gp-lookup x S)) (define-syntax-rule (<lookup> x) (gp-lookup x S))
(define-syntax-rule (<newframe>) (gp-newframe S)) (define-syntax-rule (<newframe>) (gp-newframe S))
(define-syntax <newframe-choice>
(syntax-rules ()
((_) (gp-newframe-choice S))
((_ s) (gp-newframe-choice s))))
(define-syntax-rule (<unwind> p) (gp-unwind p)) (define-syntax-rule (<unwind> p) (gp-unwind p))
(define-syntax-rule (<prune> p) (gp-prune p))
(define-syntax-rule (<prune-tail> p) (gp-prune-tail p))
(define-syntax-rule (<unwind-tail> p) (gp-unwind-tail p)) (define-syntax-rule (<unwind-tail> p) (gp-unwind-tail p))
(define-syntax-rule (<cp> x ...) (gp-cp x ... S)) (define-syntax-rule (<cp> x ...) (gp-cp x ... S))
(define-syntax-rule (<cons?> x) (gp-pair- (gp-lookup x S) S)) (define-syntax-rule (<cons?> x) (gp-pair- (gp-lookup x S) S))
...@@ -169,7 +176,7 @@ ...@@ -169,7 +176,7 @@
((_ meta e1) (parse<> meta e1)) ((_ meta e1) (parse<> meta e1))
((_ (cut s pr cc) . l) ((_ (cut s pr cc) . l)
(let ((s (gp-newframe s))) (let ((s (gp-newframe-choice s)))
(or-aux (cut s pr cc) . l))))) (or-aux (cut s pr cc) . l)))))
(define-syntax or-aux (define-syntax or-aux
...@@ -302,7 +309,6 @@ ...@@ -302,7 +309,6 @@
(cc-let (ccc) (cc-let (ccc)
(parse<> (cut s pr ccc) e1)))))))))) (parse<> (cut s pr ccc) e1))))))))))
;;This is inspired from kanren ;;This is inspired from kanren
;; (<and!> a ... ) gives exactly one answer from (and a ....) ;; (<and!> a ... ) gives exactly one answer from (and a ....)
;; (<and!!> a ... ) is the same as (and (and! a) ...) ;; (<and!!> a ... ) is the same as (and (and! a) ...)
...@@ -311,8 +317,10 @@ ...@@ -311,8 +317,10 @@
(syntax-rules () (syntax-rules ()
((_ w) (parse<> w <cc>)) ((_ w) (parse<> w <cc>))
((_ (cut s p cc) a ...) ((_ (cut s p cc) a ...)
(let ((ccc (lambda (ss pp . l) (apply cc ss p l)))) (let ((ccc (lambda (ss pp . l)
(parse<> (cut s p ccc) (<and> a ...)))))) (<prune> s)
(apply cc ss p l))))
(parse<> (cut s p ccc) (<and> a ... ))))))
(define-guile-log <and!!> (define-guile-log <and!!>
(lambda (x) (lambda (x)
...@@ -355,7 +363,7 @@ ...@@ -355,7 +363,7 @@
(syntax-rules () (syntax-rules ()
((_ (cut s p cc) g ...) ((_ (cut s p cc) g ...)
(let* ((s (gp-newframe s)) (let* ((s (gp-newframe s))
(ccc (lambda (ss pp) (gp-unwind s) (cc s p)))) (ccc (lambda (ss pp) (gp-unwind-tail s) (cc s p))))
(parse<> (cut s p ccc) (<and> g ...)))))) (parse<> (cut s p ccc) (<and> g ...))))))
...@@ -398,15 +406,21 @@ ...@@ -398,15 +406,21 @@
(define-guile-log <if> (define-guile-log <if>
(syntax-rules () (syntax-rules ()
((_ meta p a) ((_ meta p a)
(parse<> meta (<and> (<and!> p) a))) (parse<> meta
(let ((s S))
(<and!> p)
a)))
((_ (cut s p cc) pred a b) ((_ (cut s p cc) pred a b)
(<or> (cut s p cc) (let* ((fr (<newframe-choice> s))
(<let> ((ss S)) (pp (lambda ()
(<and> (<and!> pred) (<unwind-tail> fr)
(<with-fail> p (parse<> (cut s p cc) b))))
(<code> (gp-clear-frame! ss)) (parse<> (cut fr pp cc)
a))) (<and>
b)))) pred
(<with-fail> p
(<code> (<prune-tail> fr))
a)))))))
(define-guile-log <scm-if> (define-guile-log <scm-if>
(syntax-rules () (syntax-rules ()
...@@ -432,7 +446,6 @@ ...@@ -432,7 +446,6 @@
(let ((cc2 (lambda (s3 p3) (let ((cc2 (lambda (s3 p3)
(parse<> (cut s3 p cc) a)))) (parse<> (cut s3 p cc) a))))
(parse<> (cut s p2f cc2) pred)))))) (parse<> (cut s p2f cc2) pred))))))
(define-guile-log <if-some> (define-guile-log <if-some>
...@@ -522,7 +535,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati ...@@ -522,7 +535,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(ss2 (gp-set! gp-not-n (+ (gp-lookup gp-not-n s) 1) ss)) (ss2 (gp-set! gp-not-n (+ (gp-lookup gp-not-n s) 1) ss))
(ss3 (gp-set! gp-is-delayed? #f ss2)) (ss3 (gp-set! gp-is-delayed? #f ss2))
(ccc (lambda (s pp . x) (ccc (lambda (s pp . x)
(gp-unwind ss) (gp-unwind-tail ss)
(gp-var-set! gp-is-delayed? #f) (gp-var-set! gp-is-delayed? #f)
(p))) (p)))
(ppp (lambda () (ppp (lambda ()
...@@ -1086,7 +1099,6 @@ For tabling, negations are tricky. the reason is that when a recursive applicati ...@@ -1086,7 +1099,6 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
((_ code ...) (<lambda> () code ...)))) ((_ code ...) (<lambda> () code ...))))
(define (<funcall> S P CC F . L) (define (<funcall> S P CC F . L)
(apply (gp-lookup F S) S P CC L)) (apply (gp-lookup F S) S P CC L))
...@@ -1285,8 +1297,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER ...@@ -1285,8 +1297,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
#'(<let> w ((id I) ...) #'(<let> w ((id I) ...)
(<syntax-parameterize> ((X (lambda x #'id)) ...) (<syntax-parameterize> ((X (lambda x #'id)) ...)
(<and> code ...)))))))) (<and> code ...))))))))
(define-syntax-rule (<define-guile-log-rule> (f a ...) code ...) (define-syntax-rule (<define-guile-log-rule> (f a ...) code ...)
(define-guile-log f (define-guile-log f
(syntax-rules () (syntax-rules ()
...@@ -1337,14 +1348,12 @@ MAKE SURE TO REVISIT THIS IDEA LATER ...@@ -1337,14 +1348,12 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(doit_off) (doit_off)
(<r=> v ,(gp-lookup-1 ret S)) (<r=> v ,(gp-lookup-1 ret S))
(doit_on)))) (doit_on))))
(<define> (<del-attr!> x m) (<code> (gp-del-attr! x m S)))
(<define> (<del-attr> x m) (<define> (<del-attr> x m)
(<let> ((s (gp-del-attr x m S))) (<let> ((s (gp-del-attr x m S)))
(if s (<with-s> s <cc>) <cc>))) (if s (<with-s> s <cc>) <cc>)))
(<define> (<del-attr!> x m) (<code> (gp-del-attr! x m S)))
(define (tr-meta f fnew) (define (tr-meta f fnew)
(define (sieve l) (define (sieve l)
(let lp ((l l)) (let lp ((l l))
...@@ -1363,7 +1372,8 @@ MAKE SURE TO REVISIT THIS IDEA LATER ...@@ -1363,7 +1372,8 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(fu f)) (fu f))
(let ((res (tr-meta fu (<lambda> x (<apply> goal fu l ... x))))) (let ((res (tr-meta fu (<lambda> x (<apply> goal fu l ... x)))))
res))) res)))
(define-syntax-rule (adaptable_vars f) (define-syntax-rule (adaptable_vars f)
(fluid-let-syntax ((<var> (syntax-rules () (fluid-let-syntax ((<var> (syntax-rules ()
((_ . l) (<modvar> . l))))) ((_ . l) (<modvar> . l)))))
...@@ -1463,9 +1473,6 @@ MAKE SURE TO REVISIT THIS IDEA LATER ...@@ -1463,9 +1473,6 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<=> var val) (<=> var val)
(<==> val var))))) (<==> val var)))))
(variable-set! (@@ (logic guile-log code-load) attributeU) attributeU) (variable-set! (@@ (logic guile-log code-load) attributeU) attributeU)
(define-syntax-rule (<with-log-in-code> code ...) (define-syntax-rule (<with-log-in-code> code ...)
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
#:use-module ((logic guile-log umatch) #:select #:use-module ((logic guile-log umatch) #:select
(gp-unifier gp-raw-unifier gp-m-unifier gp? gp-pair? (gp-unifier gp-raw-unifier gp-m-unifier gp? gp-pair?
gp-attvar-raw? gp-att-raw-var gp-att-data gp-attvar-raw? gp-att-raw-var gp-att-data
gp-newframe gp-unwind gp-newframe gp-unwind gp-unwind-tail
attribute-cstor-ref)) attribute-cstor-ref))
#:use-module (logic guile-log canonacalize) #:use-module (logic guile-log canonacalize)
#:use-module (logic guile-log dynamic-features) #:use-module (logic guile-log dynamic-features)
...@@ -574,7 +574,7 @@ Also it is possible to solve inifinite recursion. ...@@ -574,7 +574,7 @@ Also it is possible to solve inifinite recursion.
x))) x)))
(let ((ret (let ((ret
(canon-it++ gp->scm-rec analyze (cdr sy) (car sy)))) (canon-it++ gp->scm-rec analyze (cdr sy) (car sy))))
(gp-unwind fr) (gp-unwind-tail fr)
ret)))) ret))))
......
...@@ -3,6 +3,7 @@ ...@@ -3,6 +3,7 @@
#:use-module (logic guile-log vlist) #:use-module (logic guile-log vlist)
#:use-module ((logic guile-log umatch) #:use-module ((logic guile-log umatch)
#:select (gp-attvar-raw? set-attribute-cstor! gp-lookup #:select (gp-attvar-raw? set-attribute-cstor! gp-lookup
gp-newframe-choice
gp-make-var gp-make-var
gp-attvar?)) gp-attvar?))
#:use-module (logic guile-log run) #:use-module (logic guile-log run)
...@@ -628,7 +629,7 @@ ...@@ -628,7 +629,7 @@
(<code> (set! true #t))))) (<code> (set! true #t)))))
<cc>))) <cc>)))
(if true (if true
(<code> (<unwind> fr)) (<code> (<unwind-tail> fr))
(when var)))) (when var))))
(define-syntax-rule (=/= x y) (define-syntax-rule (=/= x y)
......
...@@ -391,7 +391,7 @@ ...@@ -391,7 +391,7 @@
(p (<newframe>))) (p (<newframe>)))
(<with-s> p (<with-s> p
(.. (c) (f c)) (.. (c) (f c))
(<code> (<unwind> p)) (<code> (<unwind-tail> p))
(<with-fail> op (<with-fail> op
(<p-cc> c)))))) (<p-cc> c))))))
...@@ -440,23 +440,23 @@ ...@@ -440,23 +440,23 @@
(<and!> (<and!>
(<let> ((val (hash-ref (fluid-ref *freeze-map*) (<let> ((val (hash-ref (fluid-ref *freeze-map*)
(cons* N M tok) #f)) (cons* N M tok) #f))
(fr (<newframe>))) (fr (<newframe-choice>)))
(if (not val) (if (not val)
(<let> ((n N) (m M)) (<let> ((n N) (m M))
(<or> (<or>
(<and> (<and>
(.. (cc) (f c)) (.. (cc) (f c))
(<let> ((val2 (mk S c cc))) (<let> ((val2 (mk S c cc)))
(<code> (<code>
(<unwind> fr) (<unwind-tail> fr)
(hash-set! (fluid-ref *freeze-map*) (hash-set! (fluid-ref *freeze-map*)
(cons* n m tok) (list X XL N M XX ... val2))) (cons* n m tok) (list X XL N M XX ... val2)))
(<p-cc> val2))) (<p-cc> val2)))
(<let> ((val2 'fail)) (<let> ((val2 'fail))
(<code> (<code>
(<unwind> fr) (<unwind-tail> fr)
(hash-set! (fluid-ref *freeze-map*) (hash-set! (fluid-ref *freeze-map*)
(cons* n m tok) val2)) (cons* n m tok) val2))
<fail>))) <fail>)))
(if (pair? val) (if (pair? val)
(<apply> f-true val) (<apply> f-true val)
......
...@@ -162,7 +162,7 @@ ...@@ -162,7 +162,7 @@
(<eval> (v) (<eval> (v)
(<and> code ...) (<and> code ...)
(lambda x (lambda x
(gp-unwind fr1) (gp-unwind-tail fr1)
(reverse ret)) (reverse ret))
(lambda (s p) (lambda (s p)
(let ((res (gp-var! s))) (let ((res (gp-var! s)))
...@@ -182,7 +182,7 @@ ...@@ -182,7 +182,7 @@
(lambda x (lambda x
(let ((r ret)) (let ((r ret))
(set! ret '()) (set! ret '())
(gp-unwind fr1) (gp-unwind-tail fr1)
(reverse r))) (reverse r)))
(lambda (s p) (lambda (s p)
(set! ret (cons (tr (gp->scm (list v ...) s) s #f) ret)) (set! ret (cons (tr (gp->scm (list v ...) s) s #f) ret))
...@@ -205,7 +205,7 @@ ...@@ -205,7 +205,7 @@
(let ((r ret)) (let ((r ret))
(set! n 0) (set! n 0)
(set! ret '()) (set! ret '())
(gp-unwind fr1) (gp-unwind-tail fr1)
(reverse r))) (reverse r)))
(lambda (s p) (lambda (s p)
(if (= n 0) (if (= n 0)
...@@ -242,7 +242,7 @@ ...@@ -242,7 +242,7 @@
(let ((r ret)) (let ((r ret))
(set! n 0) (set! n 0)
(set! ret '()) (set! ret '())
(gp-unwind fr1) (gp-unwind-tail fr1)
(reverse r))) (reverse r)))
(lambda (s p) (lambda (s p)
(if (= n 0) (if (= n 0)
......
(define-module (logic guile-log soft-cut) (define-module (logic guile-log soft-cut)
#:use-module (logic guile-log) #:use-module (logic guile-log)
#:use-module ((logic guile-log umatch) #:select
(gp-deterministic?))
#:use-module (logic guile-log interleave) #:use-module (logic guile-log interleave)
#:export (<soft-if> #:export (<soft-if>
soft-if-f soft-if-f
...@@ -25,7 +27,7 @@ and rgard removes it from the list going backwards reverses the actions. ...@@ -25,7 +27,7 @@ and rgard removes it from the list going backwards reverses the actions.
(s0 S) (s0 S)
(cut1 CUT) (cut1 CUT)
(cc CC) (cc CC)
(fr (<newframe>))) (fr (<newframe-choice>)))
(<let-with-lr-guard> wind lguard rguard (<let-with-lr-guard> wind lguard rguard
((rp (lambda () ((rp (lambda ()
(<unwind-tail> fr) (<unwind-tail> fr)
...@@ -37,8 +39,8 @@ and rgard removes it from the list going backwards reverses the actions. ...@@ -37,8 +39,8 @@ and rgard removes it from the list going backwards reverses the actions.
(<with-cut> cut1 (<with-cut> cut1
a a
(<code> (<code>
(if (gp-deterministic? fr S)