compiles

parent 507bd438
(define-module (logic guile-log prolog goal-functors)
#:use-module ((logic guile-log) #:select
(CUT SCUT <if> <define> <match> <<match>>
<let> <apply> <cut> <fail> S
(CUT SCUT <if> <define> <match> <<match>> <lambda>
<let> <apply> <cut> <fail> S <values>
<and> <with-cut> <cc> <pp> <lookup> <var?> <pp> <cut>
<code> </.> procedure-name
define-guile-log))
......@@ -54,18 +54,22 @@
(<define> (get-vars a)
(<<match>> (#:mode -) (a)
((_ . _)
(<cc> a))
((x . y)
(<and>
(<values> (xx) (get-vars x))
(<values> (yy) (get-vars y))
(<cc> (cons xx yy))))
(#("," #(("," x y)) z)
(<values> (zz) (get-vars z))
(<cc> (cons (cons x y) zz)))
(#(("," x y))
(<cc> (cons x y)))
(z (<cc> z))))
(<define> (subst code vars)
(<<match>> (#:mode -) (code)
(#(("op2*" (and a #((f l))) code))
(<and>
(<values> (vs) (get-vars l))
(let ((va (map car vs))
(vb (map cdr vs)))
......@@ -79,23 +83,27 @@
(<cc> (lambda (x) (vector (list "op2*"
(map (lambda (v w) (cons v (w x)))
va vb)
(c x)))))))
(c x))))))))
(#(a)
(<and>
(<values> aa (subst a vars))
(<cc> (lambda (x) (vector (aa x)))))
(<cc> (lambda (x) (vector (aa x))))))
(#(a b)
(<and>
(<values> aa (subst a vars))
(<values> bb (subst b vars))
(<cc> (lambda (x) (vector (aa x) (bb x)))))
(<cc> (lambda (x) (vector (aa x) (bb x))))))
((a . b)
(<and>
(<values> aa (subst a vars))
(<values> bb (subst b vars))
(<cc> (lambda (x) (cons (aa x) (bb x)))))
(<cc> (lambda (x) (cons (aa x) (bb x))))))
(a
(<cc>
(lambda (x)
(let ((r (assq a vars)))
(if r
......@@ -103,13 +111,13 @@
(if r
(list-ref x r)
a))
a)))))
a)))))))
(<define> (goal-eval* cut scut x)
(<<match>> (#:mode - #:name goal-eval) ((pp 'goal-eval x))
(#((,op2: mod #((n . l))))
(<let> ((mod (get-module (procedure-name (<lookup> mod))))
(let ((mod (get-module (procedure-name (<lookup> mod))))
(n (<lookup> n)))
(namespace-switch mod
(</.>
......@@ -118,11 +126,13 @@
(procedure-name n))
l)))))))
(#(("op2*" #((f val)) code))
(<values> (vars.vals) (get-vals val))
(#(("op2*" #((f . val)) code))
(<and>
(<pp> val)
(<values> (vars.vals) (get-vars val))
(let* ((vars (map car vars.vals))
(vals (map cdr vars.vals))
(vvars (lp ((i 0) (vv vars))
(vvars (let lp ((i 0) (vv vars))
(if (pair? vv)
(cons (cons (car vv) i)
(lp (+ i 1) (cdr vv)))
......@@ -130,9 +140,9 @@
(code2 #f)
(lp (<lambda> x
(goal-eval* cut scut (code2 x)))))
(<values (code3) (subst code (cons (cons f lp) vvars)))
(<values> (code3) (subst code (cons (cons f lp) vvars)))
(<code> (set! code2 code3))
(<apply> lp vals)))
(<apply> lp vals))))
(#((f . l))
(<let> ((f (<lookup> 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