the dynamic functions db framework is almost finished

parent 3b58bcf8
......@@ -13,7 +13,7 @@
dynamic-remove dynamic-env-ref dynamic-env-set!
;get-index-set
dynamic-compile-index dynamic?
dynamic-abolish mk-dyn
dynamic-abolish mk-dyn define-dynamic!
<with-dynamic-functions>
<push-dynamic>
<append-dynamic>
......@@ -503,6 +503,12 @@ add/run * vlist *
(define f #f)
(mk-dyn 'f (lambda (x) (set! f x)))))
(define-syntax-rule (define-dynamic! f)
(begin
(if (not (defined? 'f))
(define! 'f #f))
(mk-dyn 'f (lambda (x) (set! f x)))))
(define (dynamic? f)
(let ((env (object-property f 'dynamic-data)))
(if env
......
......@@ -22,6 +22,13 @@
#:use-module (logic guile-log parser)
#:export (compile-string compile-file read-prolog-term save-operator-table))
(define-syntax-rule (define-or-set! f x)
(let ((xx x))
(if (defined? 'f)
(set! f xx)
(define! 'f xx))
(set-procedure-property! xx 'name 'f)))
(define do-print #f)
(define pp
......@@ -49,14 +56,18 @@
(define (compile stx l)
(define (less x y)
(match (pp 'less-x x)
((#:translated x)
#t)
((#:translated n x)
(match (pp 'less-y y)
((#:translated m y)
(< n m))
(_ #t)))
((#f #f _)
#t)
((f xa xb)
(match (pp 'less-y y)
((#:translated _)
((#:translated _ _)
#f)
((#f #f _)
......@@ -75,10 +86,10 @@
(match (pp 'top x)
(((('xfx _ ":-" _) (#:term (#:atom v . _) y . _) z n m))
(if (is-dynamic? v)
`(#:translated ,#`(prolog-run
1 #,(mk-rhs stx
`(#:term (#:atom asserta ,n ,m)
,(car x) ,n ,m))))
`(#:translated 1 ,#`(prolog-run
1 #,(mk-rhs stx
`(#:term (#:atom asserta ,n ,m)
,(car x) ,n ,m))))
(match y
(()
(list v '() z))
......@@ -87,10 +98,10 @@
(((('xfx _ ":-" _) (#:atom v . _) z n m))
(if (is-dynamic? v)
`(#:translated ,#`(prolog-run
1 #,(mk-rhs stx
`(#:term (#:atom asserta ,n ,m)
,(car x) ,n ,m))))
`(#:translated 1 ,#`(prolog-run
1 #,(mk-rhs stx
`(#:term (#:atom asserta ,n ,m)
,(car x) ,n ,m))))
(list v '() z)))
(((('xfx _ ":-" _) (((_ _ op _) a b _ _)) z _ _))
......@@ -106,26 +117,26 @@
(((('fx _ ":-" _) z . _))
(list #f #f z))
((#:translated (#:untranslate x))
((#:translated _ (#:untranslate x))
(top x))
((#:translated _)
((#:translated _ _)
x)
((#:atom v n m)
(if (is-dynamic? v)
`(#:translated ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom asserta ,n ,m)
,x ,n ,m))))
`(#:translated 1 ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom asserta ,n ,m)
,x ,n ,m))))
(list v '() '())))
((#:term (#:atom v . _) y n m)
(if (is-dynamic? v)
`(#:translated ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom asserta ,n ,m)
,x ,n ,m))))
`(#:translated 1 ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom asserta ,n ,m)
,x ,n ,m))))
(list v (get.. "," y) '())))))
......@@ -133,13 +144,16 @@
(clear-syms)
(let* ((l-r (pp 'l-r (stable-sort (map top (car (pp 'compile (reverse l))))
less)))
(in.r (let lp ((l-r l-r) (r '()))
(in.r (let lp ((l-r l-r) (def '()) (r '()))
(match (pp 'ini l-r)
(((#:translated x) . l)
(lp l (cons x r)))
(x (cons r x)))))
(ini (car in.r))
(l-r (cdr in.r))
(((#:translated n x) . l)
(lp l (cons x def) r))
(x (cons* def r x)))))
(ini (reverse (car in.r)))
(evl (reverse (cadr in.r)))
(l-r (cddr in.r))
(com (let lp ((f #f) (xx #f) (l l-r) (r '()) (rl '()) (res '()))
(define (next l x y)
(if (= (length x) (length xx))
......@@ -178,7 +192,7 @@
(ppp 'res #`(begin
(add-non-defined
(quote #,(datum->syntax stx (get-syms))))
#,@ini #,@l)))))
#,@ini #,@l #,@evl)))))
(define-syntax save-operator-table
(lambda (x)
......@@ -212,7 +226,7 @@
(((rhs ...) ...) rhs)
((((v ...) ...) ...) v-new)
(f (datum->syntax stx f)))
#'(define f
#'(define-or-set! f
(<<case-lambda>>
((lhs ... (<var> (v ...) rhs)) ...)
...))))))))
......
......@@ -101,7 +101,7 @@
PI))
(define *dynamics* (make-fluid '()))
(define-syntax-rule (define-PI dynamic define-dynamic err)
(define-syntax-rule (define-PI dynamic define-dynamic! err)
(define-parser-directive (dynamic stx l N M)
#`(begin
#,@(map
......@@ -110,12 +110,12 @@
(begin
(fluid-set! *dynamics* (cons (car f)
(fluid-ref *dynamics*)))
#`(define-dynamic #,(datum->syntax stx (car f))))
#`(define-dynamic! #,(datum->syntax stx (car f))))
(begin
(fluid-set! *dynamics* (cons f
(fluid-ref *dynamics*)))
#`(define-dynamic #,(datum->syntax stx f)))))
#`(define-dynamic! #,(datum->syntax stx f)))))
((parse-PI err N M) l)))))
(define (is-dynamic? f)
......@@ -343,13 +343,13 @@
(define (mk-err nm) (string-append "at (~a,~a) in " nm ", not a PI list"))
(define-PI dynamic define-dynamic (mk-err "dynamic"))
(define-PI multifile define-multifile (mk-err "multifile"))
(define-PI discontiguous define-discontiguous (mk-err "discontiguous"))
(define-PI dynamic define-dynamic! (mk-err "dynamic"))
(define-PI multifile define-multifile! (mk-err "multifile"))
(define-PI discontiguous define-discontiguous! (mk-err "discontiguous"))
;; Do not do anything for these ones
(define-syntax-rule (define-multifile f) (define-dynamic f))
(define-syntax-rule (define-discontiguous f) (define-dynamic f))
(define-syntax-rule (define-multifile! f) (define-dynamic! f))
(define-syntax-rule (define-discontiguous! f) (define-dynamic! f))
(<define> (current_prolog_flag flag value)
(<let> ((flag (<lookup> flag)))
......
......@@ -14,7 +14,7 @@
not_less_than_zero))
#:use-module (logic guile-log)
#:use-module (ice-9 match)
#:re-export (define-dynamic)
#:re-export (define-dynamic define-dynamic!)
#:export (asserta assertz clause retract abolish current_predicate))
(define divide (@@ (logic guile-log prolog goal-transformers) divide))
......@@ -32,19 +32,24 @@
(instantiation_error))
(#((F . A))
(<cut>
(if (not (dynamic? (<lookup> F) ))
(permission_error modify static_procedure
(vector
(list divide
F
(length (<scm> A)))))
(<push-dynamic> (<lookup> F)
(catch #t
(lambda ()
(compile-prolog S A Body))
(lambda x
(format #t "~a" x)
(type_error S P CC callable Body)))))))
(<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)
(catch #t
(lambda ()
(compile-prolog S A Body))
(lambda x
(format #t "~a" x)
(type_error S P CC callable Body))))))))
(F
(if (procedure? (<lookup> F))
(lp (vector (list F)))
......@@ -52,17 +57,24 @@
(#((F . A))
(<cut>
(if (not (dynamic? (<lookup> F) ))
(permission_error modify static_procedure
(vector (list divide
F
(length (<scm> A)))))
(<push-dynamic> (<lookup> F)
(catch #t
(lambda () (compile-prolog S A true))
(lambda x
(format #t "~a" x)
(type_error S P CC callable true)))))))
(<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> A))))))
(type_error callable F))
(<push-dynamic> (<lookup> F)
(catch #t
(lambda () (compile-prolog S A true))
(lambda x
(format #t "~a" x)
(type_error S P CC callable true))))))))
(F
(if (procedure? (<lookup> F))
......@@ -85,16 +97,18 @@
(<var> (F A)
(<if> (<or> (<=> Head ,(vector (cons F A)))
(<and> (<=> Head F) (<=> A ())))
(<let> ((FF (<lookup> F)))
(<recur> lp ((FF (<lookup> F)))
(cond
((dynamic? FF)
(<clause-dynamic> FF A Body))
((procedure? FF)
(permission_error access private_procedure
(vector
(list divide
FF
(length (<scm> A))))))
(if (object-property FF 'prolog-symbol)
(lp (FF))
(permission_error access private_procedure
(vector
(list divide
FF
(length (<scm> A)))))))
(else
(type_error callable F))))
......@@ -109,34 +123,43 @@
(retract (vector (list Arg))))
(else
(<var> (Head Body F A)
(<or>
(<if> (<=> Arg ,(vector (list fact Head Body)))
(if (<var?> Head)
(instantiation_error)
(<if> (<=> Head ,(vector (cons F A)))
(<let> ((F (<lookup> F)))
(if (dynamic? F)
(<and>
(<clause-dynamic> (<lookup> F) A Body)
(<retract-dynamic> (<lookup> F) (cons A Body)))
(permission_error
modify static_procedure
(vector (list divide
F
(length (<scm> A)))))))
(<recur> lp ((F (<lookup> F)))
(cond
((dynamic? F)
(<and>
(<clause-dynamic> (<lookup> F) A Body)
(<retract-dynamic> (<lookup> F) (cons A Body))))
((object-property F 'prolog-symbol)
(lp (F)))
(else
(permission_error
modify static_procedure
(vector (list divide
F
(length (<scm> A))))))))
(type_error callable Head)))
(<if> (<=> Arg ,(vector (cons F A)))
(<let> ((F (<lookup> F)))
(if (dynamic? F)
(<recur> lp ((F (<lookup> F)))
(cond
((dynamic? F)
(<and>
(<clause-dynamic> F A true)
(<retract-dynamic> F (cons A true)))
(permission_error
modify static_procedure
(vector (list divide
F
(length (<scm> A)))))))
(type_error callable Head)))))))))
(<retract-dynamic> F (cons A true))))
((object-property F 'prolog-symbol)
(lp (F)))
(else
(permission_error
modify static_procedure
(vector (list divide
F
(length (<scm> A))))))))
(type_error callable Head))))))))
(<define> (abolish pred)
(<let> ((pred (<lookup> pred)))
......@@ -146,8 +169,8 @@
(else
(<match> (#:mode - #:name abolish) (pred)
(#((,divide F N))
(<let> ((F (<lookup> F))
(N (<lookup> N)))
(<recur> lp ((F (<lookup> F))
(N (<lookup> N)))
(cond
((or (<var?> F) (<var?> N))
(instantiation_error))
......@@ -158,6 +181,9 @@
(domain_error not_less_than_zero N)
(<code> (dynamic-abolish F)))
(type_error integer N)))
((object-property F 'prolog-symbol)
(lp (F) N))
((procedure? F)
(permission_error modify static_procedure
......@@ -175,7 +201,9 @@
(module-for-each
(lambda (k v)
(let ((v (variable-ref v)))
(if (and (procedure? v) (dynamic? v))
(if (and (procedure? v) (or (dynamic? v)
(and (object-property v 'prolog-symbol)
(v 'defined))))
(set! l (cons v l)))))
mod)
l)
......@@ -190,7 +218,11 @@
(<let> ((L (get-dyns (current-module))))
(pr-member F L)))
((procedure? F)
(<cut> (<when> (dynamic? F))))
(<cut> (<when> (or (dynamic? F)
(and (object-property F 'prolog-symbol)
(F 'defined))
(and (procedure? F)
(not (object-property F 'prolog-symbol)))))))
(else
(type_error predicate_indicator X))))))
(_
......
......@@ -661,9 +661,18 @@ floor(x) (floor x)
(define (make-unbound-fkn nm)
(letrec ((warn-message
(format #f "fkn ~a is not evaluable, will fail" f))
(d #f)
(f (lambda k
(match k
(()
(if d
d
(begin
(mk-dyn nm (lambda (x) (set! d x)))
d)))
((x) d)
((a b c . l)
(if d (apply d k)
(apply
(<lambda> l
(<let> ((e (get-flag unknown)))
......@@ -684,13 +693,13 @@ floor(x) (floor x)
(<code>
(error
"Bug in prolog flag 'unknown' implementation"))))))
a b c l))
a b c l)))
(_
(type_error ss p cc evaluable
(vector `(,divide ,f
,(- (length k) 1)))))))))
(set-object-property! f 'prolog-symbol #t)
f))
(<define> (once-f v)
......
......@@ -451,7 +451,7 @@
(define (parse-1 stx x)
(define (ferr f n m)
`(#:translated
`(#:translated 0
,(format
#f
"in (~a,~a) term directive ~a did not point to an available global directive"
......@@ -469,8 +469,8 @@
(p (object-property f 'prolog-directive)))
(if p
(if (procedure? p)
`(#:translated ,(p stx l N M))
`(#:translated ,(f stx l N M)))
`(#:translated 0 ,(p stx l N M))
`(#:translated 0 ,(f stx l N M)))
(ferr nm N M))))
(else
(ferr nm N M))))))
......
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