bugfix

parent e76fe5df
......@@ -15,34 +15,25 @@
#:use-module (logic guile-log prolog namespace)
#:export (unify))
(define-syntax-rule (aif it p a b) (let ((it p)) (if it a b)))
(define attributeU (@@ (logic guile-log macros) attributeU))
(define-syntax-rule
(mk-unify name def
(x y sx sy kind vec build gvar? gid scm? scm-it
do-scm-x do-scm-y
do-attvar-x do-attvar-y
do-gvar-x do-gvar-y
do-namespace
(x y kind vec build gvar? gid scm? scm-it
do-scm-x do-scm-y
do-attvar-x do-attvar-y
do-gvar-x do-gvar-y
do-namespace-x do-namespace-y
inc check
)
(scm ...)
(sc ...)
defs ...)
(define (name s p cc . def)
defs ...
(define (check x y m)
(if (vhash? x)
(vhash-assoc (cons x y) m)
#f))
(define (inc x y m)
(if (vhash? m)
(vhash-cons (cons x y) #t m)
(if (< m 10)
(+ m 1)
(vhash-cons (cons x y) #t vlist-null))))
(<define> (do-prolog-closure lp x y m sc ...)
(if (eq? (prolog-closure-closure x)
(prolog-closure-closure y))
......@@ -98,7 +89,7 @@
(lp-or (+ i 1) m)))
<fail>)))
(<define> (do-not lp x y m)
(<define> (do-not lp x y m sc ...)
(<and>
(<not>
(lp (vector-ref x 1) y 0 sc ...)
......@@ -212,10 +203,10 @@
<fail>)))
((namespace? x)
(do-namespace lp x y m sc ...))
(do-namespace-x lp x y m sc ...))
((namespace? y)
(do-namespace lp y x m sc ...))
(do-namespace-y lp y x m sc ...))
((prolog-closure? x)
(if (prolog-closure? y)
......@@ -243,13 +234,15 @@
(id get-vec-id))
(mk-unify unify-vec (x y kind vec)
(x y sx sy kind vec build gvar? gid scm? scm-it
do-scm-x do-scm-y
do-attvar-x do-attvar-y
do-gvar-x do-gvar-y
do-namespace)
(x y kind vec build gvar? gid scm? scm-it
do-scm-x do-scm-y
do-attvar-x do-attvar-y
do-gvar-x do-gvar-y
do-namespace-x do-namespace-y
inc check)
((sx #f) (sy #f))
(sx sy)
(define (gvar? x) (vec? x))
(define (gid x) (get-vec-id x))
(define (scm? x) (scmwrap? x))
......@@ -279,11 +272,21 @@
(attributeU (build S sx x) y kind)
(<cc> m))
(<define> (do-namespace lp x y m sc ...)
(if (ns-unify S (build S sx x) (build S sy y) kind)
(<cc> m)
<fail>))
(<define> (do-namespace-x lp x y m sx sy)
(let ((s (ns-unify S (build S sx x) (build S sy y) kind)))
(if s
(<with-s> s (<cc> m))
<fail>)))
(<define> (do-namespace-y lp x y m sx sy)
(let ((s (ns-unify S (build S sy y) (build S sx x) kind)))
(if s
(<with-s> s (<cc> m))
<fail>)))
(define (check x y m) #f)
(define (inc x y m) m)
(define (build s p x)
(if p
x
......@@ -325,11 +328,12 @@
x)))))))
(mk-unify unify (x y kind)
(x y sx sy kind vec build gvar? gid scm? scm-it
do-scm-x do-scm-y
do-attvar-x do-attvar-y
do-gvar-x do-gvar-y
do-namespace)
(x y kind vec build gvar? gid scm? scm-it
do-scm-x do-scm-y
do-attvar-x do-attvar-y
do-gvar-x do-gvar-y
do-namespace-x do-namespace-y
inc check)
()
()
(<define> (do-scm-x lp x y m) (<cc> #f))
......@@ -345,11 +349,30 @@
(attributeU x y kind)
(<cc> m))
(<define> (do-namespace lp x y m)
(if (ns-unify S x y kind)
(<cc> m)
<fail>))
(<define> (do-namespace-x lp x y m)
(let ((s (ns-unify S x y kind)))
(if s
(<with-s> s (<cc> m))
<fail>)))
(<define> (do-namespace-y lp x y m)
(let ((s (ns-unify S y x kind)))
(if s
(<with-s> s (<cc> m))
<fail>)))
(define (check x y m)
(if (vhash? x)
(vhash-assoc (cons x y) m)
#f))
(define (inc x y m)
(if (vhash? m)
(vhash-cons (cons x y) #t m)
(if (< m 10)
(+ m 1)
(vhash-cons (cons x y) #t vlist-null))))
(define (gvar? x) #f)
(define (gid x) (get-vec-id x))
(define (scm? x) #f)
......
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