full support of prolog closures

parent c01ea81b
(define-module (logic guile-log prolog compile)
#:use-module (logic guile-log guile-prolog closure)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 match)
#:use-module (logic guile-log)
......@@ -31,6 +32,9 @@
(symbol? x)
(number? x)))
(define-syntax-rule (G x) '(@ (guile) x))
(define-syntax-rule (GL x) '(@ (logic guile-log) x))
(define-syntax-rule (FU x) '(@ (logic guile-log prolog goal-functor) x))
(define (compile-prolog s a f)
(define in-house (make-hash-table))
......@@ -82,9 +86,14 @@
(define (scan-var add-var x)
(umatch (#:mode - #:status s #:name scan-var) (x)
(#((f . a))
(begin
(cond
((and (struct? f) (prolog-closure? f))
(add-fkn (prolog-closure-parent f))
(for-each* (lambda (x) (scan-var add-var x)) (prolog-closure-state f))
(for-each* (lambda (x) (scan-var add-var x)) a))
(else
(add-fkn f)
(for-each* (lambda (x) (scan-var add-var x)) a)))
(for-each* (lambda (x) (scan-var add-var x)) a))))
((x . l)
(begin
......@@ -92,22 +101,33 @@
(scan-var add-var l)))
(x
(cond
((gp-var? x s)
(add-var x))
((procedure? x)
(add-fkn x))
((not (ident? x))
(add-fkn x))
(else
#t)))))
(let ((x (gp-lookup x s)))
(cond
((gp-var? x s)
(add-var x))
((procedure? x)
(add-fkn x))
((and (struct? x) (prolog-closure? x))
(for-each
(lambda (x)
(scan-var add-var x))
(prolog-closure-state x)))
((not (ident? x))
(add-fkn x))
(else
#t))))))
(define (scan-goal x)
(umatch (#:mode - #:status s #:name scan-goal) (x)
(#((f . a))
(begin
(cond
((and (struct? f) (prolog-closure? f))
(add-fkn (prolog-closure-parent f))
(for-each* scan-goal (prolog-closure-state f))
(for-each* scan-goal a))
(else
(add-fkn f)
(for-each* scan-goal a)))
(for-each* scan-goal a))))
((x . l)
(begin
......@@ -120,13 +140,23 @@
(add-var x))
((procedure? x)
(add-fkn x))
((and (struct? x) (prolog-closure? x))
(add-fkn (prolog-closure-parent x))
(for-each* scan-goal (prolog-closure-state x)))
(else
#t)))))
(define (compile-li x)
(umatch (#:mode - #:status s #:name compile-li) (x)
(#((f . a))
(vector (list (get-fkn f) (map* compile-li a))))
(let ((f (gp-lookup f s)))
(cond
((and (struct? f) (prolog-closure? f))
(vector (cons (cons (get-fkn (prolog-closure-parent f))
(map* compile-li (prolog-closure-state f)))
(map* compile-li a))))
(else
(vector (cons* (get-fkn f) (map* compile-li a)))))))
((x . l)
(let* ((a (compile-li x))
......@@ -134,14 +164,18 @@
(r0 (cons a b)))
r0))
(x
(cond
((gp-var? x s)
(get-var x))
((procedure? x)
(get-fkn x))
((symbol? x)
(quote x))
(else x)))))
(let ((x (gp-lookup x s)))
(cond
((gp-var? x s)
(get-var x))
((procedure? x)
(get-fkn x))
((symbol? x)
(quote x))
((and (struct? x) (prolog-closure? x))
(cons* (get-fkn (prolog-closure-parent x))
(map* compile-li (prolog-closure-state x))))
(else x))))))
(define (get-goal-types f)
......@@ -170,9 +204,17 @@
(pp 'compgoal x)
(umatch (#:mode - #:status s #:name compile-goal) (x)
(#((f . a))
(if (goal-fkn? f)
(apply (get-goal-stub f ) (comp-map* a (get-goal-types f)))
(cons (get-fkn f) (map* compile-li a))))
(let ((f (gp-lookup f s)))
(cond
((and (struct? f) (prolog-closure? f))
(cons (cons (get-fkn (prolog-closure-parent f))
(map* compile-li (prolog-closure-state f)))
(map* compile-li a)))
((goal-fkn? f)
(apply (get-goal-stub f ) (comp-map* a (get-goal-types f))))
(else
(cons (get-fkn f) (map* compile-li a))))))
((_ . _)
(compile-li x))
......@@ -181,15 +223,17 @@
(let ((x (gp-lookup x s)))
(cond
((gp-var? x s)
`(eval-goal ,(get-var x)))
`(,(FU eval-goal) ,(get-var x)))
((eq? x true)
'(@ (logic guile-log) <cc>))
(GL <cc>))
((eq? x fail)
'(@ (logic guile-log) <fail>))
(GL <fail>))
((eq? x !)
'(@ (logic guile-log) <cut>))
(GL <cut>))
((procedure? x)
(compile-goal (vector (list x))))
((and (struct? f) (prolog-closure? f))
(compile-goal (vector (list x))))
(else
(error (format #f "Atom ~a is not allowed as a goal" x))))))))
......@@ -206,11 +250,11 @@
((gp-var? a s)
(get-var a))
((procedure? a)
`(,'unquote ,(get-fkn a)))
`(,(G unquote) ,(get-fkn a)))
((symbol? a)
`(quote ,a))
`((G quote) ,a))
((not (ident? a))
`(,'unquote ,(get-fkn a)))
`(,(G unquote) ,(get-fkn a)))
(else
a))))))
......@@ -223,11 +267,20 @@
(umatch (#:mode - #:status s #:name compile-match) ((pp 'compil-var1 x))
(#((f . a))
(list 'vector (cons* 'list (get-fkn f)
(map* compile-var a))))
(let ((f (gp-lookup f s)))
(cond
((and (struct? f) (prolog-closure? f))
`(,(G vector) (,(G list)
,(cons (get-fkn (prolog-closure-parent f))
(map* compile-li
(prolog-closure-state f)))
,@(map* compile-var a))))
(else
(list (G vector) (cons* (G list) (get-fkn f)
(map* compile-var a)))))))
((a . l)
(list 'cons (compile-var a) (map-cons l)))
(list (G cons) (compile-var a) (map-cons l)))
(a
(let ((a (pp 'u (gp-lookup a s))))
(cond
......@@ -237,6 +290,9 @@
(get-fkn a))
((symbol? a)
(list 'quote a))
((and (struct? a) (prolog-closure? a))
(cons (get-fkn (prolog-closure-parent a))
(map* compile-li (prolog-closure-state a))))
((not (ident? a))
(get-fkn a))
((null? a)
......@@ -255,11 +311,11 @@
(ffkn (pp 'ffkn (hash-fold (lambda (k v r) (cons k r)) '() fkns)))
(vars (hash-fold (lambda (k v r) (cons v r)) '() in-house))
(ovars (hash-fold (lambda (k v r) (cons v r)) '() ex-house)))
(apply (compile (pp `(lambda (,@vfkn ,@vars ,@ovars)
((@@ (logic guile-log functional-database)
<lambda-dyn>) ,aa
((@@ (logic guile-log) <var>) ,vars ,ff)
,(list 'cons `,aaa `,fff))))
(apply (compile (pp `(,(G lambda) (,@vfkn ,@vars ,@ovars)
((@@ (logic guile-log functional-database)
<lambda-dyn>) ,aa
(,(GL <var>) ,vars ,ff)
,(list (G cons) `,aaa `,fff))))
#:env (current-module))
(append ffkn (map (lambda (x) (gp-make-var)) (append vars ovars))))))
......@@ -461,9 +461,14 @@
((and (struct? f) (prolog-closure? f))
(let ((args (map lp (prolog-closure-state f)))
(pre (lp (vector (cons* (prolog-closure-parent f) l)))))
(if (pair? args)
(format #f "~a[]" pre)
(format #f "~a[~a~{,~a~}]" pre (car args) (cdr args)))))
(if quoted?
(if (pair? args)
(format #f "~a[]" pre)
(format #f "~a[~a~{,~a~}]" pre (car args) (cdr args)))
(format #f "~a#~a" pre
(number->string
(object-address (prolog-closure-closure f))
31)))))
(else
(let ((op (procedure-property f 'prolog-operator)))
......@@ -481,14 +486,30 @@
(procedure-name f)
(lp a) (map lp (gp->scm l s)))))))))))
(#((f))
(if (string? f)
(format #f "'~a'" f)
(let ((ll (map (lambda (x) (format #f "'~a'" x))
(get-attached-module f ns?))))
(if (pair? ll)
(format #f "~a@@(~a~{, ~a~})"
(procedure-name f) (car ll) (cdr ll))
(format #f "~a" (procedure-name f))))))
(cond
((string? f)
(format #f "'~a'" f))
((and (struct? f) (prolog-closure? f))
(let ((args (map lp (prolog-closure-state f)))
(pre (lp (vector (cons* (prolog-closure-parent f) '())))))
(if quoted?
(if (pair? args)
(format #f "~a()[]" pre)
(format #f "~a()[~a~{,~a~}]" pre (car args) (cdr args)))
(format #f "~a#~a" pre
(number->string
(object-address (prolog-closure-closure f))
31)))))
(else
(let ((ll (map (lambda (x) (format #f "'~a'" x))
(get-attached-module f ns?))))
(if (pair? ll)
(format #f "~a@@(~a~{, ~a~})"
(procedure-name f) (car ll) (cdr ll))
(format #f "~a" (procedure-name f)))))))
((a . l)
......@@ -522,6 +543,20 @@
(format #f "~a@@(~a~{, ~a~})"
(procedure-name a) (car ll) (cdr ll))
(format #f "~a" (procedure-name a)))))
((and (struct? a) (prolog-closure? a))
(let ((args (map lp (prolog-closure-state a)))
(pre (lp (vector (cons* (prolog-closure-parent a) '())))))
(if quoted?
(if (pair? args)
(format #f "scm[(~a)]" pre)
(format #f "scm[(~a ~a ~{ ~a~})]"
pre (car args) (cdr args)))
(format #f "~a#~a" pre
(number->string
(object-address (prolog-closure-closure a))
31)))))
(else
(format #f "~a" a)))))))
(lp x))
......
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