do not use depricated features + added dynamic features for prolog

parent 771a57df
......@@ -26,7 +26,6 @@ SOURCES = \
logic/guile-log/collects.scm \
logic/guile-log/canonacalize.scm \
logic/guile-log/kanren.scm \
logic/guile-log/grep.scm \
logic/guile-log/hash.scm \
logic/guile-log/memoize.scm \
logic/guile-log/parsing/scanner.scm \
......@@ -34,6 +33,7 @@ SOURCES = \
logic/guile-log/parsing/operator-parser.scm \
logic/guile-log/parsing/scheme.scm \
logic/guile-log/parsing/sch-match.scm \
logic/guile-log/grep.scm \
logic/guile-log/dynlist.scm \
logic/guile-log/postpone.scm \
logic/guile-log/util.scm \
......@@ -64,6 +64,7 @@ SOURCES = \
logic/guile-log/iso-prolog.scm \
logic/guile-log/guile-prolog/continuations.scm \
logic/guile-log/guile-prolog/hash.scm \
logic/guile-log/guile-prolog/dynamic-features.scm \
logic/guile-log/guile-prolog/interleave.scm
AM_MAKEINFOFLAGS=--force
......
......@@ -1874,7 +1874,7 @@ There is a section about the scheme part of this interface, here we concentrate
@code{with_fluid_guard_dynamic_object(o,...,code)}, the same as above, but with an extra fluid guard at the success edge of @code{code}.
@code{with_fluid_guard_synamic_object_once(o,...,code)}, the same as above but takes an optimization by forcing the @code{code} to only succeeds once.
@code{with_fluid_guard_dynamic_object_once(o,...,code)}, the same as above but takes an optimization by forcing the @code{code} to only succeeds once.
@subsubsection utils,
There are a few general util funcitons used to manage the state of the dynamic objects in a safe way.
......
......@@ -35,6 +35,8 @@
<solor-2>
<solor-step>
<solor-step-2>))
(define Inf (inf))
(define -Inf (- (inf)))
(<define> (<collect> Lam X L)
(<fold> cons '() Lam X L))
......@@ -55,17 +57,17 @@
(<fix-fold> * 1 Lam X Y L))
(<define> (<max> Lam X L)
(<fold> max -Inf.0 Lam X L))
(<fold> max -Inf Lam X L))
(<define> (<max-2> Lam X Y L)
(<fix-fold> max -Inf.0 Lam X Y L))
(<fix-fold> max -Inf Lam X Y L))
(<define> (<min> Lam X L)
(<fold> min Inf.0 Lam X L))
(<fold> min Inf Lam X L))
(<define> (<min-2> Lam X Y L)
(<fix-fold> mix Inf.0 Lam X Y L))
(<fix-fold> min Inf Lam X Y L))
(define (and* x y) (and x y))
(define (or* x y) (or x y))
(<define> (<soland> Lam X L)
......@@ -99,16 +101,16 @@
(<fix-fold> * 1 Lam X Y L))
(<define> (<max-step> Lam X L)
(<fold-step> max -Inf.0 Lam X L))
(<fold-step> max -Inf Lam X L))
(<define> (<max-step-2> Lam X Y L)
(<fix-fold-step> max -Inf.0 Lam X Y L))
(<fix-fold-step> max -Inf Lam X Y L))
(<define> (<min-step> Lam X L)
(<fold> min Inf.0 Lam X L))
(<fold> min Inf Lam X L))
(<define> (<min-step-2> Lam X Y L)
(<fix-fold> mix Inf.0 Lam X Y L))
(<fix-fold> min Inf Lam X Y L))
(<define> (<soland-step> Lam X L)
(<fold> and* #t Lam X L))
......
......@@ -11,7 +11,8 @@
#:re-export (get-index-set)
#:export (define-dynamic dynamic-push dynamic-prepend dynamic-compile
dynamic-remove dynamic-env-ref dynamic-env-set!
;get-index-set
dynamic-refcount++ dynamic-refcount-- dynamic-truncate!
dynamic-compile-index
dynamic-compile-index dynamic?
dynamic-abolish mk-dyn define-dynamic!
<with-dynamic-functions>
......
(define-module (logic guile-log prolog dynamic-features)
#:use-module (logic guile-log)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog goal-functors)
#:export(backtrack_dynamic_object
not_backtrack_dynamic_object
fluid_guard_dynamic_object
state_guard_dynamic_object
state_guard_dynamic_object_zip
always_state_guard_dynamic_object
with_fluid_guard_dynamic_object
with_fluid_guard_dynamic_object_once
with_state_guard_dynamic_object
with_state_guard_dynamic_object_zip
with_always_state_guard_dynamic_object
with_backtrack_dynamic_object
with_not_backtrack_dynamic_object
copy_dynamic_object
set_dynamic
dynamic_feature
))
(mk-sym dynamic_feature)
(<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))
(when (pair? h)
(backtrack-dynamic-object (car h) fail)
(lp (cdr h))))))
(mk backtrack_dynamic_object backtrack-dynamic-object)
(mk not_backtrack_dynamic_object not-backtrack-dynamic-object)
(mk fluid_guard_dynamic_object fluid-guard-dynamic-object)
(mk state_guard_dynamic_object state-guard-dynamic-object)
(mk always_state_guard_dynamic_object always-state-guard-dynamic-object)
(define-syntax-rule (mk-with a_b a-b)
(define a_b
(<case-lambda>
((h code)
(a-b h (<lambda> () (goal-eval code)) fail))
((h . l)
(a-b h (<lambda> () (<apply> a_b l)) fail)))))
(mk-with with_fluid_guard_dynamic_object
with-fluid-guard-dynamic-object)
(mk-with with_fluid_guard_dynamic_object_once
with-fluid-guard-dynamic-object-once)
(mk-with with_state_guard_dynamic_object
with-state-guard-dynamic-object)
(mk-with with_state_guard_dynamic_object_zip
with-state-guard-dynamic-object-zip)
(mk-with with_always_state_guard_dynamic_object
with-always-state-guard-dynamic-object)
(mk-with with_backtrack_dynamic_object
with-backtrack-dynamic-object)
(mk-with with_not_backtrack_dynamic_object
with-not-backtrack-dynamic-object)
(<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> (set_dynamic_ x y) (set-dynamic x y #:fail fail #:failxy failxy))
(compile-prolog-string "set_dynamic(X->Y) :- set_dynamic_(X,Y)")
(define-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog base)
#:use-module (logic guile-log prolog parser)
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (logic guile-log prolog directives)
#:use-module (logic guile-log prolog dynamic)
......@@ -12,6 +13,7 @@
#:use-module (logic guile-log prolog char-conversion)
#:use-module (logic guile-log prolog conversion)
#:use-module (logic guile-log prolog names)
#:export (reset-flags reset-prolog)
#:re-export (;; Scheme functions
compile-prolog-string compile-prolog-file
save-operator-table prolog-run
......@@ -19,8 +21,7 @@
save-char-conversion-table
reset-char-conversion
reset-operator-map
reset-flags
reset-prolog
;; Math
sin cos atan exp log sqrt
......
......@@ -38,10 +38,12 @@
(re-export define-and-log
define-guile-log guile-log-macro? log-code-macro log-code-macro?)
(cond-expand
(guile-2.2
(define-syntax-rule (fluid-let-syntax . x) (syntax-parameterize . x)))
(else #f))
(if (not (defined? 'syntax-parameterize))
(module-set!
(current-module)
'syntax-parameterize
(module-ref (current-module) 'fluid-let-syntax)))
(define-syntax-parameter S
(lambda (x) (error "S should be bound by fluid-let")))
......@@ -62,14 +64,14 @@
(export _)
(define-syntax-rule (fl-let (cut s p cc) code ...)
(fluid-let-syntax ((S (identifier-syntax s))
(syntax-parameterize ((S (identifier-syntax s))
(P (identifier-syntax p))
(CC (identifier-syntax cc))
(CUT (identifier-syntax cut)))
code ...))
(define-syntax-rule (cc-let (cc) code ...)
(fluid-let-syntax ((CC (identifier-syntax cc)))
(syntax-parameterize ((CC (identifier-syntax cc)))
code ...))
(define-syntax-rule (<scm> x) (gp->scm x S))
......@@ -292,28 +294,28 @@
(syntax-rules ()
((_ (cut s p cc) ccc code ...)
(let ((cccc ccc))
(fluid-let-syntax ((CC (identifier-syntax cccc)))
(syntax-parameterize ((CC (identifier-syntax cccc)))
(parse<> (cut s p cccc) (<and> code ...)))))))
(define-guile-log <with-s>
(syntax-rules ()
((_ (cut s p cc) ss code ...)
(let ((sss ss))
(fluid-let-syntax ((S (identifier-syntax sss)))
(syntax-parameterize ((S (identifier-syntax sss)))
(parse<> (cut sss p cc) (<and> code ...)))))))
(define-guile-log <with-fail>
(syntax-rules ()
((_ (cut s p cc) pp code ...)
(let ((ppp pp))
(fluid-let-syntax ((P (identifier-syntax ppp)))
(syntax-parameterize ((P (identifier-syntax ppp)))
(parse<> (cut s ppp cc) (<and> code ...)))))))
(define-guile-log <with-cut>
(syntax-rules ()
((_ (cut s p cc) cutt code ...)
(let ((cuttt cutt))
(fluid-let-syntax ((CUT (identifier-syntax cuttt)))
(syntax-parameterize ((CUT (identifier-syntax cuttt)))
(parse<> (cuttt s p cc) (<and> code ...)))))))
......@@ -902,10 +904,10 @@ MAKE SURE TO REVISIT THIS IDEA LATER
|#
(define-guile-log <fluid-let-syntax>
(define-guile-log <syntax-parameterize>
(syntax-rules ()
((_ w a code ...)
(fluid-let-syntax a
(syntax-parameterize a
(parse<> w (<and> code ...))))))
(define-guile-log <windlevel>
......@@ -979,7 +981,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(define-syntax-rule (lam q . code)
(<lambda> (p ... . q)
(<fluid-let-syntax> ((X (lambda (x)
(<syntax-parameterize> ((X (lambda (x)
(syntax-case x ()
((x . l)
#'(p . l))
......
......@@ -111,10 +111,11 @@
(match (pp 'top x)
(((('xfx _ ":-" _) (#:term (#:atom v . _) y . _) z n m))
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(mk-rhs stx
`(#:term (#:atom assertz #f #f ,n ,m)
,(car x) ,n ,m))))
`(#:translated
1 ,#`(prolog-run
1 () #,(mk-rhs stx
`(#:term (#:atom assertz #f #f ,n ,m)
,(car x) ,n ,m))))
(match y
(()
(list v '() z))
......@@ -123,10 +124,11 @@
(((('xfx _ ":-" _) (#:atom v . _) z n m))
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(mk-rhs stx
`(#:term (#:atom assertz #f #f ,n ,m)
,(car x) ,n ,m))))
`(#:translated
1 ,#`(prolog-run
1 () #,(mk-rhs stx
`(#:term (#:atom assertz #f #f ,n ,m)
,(car x) ,n ,m))))
(list v '() z)))
(((('xfx _ ":-" _) (((_ _ op _) a b _ _)) z _ _))
......@@ -150,18 +152,20 @@
((#:atom v _ _ n m)
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom assertz #f #f ,n ,m)
,x ,n ,m))))
`(#:translated
1 ,#`(prolog-run
1 () #,(goal stx
`(#:term (#:atom assertz #f #f ,n ,m)
,x ,n ,m))))
(list v '() '())))
((#:term (#:atom v . _) y n m)
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom assertz #f #f ,n ,m)
,x ,n ,m))))
`(#:translated
1 ,#`(prolog-run
1 () #,(goal stx
`(#:term (#:atom assertz #f #f ,n ,m)
,x ,n ,m))))
(list v (get.. "," y) '())))))
......
......@@ -205,7 +205,7 @@
(((#:number prio _ _)
(#:atom spec . _)
(or (#:string x _ _) (#:atom x . _) (#:symbolic x _ _)))
(prolog-run 1 (op prio (make-spec spec) x))
(prolog-run 1 () (op prio (make-spec spec) x))
#f)
(((#:number prio _ _)
......@@ -213,7 +213,7 @@
(#:list li _ _))
(match (get.. "," li)
(((or (#:atom x . _) (#:string x _ _) (#:symbolic x _ _)) ...)
(prolog-run 1 (op prio (make-spec spec) x))
(prolog-run 1 () (op prio (make-spec spec) x))
#f)
(_ (format #t "Bad op/3 directive at ~a~%" (get-refstr N M)) #t)))
......
......@@ -92,6 +92,27 @@
(define newf (@@ (logic guile-log code-load) gp-newframe))
(define unw (@@ (logic guile-log code-load) gp-unwind))
(define *unwind-parameters* (make-fluid '()))
(begin
(define gp-unwind
(lambda (fr)
(unw fr)
(let ((l.a (fluid-ref *unwind-parameters*)))
(unw fr)
(if (pair? l.a)
(for-each
(lambda (f) ((car f) (cdr f)))
(cdr l.a))))))
(define (gp-newframe s)
(let ((l.a (fluid-ref *unwind-parameters*)))
(if (pair? l.a)
(gp-fluid-set *unwind-parameters*
(cons l
(map (lambda (f) (cons f (f)))
(car l.a)))))
(newf s))))
(define gp-fluid-set! fluid-set!)
;; assq kind of base structure
......@@ -524,28 +545,3 @@
(unw fr)))
;;Use these if the code i bug free ;-)
(define *unwind-parameters* (make-fluid '()))
(begin
(define gp-unwind
(lambda (fr)
(unw fr)
(let ((l (fluid-ref *unwind-parameters*)))
(if (pair? l)
(for-each
(lambda (f)
((car f) (cdr f)))
l)))))
(define (gp-newframe s)
(let ((l (fluid-ref *unwind-parameters* )))
(if (pair? l)
(fluid-set! *unwind-parameters*
(map (lambda (f)
(let ((f (car f)))
(cons f (f))))
l)))
(newf s))))
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