fixed the stall command

parent 0cb49701
...@@ -15,7 +15,6 @@ SOURCES = \ ...@@ -15,7 +15,6 @@ SOURCES = \
logic/guile-log/code-load.scm \ logic/guile-log/code-load.scm \
logic/guile-log/vlist.scm \ logic/guile-log/vlist.scm \
logic/guile-log/indexer.scm \ logic/guile-log/indexer.scm \
logic/guile-log/guile-prolog/closure.scm \
logic/guile-log/umatch.scm \ logic/guile-log/umatch.scm \
logic/guile-log/macros.scm \ logic/guile-log/macros.scm \
logic/guile-log/run.scm \ logic/guile-log/run.scm \
...@@ -39,6 +38,7 @@ SOURCES = \ ...@@ -39,6 +38,7 @@ SOURCES = \
logic/guile-log/util.scm \ logic/guile-log/util.scm \
logic/guile-log/functional-database.scm \ logic/guile-log/functional-database.scm \
logic/guile-log/dynamic-features.scm \ logic/guile-log/dynamic-features.scm \
logic/guile-log/guile-prolog/closure.scm \
logic/guile-log/prolog/pre.scm \ logic/guile-log/prolog/pre.scm \
logic/guile-log/prolog/error.scm \ logic/guile-log/prolog/error.scm \
logic/guile-log/prolog/closed.scm \ logic/guile-log/prolog/closed.scm \
......
...@@ -184,7 +184,7 @@ ...@@ -184,7 +184,7 @@
(match tree (match tree
((#f -1) ((#f -1)
(p)) (p))
((f 0) ((x 0)
(f p x)) (f p x))
((l n . r) ((l n . r)
(lp-r (lambda () (lp p l)) r)))) (lp-r (lambda () (lp p l)) r))))
......
...@@ -12,7 +12,8 @@ ...@@ -12,7 +12,8 @@
(<define> (closure_p x) (when (prolog-closure? (<lookup> x)))) (<define> (closure_p x) (when (prolog-closure? (<lookup> x))))
(<define> (closure_state_ref x l) (<=> l ,(prolog-closure-state (<lookup> x)))) (<define> (closure_state_ref x l) (<=> l ,(prolog-closure-state (<lookup> x))))
(<define> (closure_is_closed x) (when (and (prolog-closure? (<lookup> x)) (<define> (closure_is_closed x)
(prolog-closer-clsed (<lookup> x))))) (when (and (prolog-closure? (<lookup> x))
(prolog-closer-closed (<lookup> x)))))
(<define> (closure_code_ref x l) (<=> l ,(prolog-closure-parent (<lookup> x)))) (<define> (closure_code_ref x l) (<=> l ,(prolog-closure-parent (<lookup> x))))
\ No newline at end of file
...@@ -34,14 +34,14 @@ ...@@ -34,14 +34,14 @@
(mk-sym dynamic_feature) (mk-sym dynamic_feature)
(<define> (fail h) (type_error dynamic_feature h)) (<define> (fail- h) (type_error dynamic_feature h))
(define-syntax-rule (mk backtrack_dynamic_object backtrack-dynamic-object) (define-syntax-rule (mk backtrack_dynamic_object backtrack-dynamic-object)
(<define> (backtrack_dynamic_object . h) (<define> (backtrack_dynamic_object . h)
(<recur> lp ((h h)) (<recur> lp ((h h))
(if (pair? h) (if (pair? h)
(<and> (<and>
(backtrack-dynamic-object (car h) fail) (backtrack-dynamic-object (car h) fail-)
(lp (cdr h))) (lp (cdr h)))
<cc>)))) <cc>))))
...@@ -56,9 +56,9 @@ ...@@ -56,9 +56,9 @@
(define a_b (define a_b
(<case-lambda> (<case-lambda>
((h code) ((h code)
(a-b h (<lambda> () (goal-eval code)) fail)) (a-b h (<lambda> () (goal-eval code)) fail-))
((h . l) ((h . l)
(a-b h (<lambda> () (<apply> a_b l)) fail))))) (a-b h (<lambda> () (<apply> a_b l)) fail-)))))
(mk-with with_fluid_guard_dynamic_object (mk-with with_fluid_guard_dynamic_object
with-fluid-guard-dynamic-object) with-fluid-guard-dynamic-object)
...@@ -81,10 +81,10 @@ ...@@ -81,10 +81,10 @@
(mk-with with_not_backtrack_dynamic_object (mk-with with_not_backtrack_dynamic_object
with-not-backtrack-dynamic-object) with-not-backtrack-dynamic-object)
(<define> (copy_dynamic_object_ x y) (copy-dynamic-object x y #:fail fail)) (<define> (copy_dynamic_object_ x y) (copy-dynamic-object x y #:fail fail-))
(compile-prolog-string "copy_dynamic_object(X->Y) :- copy_dynamic_object_(X,Y)") (compile-prolog-string "copy_dynamic_object(X->Y) :- copy_dynamic_object_(X,Y)")
(<define> (failxy s p cc x y tx ty) (fail y)) (<define> (failxy s p cc x y tx ty) (fail- y))
(<define> (set_dynamic_ x y) (set-dynamic x y #:fail fail #:failxy failxy)) (<define> (set_dynamic_ x y) (set-dynamic x y #:fail fail #:failxy failxy))
(compile-prolog-string "set_dynamic(X->Y) :- set_dynamic_(X,Y)") (compile-prolog-string "set_dynamic(X->Y) :- set_dynamic_(X,Y)")
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
#:export(make_fluid fluid_ref fluid_set)) #:export(make_fluid fluid_ref fluid_set))
(<define> (make_fluid Init Out) (<=> Out ,(make-fluid (<lookup> Init)))) (<define> (make_fluid Init Out) (<=> Out ,(make-fluid (<lookup> Init))))
(<define> (fluid_ref Fluid Out) (<=> Out ,(fluid-ref (<lookuo> Fluid)))) (<define> (fluid_ref Fluid Out) (<=> Out ,(fluid-ref (<lookup> Fluid))))
(<define> (fluid_set Fluid Val) (<code> (fluid-set! (<lookup> Fluid) (<define> (fluid_set Fluid Val) (<code> (fluid-set! (<lookup> Fluid)
(<lookup> Val)))) (<lookup> Val))))
...@@ -81,14 +81,15 @@ ...@@ -81,14 +81,15 @@
(<code> (<code>
(usr-set! 'stall-ret '()) (usr-set! 'stall-ret '())
(fluid-set! *usr-state* S) (fluid-set! *usr-state* S)
(set! lold (<state-ref>)))) (set! lold (<state-ref>)))
(<stall>))
((l) ((l)
(<code> (<code>
(usr-set! 'stall-ret l) (usr-set! 'stall-ret l)
(fluid-set! *usr-state* S) (fluid-set! *usr-state* S)
(set! lold (<state-ref>)))) (set! lold (<state-ref>)))
(<stall>))) (<stall>))))
(<define> (thin_stall) (<define> (thin_stall)
(<stall>)) (<stall>))
......
...@@ -286,7 +286,7 @@ ...@@ -286,7 +286,7 @@
((<= x n) ((<= x n)
<cc>)))) <cc>))))
(<define> (select l bef len lout) (<define> (select* l bef len lout)
(<recur> lp1 ((i 0) (l2 l)) (<recur> lp1 ((i 0) (l2 l))
(if (< i bef) (if (< i bef)
(<match> (#:name select1) (l2) (<match> (#:name select1) (l2)
...@@ -335,7 +335,7 @@ ...@@ -335,7 +335,7 @@
(iter bef n) (iter bef n)
(iter len (- n (<scm> bef))) (iter len (- n (<scm> bef)))
(<=> aft ,(- n (<scm> bef) (<scm> len))) (<=> aft ,(- n (<scm> bef) (<scm> len)))
(select l (<scm> bef) (<scm> len) subsub) (select* l (<scm> bef) (<scm> len) subsub)
(<=> sub ,(list->string (plist->chars (<scm> subsub))))))) (<=> sub ,(list->string (plist->chars (<scm> subsub)))))))
(else (else
(<var> (subsub latm lsub) (<var> (subsub latm lsub)
...@@ -346,7 +346,7 @@ ...@@ -346,7 +346,7 @@
(iter bef (- natm nsub)) (iter bef (- natm nsub))
(<=> len nsub) (<=> len nsub)
(<=> aft ,(- natm nsub (<scm> bef))) (<=> aft ,(- natm nsub (<scm> bef)))
(select latm (<scm> bef) (<scm> nsub) lsub))))))) (select* latm (<scm> bef) (<scm> nsub) lsub)))))))
(set! (@@ (logic guile-log prolog var) get-double-quote-flag-fkn) (set! (@@ (logic guile-log prolog var) get-double-quote-flag-fkn)
(lambda () (lambda ()
......
...@@ -10,7 +10,7 @@ ...@@ -10,7 +10,7 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 eval-string) #:use-module (ice-9 eval-string)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:export (goal scm fff define-goal-transformer add-op-map op->fkn #:export (goal scm define-goal-transformer add-op-map op->fkn
get-functor-stx op->>fkn maybe-op)) get-functor-stx op->>fkn maybe-op))
(define do-print #f) (define do-print #f)
...@@ -275,10 +275,3 @@ ...@@ -275,10 +275,3 @@
(let ((l (get.. "," l)) (let ((l (get.. "," l))
(v-stx (datum->syntax stx v))) (v-stx (datum->syntax stx v)))
(apply (term-functor v-stx 'scm n m) stx n m l))))) (apply (term-functor v-stx 'scm n m) stx n m l)))))
(define (fff stx x)
(match x
((and atom (#:atom f _ _ _ _))
(get-binding atom stx (lambda (x) x)))
((#:variable v _ _)
(datum->syntax stx v))))
\ No newline at end of file
...@@ -36,6 +36,8 @@ ...@@ -36,6 +36,8 @@
namespace_switch namespace_switch
)) ))
(define namespace_switch #f)
(<define> (namespace_p (<define> (namespace_p
x) (when (namespace? (<lookup> x)))) x) (when (namespace? (<lookup> x))))
(<define> (namespace_val (<define> (namespace_val
...@@ -108,7 +110,8 @@ Two things will happen ...@@ -108,7 +110,8 @@ Two things will happen
(<=> x ,(fluid-ref white-list-namespaces))) (<=> x ,(fluid-ref white-list-namespaces)))
(<define> (namespace_white_list_set x) (<define> (namespace_white_list_set x)
(<code> (fluid-set! white-list-namespaces (<scm> x)))) (<code> (fluid-set! white-list-namespaces (<scm> x))))
(define namespace_switch #f)
(mk-sym namespace_switch) (mk-sym namespace_switch)
(define (err x) (<wrap> permission_error namespace_swich true x)) (define (err x) (<wrap> permission_error namespace_swich true x))
......
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