fixed the stall command

parent 0cb49701
......@@ -15,7 +15,6 @@ SOURCES = \
logic/guile-log/code-load.scm \
logic/guile-log/vlist.scm \
logic/guile-log/indexer.scm \
logic/guile-log/guile-prolog/closure.scm \
logic/guile-log/umatch.scm \
logic/guile-log/macros.scm \
logic/guile-log/run.scm \
......@@ -39,6 +38,7 @@ SOURCES = \
logic/guile-log/util.scm \
logic/guile-log/functional-database.scm \
logic/guile-log/dynamic-features.scm \
logic/guile-log/guile-prolog/closure.scm \
logic/guile-log/prolog/pre.scm \
logic/guile-log/prolog/error.scm \
logic/guile-log/prolog/closed.scm \
......@@ -184,7 +184,7 @@
(match tree
((#f -1)
((f 0)
((x 0)
(f p x))
((l n . r)
(lp-r (lambda () (lp p l)) r))))
......@@ -12,7 +12,8 @@
(<define> (closure_p x) (when (prolog-closure? (<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))
(prolog-closer-clsed (<lookup> x)))))
(<define> (closure_is_closed x)
(when (and (prolog-closure? (<lookup> x))
(prolog-closer-closed (<lookup> x)))))
(<define> (closure_code_ref x l) (<=> l ,(prolog-closure-parent (<lookup> x))))
\ No newline at end of file
......@@ -34,14 +34,14 @@
(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> (backtrack_dynamic_object . h)
(<recur> lp ((h h))
(if (pair? h)
(backtrack-dynamic-object (car h) fail)
(backtrack-dynamic-object (car h) fail-)
(lp (cdr h)))
......@@ -56,9 +56,9 @@
(define a_b
((h code)
(a-b h (<lambda> () (goal-eval code)) fail))
(a-b h (<lambda> () (goal-eval code)) fail-))
((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
......@@ -81,10 +81,10 @@
(mk-with 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)")
(<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))
(compile-prolog-string "set_dynamic(X->Y) :- set_dynamic_(X,Y)")
......@@ -3,7 +3,7 @@
#:export(make_fluid fluid_ref fluid_set))
(<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)
(<lookup> Val))))
......@@ -81,14 +81,15 @@
(usr-set! 'stall-ret '())
(fluid-set! *usr-state* S)
(set! lold (<state-ref>))))
(set! lold (<state-ref>)))
(usr-set! 'stall-ret l)
(fluid-set! *usr-state* S)
(set! lold (<state-ref>))))
(set! lold (<state-ref>)))
(<define> (thin_stall)
......@@ -286,7 +286,7 @@
((<= x n)
(<define> (select l bef len lout)
(<define> (select* l bef len lout)
(<recur> lp1 ((i 0) (l2 l))
(if (< i bef)
(<match> (#:name select1) (l2)
......@@ -335,7 +335,7 @@
(iter bef n)
(iter len (- n (<scm> bef)))
(<=> 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)))))))
(<var> (subsub latm lsub)
......@@ -346,7 +346,7 @@
(iter bef (- natm nsub))
(<=> len nsub)
(<=> 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)
(lambda ()
......@@ -10,7 +10,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 eval-string)
#: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))
(define do-print #f)
......@@ -275,10 +275,3 @@
(let ((l (get.. "," l))
(v-stx (datum->syntax stx v)))
(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 @@
(define namespace_switch #f)
(<define> (namespace_p
x) (when (namespace? (<lookup> x))))
(<define> (namespace_val
......@@ -108,7 +110,8 @@ Two things will happen
(<=> x ,(fluid-ref white-list-namespaces)))
(<define> (namespace_white_list_set x)
(<code> (fluid-set! white-list-namespaces (<scm> x))))
(define namespace_switch #f)
(mk-sym namespace_switch)
(define (err x) (<wrap> permission_error namespace_swich true x))
Markdown is supported
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment