non compiling version of asserts

parent e208b94d
......@@ -181,8 +181,12 @@
catch throw call unify_with_occurs_check copy_term findall bagof
setof var atom integer float atomic compound nonvar number
dynamic multifile discontiguous
assertaf assertzf assertgf
asserta assertz assertg clause clausei
assertac assertzc assertgc
asserta assertz assertg
clause clausei
retract abolish current_predicate
op current_op set_prolog_flag generalized
repeat once
......
......@@ -3,6 +3,7 @@
#:use-module (logic guile-log prolog directives)
#:use-module (logic guile-log functional-database)
#:use-module (logic guile-log match)
#:use-module ((logic guile-log umatch) #:select (gp-cp))
#:use-module (logic guile-log prolog goal)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log prolog error)
......@@ -14,8 +15,8 @@
#:use-module (logic guile-log)
#:use-module (ice-9 match)
#:re-export (define-dynamic define-dynamic! define-dynamic-f)
#:export (asserta assertz assertaf assertzf
assertg assertgf assertg-source
#:export (asserta assertz assertac assertzc assertaf assertzf
assertg assertgc assertgf assertg-source
clause clausei retract abolish current_predicate
asserta-source assertz-source assertg-source
asserta-source+ assertz-source+ assertg-source+
......@@ -107,6 +108,27 @@
(mk-assert++ assertg+_ <push-gen>)
(define (simple s a)
(let ((a (gp-cp a s)))
(list
(lambda () a)
(lambda ()
(lambda (s p cc cut scut x)
((<lambda> (x) (<=> x ,(gp-cp a S))) s p cc x)))
(lambda () (cons a true)))))
(define (simple-3 s a g)
(let ((a.g (gp-cp (cons a g) s)))
(list
(lambda () (car a.g))
(lambda ()
(lambda (s p cc cut scut x)
((<lambda> (x)
(let ((a.g (gp-cp a.g S)))
(<=> x ,(car a.g))
(goal-eval (cdr a.g))))
s p cc x)))
(lambda () a.g))))
(define-syntax-rule (mk-assert+ asserta <push-dynamic>)
(define asserta
......@@ -121,7 +143,72 @@
(#((":-" Head Body ))
(<and>
(<values> (Head Body) (analyze Head Body))
;(<values> (HHead BBody) (analyze Head Body))
(<recur> lp ((Head Head))
(<<match>> (#:mode - #:name subassert) (Head)
((? <var?>)
(instantiation_error))
(#((F . A))
(<cut>
(<recur> lp2 ((F (<lookup> F)))
(if (not (dynamic? F))
(if (procedure? F)
(if (object-property F 'prolog-symbol)
(lp2 (F))
(permission_error modify static_procedure
(vector
(list divide
F
(length (<scm> A))))))
(type_error callable F))
(<push-dynamic> (<lookup> F) U
(simple-3 S A Body))))))
(F
(if (procedure? (<lookup> F))
(lp (vector (list F)))
(type_error callable Head)))))))
(#((F . A))
(<cut>
(<recur> lp ((F (<lookup> F)))
(if (not (dynamic? F))
(if (procedure? F)
(if (object-property F 'prolog-symbol)
(lp (F))
(permission_error modify static_procedure
(vector
(list divide
F
(length (<scm> AA))))))
(type_error callable F))
(<and>
(<push-dynamic> (<lookup> F) (simple S A)))))))
(F
(if (procedure? (<lookup> F))
(asserta (vector (list F)) ext)
(type_error callable Arg))))))))
(mk-assert+ asserta_ <push-dynamic>)
(mk-assert+ assertz_ <append-dynamic>)
(mk-assert+ assertg_ <push-gen>)
(define-syntax-rule (mk-assertc+ asserta <push-dynamic>)
(define asserta
(<case-lambda>
((Arg ext)
(<var> (u)
(asserta Arg u ext)))
((Arg U ext)
(<<match>> (#:mode - #:name asserta) (Arg)
((? <var?>)
(instantiation_error))
(#((":-" Head Body ))
(<and>
(<values> (HHead BBody) (analyze Head Body))
(<recur> lp ((Head Head))
(<<match>> (#:mode - #:name subassert) (Head)
((? <var?>)
......@@ -143,8 +230,8 @@
(catch #t
(lambda ()
(compile-prolog (<scm> S)
(<scm> A)
(<scm> Body)
(<scm> AA)
(<scm> BBody)
#f
ext))
(lambda x
......@@ -158,7 +245,7 @@
(#((F . A))
(<cut>
(<values> (A Body) (analyze A true))
(<values> (AA BBody) (analyze A true))
(<recur> lp ((F (<lookup> F)))
(if (not (dynamic? F))
(if (procedure? F)
......@@ -168,14 +255,14 @@
(vector
(list divide
F
(length (<scm> A))))))
(length (<scm> AA))))))
(type_error callable F))
(<and>
(<push-dynamic> (<lookup> F)
(catch #t
(lambda () (compile-prolog (<scm> S) (<scm> A)
Body #f
(<push-dynamic> (<lookup> F)
(catch #t
(lambda () (compile-prolog (<scm> S) (<scm> AA)
NBody #f
ext))
(lambda x
(format #t "PROLOG HOT COMPILE ERROR:~%~a~%~%" x)
......@@ -186,9 +273,9 @@
(asserta (vector (list F)) ext)
(type_error callable Arg))))))))
(mk-assert+ asserta_ <push-dynamic>)
(mk-assert+ assertz_ <append-dynamic>)
(mk-assert+ assertg_ <push-gen>)
(mk-assertc+ assertac_ <push-dynamic>)
(mk-assertc+ assertzc_ <append-dynamic>)
(mk-assertc+ assertgc_ <push-gen>)
(define (get-name f)
(let ((mod (procedure-property f 'module)))
......@@ -376,6 +463,21 @@
(assertg_ x u ext)
(assertg_ x ext)))
(<define*> (assertac x #:optional (u #f) #:key (ext #f))
(if u
(assertac_ x u ext)
(assertac_ x ext)))
(<define*> (assertzc x #:optional (u #f) #:key (ext #f))
(if u
(assertzc_ x u ext)
(assertzc_ x ext)))
(<define*> (assertgc x #:optional (u #f) #:key (ext #f))
(if u
(assertgc_ x u ext)
(assertgc_ x ext)))
(<define*> (assertaf x #:optional (u #f) #:key (ext #f))
(if u
(asserta+_ x u ext)
......
......@@ -1039,8 +1039,8 @@
s
(lambda ()
(gp-unwind fr)
(cons
(lp (car data))
(cons
(lp (car data))
(lp2 (cdr data))))
(lambda (ss p x)
(gp-unwind fr)
......
......@@ -128,6 +128,18 @@ f4(A,B) :- mk({1,2},X),(A⊔B)⊂X.
t(ftheory(cls(cS))),
X is {a-2},t(ftheory(cls(X))),
Y is {a-2,b-4},t(ftheory(cls(Y,aT))).
test2 :-
asserta(f(1)),
asserta(f(1)),
asserta(f(1)),
asserta(f(1)),
asserta(f(1)),
asserta(f(1)),
asserta(f(1)),
asserta(f(1)),
asserta(f(1)),
asserta(f(1)).
")
(prolog-run 1 () (test))
......
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