reworked the printer in conversation, varius fixes to closures

parent ed278eeb
......@@ -68,6 +68,7 @@ SOURCES = \
logic/guile-log/guile-prolog/interleave.scm \
logic/guile-log/guile-prolog/zip.scm \
logic/guile-log/guile-prolog/readline.scm \
logic/guile-log/guile-prolog/fluid.scm \
logic/guile-log/guile-prolog/interpreter.scm \
language/prolog/spec.scm
......
......@@ -597,7 +597,7 @@ refers to the current wind level and use it in
@code{(gp-restore-wind state wind)}
To restore at the current wind level meaning that any @code{let-with-guard}
construct inside @code{code ...} will be restored but the defined @code{var ...} will not be restored, if that is wanted then use @code{(- wind 1}} instead.
construct inside @code{code ...} will be restored but the defined @code{var ...} will not be restored, if that is wanted then use @code{(- wind 1)} instead.
@code{G.L. (<let-with-lr-guard> wind lguard rguard ((var init) ...) code ...)}
This is very similar to the previous construct but for this ideom we define a
......
......@@ -14,6 +14,6 @@
#:title "Prolog"
#:reader read-prolog
#:compilers `((tree-il . ,compile-tree-il))
#:evaluator (lambda (x module) (eval x module))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write)
......@@ -185,7 +185,7 @@
(format port
"#<prolog-closure ~a(~a)>"
(procedure-name (struct-ref vl 1))
(object-adress (struct-ref vl 0)))))
(object-address (struct-ref vl 0)))))
(set-record-type-printer! <vlist>
(lambda (vl port)
......
......@@ -10,7 +10,8 @@
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (logic guile-log)
#:export (make_vhash vhash vhashp vhash_ref vhash_cons peek_vhash))
#:export (make_vhash vhash vhashp vhash_ref vhashq_ref vhash_cons vhashq_cons
peek_vhash))
(mk-sym vhash)
......@@ -59,6 +60,19 @@ it's old datastructure.
(when val
(<=> ,(un-canon-it val) (k . ret))))))))
(<define> (vhashq_ref h k ret)
(<let> ((h (<lookup> h))
(k (<lookup> k)))
(cond
((<var?> h)
(instantiation_error))
((not (<vhash?> h))
(type_error vhash h))
(else
(<let> ((val (vhash-assq k (fluid-ref h))))
(when val
(<=> ,val (_ . ret))))))))
(<define> (vhash_cons h k v)
(<let*> ((h (<lookup> h))
(k.v (canon-it (cons k v) S))
......@@ -72,33 +86,45 @@ it's old datastructure.
(else
(<code> (fluid-set! h (vhash-cons k v (fluid-ref h))))))))
(<define> (vhashq_cons h k v)
(<let*> ((h (<lookup> h))
(k (<lookup> k)))
(cond
((<var?> h)
(instantiation_error))
((not (<vhash?> h))
(type_error vhash h))
(else
(<code> (fluid-set! h (vhash-consq k
(<lookup> v) (fluid-ref h))))))))
(<define> (peek_vhash h)
(<code> (analyze (fluid-ref (<lookup> h)))))
(define (analyze x)
(if (vlist? x)
(let ((a (struct-ref x 0))
(b (struct-ref x 1)))
(format #t "<vhash> offset = ~a, " b)
(let ((block (vector-ref a 0))
(off (vector-ref a 2))
(size (vector-ref a 3))
(free (vector-ref a 4)))
(format #t " size ~a, free ~a~%" size free)
(let lp ((i b))
(if (>= i 0)
(let* ((next (number->string
(logand #xffffffff
(vector-ref block (+ (* size 3) i)))
16))
(back (ash
(vector-ref block (+ (* size 3) i))
-32))
(hash (vector-ref block (+ (* size 2) back)))
(v (object-address (vector-ref block i))))
(if (vlist? x)
(let ((a (struct-ref x 0))
(b (struct-ref x 1)))
(format #t "<vhash> offset = ~a, " b)
(let ((block (vector-ref a 0))
(off (vector-ref a 2))
(size (vector-ref a 3))
(free (vector-ref a 4)))
(format #t " size ~a, free ~a~%" size free)
(let lp ((i b))
(if (>= i 0)
(let* ((next (number->string
(logand #xffffffff
(vector-ref block (+ (* size 3) i)))
16))
(back (ash
(vector-ref block (+ (* size 3) i))
-32))
(hash (vector-ref block (+ (* size 2) back)))
(v (object-address (vector-ref block i))))
(format #t "~a: next ~a, back ~a hashv ~a key ~a~%"
i next back
hash (number->string v 16))
(lp (- i 1)))))))
(format #t "<assoc>~%")))
(format #t "~a: next ~a, back ~a hashv ~a key ~a~%"
i next back
hash (number->string v 16))
(lp (- i 1)))))))
(format #t "<assoc>~%")))
(define-module (logic guile-log guile-prolog interpreter)
#:use-module ((logic guile-log) #:select
(<clear> <define> <let> <let*> <=>))
(<clear> <define> <let> <let*> <=> <lookup>))
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog fluid)
#:use-module (ice-9 match)
#:use-module (ice-9 readline)
#:use-module (ice-9 rdelim)
......@@ -33,7 +35,8 @@
(define more #t)
(define write_out #t)
(define empty #t)
(define hash_new #t)
(define vtosym #t)
(mk-sym finish)
(define (prolog-shell)
......@@ -60,17 +63,18 @@
(let lp ((first? #t) (ch (peek-char)) (r '()))
(when (eof-object? ch)
(set! ch #\.))
(match ch
(match ch
(#\space
(read-char)
(if first?
(lp first? (read-char) r)
(lp first? (read-char) (cons ch r))))
(lp first? (peek-char) r)
(lp first? (peek-char) (cons ch r))))
(#\,
(read-char)
(if first?
(cons ch (string->list (read-line)))
(lp #f (peek-char) (cons ch r))))
(lp #f (peek-char) (cons ch r))))
(#\[
(if first?
......@@ -89,9 +93,7 @@
(if (string? l)
(let ((str l))
(add-history str)
(when (eq? (string-ref str 0) #\()
(set! str (string-append "do[" str "]")))
;(add-history str)
(when (eq? (string-ref str 0) #\,)
(string-set! str 0 #\space)
(set! str (string-append str " "))
......@@ -129,7 +131,6 @@
(let ((S (current-input-port)))
(read_term s p cc S T O)))))
(compile-prolog-string
"
leave :- throw(leave).
......@@ -177,8 +178,33 @@ consult(X,V,N) :-
finish,
fail).
vtosym(X,Y) :- make_vhash(H),make_fluid(0,I),vtosym(X,Y,H,I).
%vtosym(X,Y,_,_) :- write([1,X,Y]),nl,fail.
vtosym(X,Y,H,I) :-
var(X) -> (!,(vhashq_ref(H,X,Y);hash_new(X,Y,H,I))) ; fail.
vtosym([X|XL],[U|UL],H,I) :-
!,vtosym(X,U,H,I), vtosym(XL,UL,H,I).
vtosym([],[],_,_) :- !.
vtosym(X,Y,_,_) :- atom(X) -> (!,X=Y) ; fail.
vtosym(F,G,H,I) :-
F=..[FH|FL], !, G=..[GH|GL],
vtosym(FH,GH,H,I),
vtosym(FL,GL,H,I).
vtosym(X,X,_,_) :- !.
hash_new(X,Y,H,I) :-
Y = scm[(format #f \"X~a\" (fluid-ref (<lookup> I)))],
fluid_set(I,scm[(+ 1 (fluid-ref (<lookup> I)))]),
vhashq_cons(H,X,Y).
output_and_more(V,N) :-
(V==[] -> write('yes') ; write_out(V,N)),more.
(V==[] -> write('yes') ; once(vtosym(V,VV)),write_out(VV,N)),more.
write_out([],[]).
write_out([V|Vs],[N|Ns])
......
......@@ -52,6 +52,14 @@
(define! 'f f))
(set-procedure-property! f 'module (module-name (current-module)))
(set-procedure-property! f 'name 'f)))
(define (define-or-set-fkn! f x)
(letrec ((xx x))
(if (module-locally-bound? (current-module) f)
(module-set! (current-module) f xx)
(define! f xx))
(set-procedure-property! xx 'module (module-name (current-module)))
(set-procedure-property! xx 'name f)))
(define do-print #f)
......@@ -243,6 +251,7 @@
(vstx (map (lambda (x)
(datum->syntax stx x))
vs)))
(pk 'lam)
(add-lambda (list name
vs
#`(letrec ((parent
......@@ -267,7 +276,7 @@
(cons x (lp l)))
(() '())))))
(ppp 'res #`(begin
(pp 'res #`(begin
(add-non-defined
(quote #,(datum->syntax stx (get-syms))))
lam-def ... #,@l #,@evl)))))))))
......@@ -458,10 +467,13 @@
(prolog-parse #'n (syntax->datum #'str)))))))
(define (re-compile stx str nm)
(pk str)
(compile stx
(prolog-parse stx str)
nm #t))
(let ((str (string-trim-right str)))
(when (not (eq? (string-ref str (- (string-length str) 1)) #\.))
(set! str (string-append str ".")))
(pk str)
(compile stx
(prolog-parse stx str)
nm #t)))
(set! (@@ (logic guile-log prolog var) compile-lambda) re-compile)
(define-syntax compile-prolog-file
......@@ -473,19 +485,22 @@
(with-fluids ((*prolog-file* (syntax->datum #'str)))
(compile #'n
(prolog-parse #'n)))))))))
(eval-when (compile eval load)
(define lamman (make-fluid)))
(define (read-prolog-term stream module)
(let ((stx (vector 'syntax-object 'a '((top))
(cons* 'hygiene (module-name module)))))
(with-fluids ((lambdas '()))
(with-input-from-port stream
(lambda ()
(term-init-variables)
(clear-syms)
(let* ((r (prolog-parse-read stx)))
(if (pair? r)
(let* ((r (term stx (reverse (car r))))
(vl (term-get-variables-list))
(vs (term-get-variables))
(let* ((r (pp 'parse-term (prolog-parse-read stx))))
(if (and (pair? r) (pair? (car r)))
(let* ((r (pp 'term (term stx (reverse (car r)))))
(vl (pp 'vl (term-get-variables-list)))
(vs (pp 'vs (term-get-variables)))
(h (make-hash-table))
(w (map (lambda (x)
(let ((r (gp-make-var)))
......@@ -512,19 +527,44 @@
(lp (cdr vs)))
(cdr vs)))
'()))))
(add-non-defined (get-syms))
(pp 'lambdas (fluid-ref lambdas))
;; Make sure to define closure parents in current module
(let lp ((lams (fluid-ref lambdas)))
(match lams
(((nm vs lam) . lams)
(let ((fkn (eval
`(let-syntax
((f (lambda (x)
,((@@ (logic guile-log prolog base)
pp) 'lammit lam))))
f)
(current-module))))
(pk nm)
(define-or-set-fkn! nm fkn))
(lp lams))
(() #t)))
(values
(apply
(eval (pp 'eval-term `(lambda ,vs
,(list 'quasiquote
(syntax->datum r))))
(eval `(let-syntax ((f (lambda (x)
((@@ (logic guile-log prolog base)
pp)
'eval-term
,#`(lambda
#,(map
(lambda (x)
(datum->syntax stx x))
vs)
`#,r)))))
f)
module)
w) w wl ws))
end_of_file))))))
w)
w wl ws))
end_of_file)))))))
(define (add-non-defined l)
(when #t (eq? (get-flag 'auto_sym) 'on)
......
......@@ -368,80 +368,84 @@ floor(x) (floor x)
(y (<scm> y)))
(cond
((or (number? x) (null? x))
(<=> (x) y))
(<cut> (<=> (x) y)))
((vector? x)
(<match> (#:mode -) (x)
(#(l)
(<cut>
(<match> (#:mode -) (x)
(#(l)
(<cut>
(<match> (#:mode -) (y)
((f . u)
(<cut>
(<let> ((f (<lookup> f)))
(cond
((string? f)
(<let> ((g (module-ref (current-module)
(string->symbol f))))
(if (procedure? g)
(<=> l ,(cons g u))
(existence_error
procedure
(vector `(,divide ,f
,(length (<scm> u))))))))
(else
(<=> l y))))))
(y
(<cut>
(<=> l y))))))
(_ (type_error 'compound x)))))
((<var?> x)
(<cut>
(cond
((<var?> y)
(instantiation_error))
((list? y)
(<match> (#:mode -) (y)
((f . u)
(<cut>
(<let> ((f (<lookup> f)))
(cond
((string? f)
(<let> ((g (module-ref (current-module) (string->symbol f))))
((f . l)
(<cut>
(<let> ((f (<lookup> f)))
(cond
((procedure? f)
(<=> x ,(vector (cons f l))))
((string? f)
(<let> ((g (module-ref (current-module) (string->symbol f))))
(if (procedure? g)
(<=> l ,(cons g u))
(<=> x ,(vector (cons g l)))
(existence_error
procedure
(vector `(,divide ,f
,(length (<scm> u))))))))
(else
(<=> l y))))))
(y
(<cut>
(<=> l y)))))
,(length (<scm> l))))))))
(_ (type_error 'compound x))))
((<var?> x)
(cond
((<var?> y)
(instantiation_error))
((list? y)
(<match> (#:mode -) (y)
((f . l)
(<cut>
(<let> ((f (<lookup> f)))
(cond
((procedure? f)
(<=> x ,(vector (cons f l))))
((string? f)
(<let> ((g (module-ref (current-module) (string->symbol f))))
(if (procedure? g)
(<=> x ,(vector (cons g l)))
(existence_error
procedure
(vector `(,divide ,f
,(length (<scm> l))))))))
((and (number? f) (null? (<lookup> l)))
(<=> x f))
((and (number? f) (null? (<lookup> l)))
(<=> x f))
((number? f)
(type_error atom f))
((number? f)
(type_error atom f))
((<var?> f)
(instantiation_error))
((<var?> f)
(instantiation_error))
(else
(type_error atom f))))))
(()
(<cut>
(type_error list y)))))
((pair? y)
(<recur> lp ((z y))
(if (pair? z)
(lp (cdr z))
(if (<var?> z)
(instantiation_error)
(type_error list y)))))
(else
(type_error atom f))))))
(()
(<cut>
(type_error list y)))))
((pair? y)
(<recur> lp ((z y))
(if (pair? z)
(lp (cdr z))
(if (<var?> z)
(instantiation_error)
(type_error list y)))))
(else
(type_error list y)))))))
(else
(type_error list y))))))))
(<define-guile-log-rule> (mac=.. a b) (func=.. a b))
(mk-prolog-biop 'xfx "=.." -fkn-expand fkn_expand mac=.. a a)
......
......@@ -8,6 +8,7 @@
#:use-module (logic guile-log)
#:use-module (system syntax)
#:use-module (ice-9 match)
#:use-module (ice-9 eval-string)
#:use-module (ice-9 pretty-print)
#:export (goal scm fff define-goal-transformer add-op-map op->fkn
get-functor-stx op->>fkn maybe-op))
......@@ -177,7 +178,7 @@
op))))))
(define (mk-scheme stx s l scm?)
(let* ((sym (eval-string (string-append "'" l)))
(let* ((sym (eval-string (string-append "'" l) #:lang 'scheme))
(w (datum->syntax stx sym)))
(case s
((do)
......@@ -217,7 +218,7 @@
((#:atom 'true . _) #'<cc>)
((#:atom 'fail . _) #'<fail>)
((#:atom v _ _ n m)
(goal stx `(#:term ,z () ,n ,m)))
(goal stx `(#:term ,z () #f ,n ,m)))
((#:symbolic '! . _) #'<cut>)
......
(define-module (logic guile-log prolog parser)
#:use-module (logic guile-log parsing operator-parser)
#:use-module (ice-9 match)
#:use-module (ice-9 eval-string)
#:use-module (logic guile-log vlist)
#:use-module ((logic guile-log umatch) #:select (*current-stack*))
#:use-module (ice-9 pretty-print)
......@@ -346,7 +347,11 @@
(.. (c5) (ws c4))
(xx (c6)
(<or>
(.. ((f-seq lb (f-or expr ws)) c5))
(<and>
(.. (a1) (lb c5))
(.. (a2) ((f-or expr ws) '()))
(.. (a3) (rb a2))
(<p-cc> a2))
(<p-cc> #f)))
(.. (c7) (ws c6))
(if (eq? c2 c3)
......@@ -364,8 +369,8 @@
(<let> ((n N) (m M))
(.. (c1) (atom c0 ))
(.. (c2) (l c1))
(.. (c3) (e c2))
(.. (c4) (r c3))
(.. (c3) (e c2))
(.. (c4) (r c3))
(.. (c5) (ws c4))
(if (eq? c2 c3)
(<p-cc> `(#:scm-term ,c1 () ,n ,m))
......@@ -499,8 +504,9 @@
#;(define tok (f-or! list-e term-tok termvar-tok atom symbolic variable number))
(define tok (f-or! char list-tok termvar-tok term-binop-tok termop-tok
termstring-tok term-tok paranthesis scm-tok lam-tok
(define tok (f-or! paranthesis
char list-tok termvar-tok term-binop-tok termop-tok
termstring-tok term-tok scm-tok lam-tok
number string dstring atom variable op-tok))
(define e (mk-operator-expression tok symbolic-tok *prolog-ops*))
......@@ -543,10 +549,12 @@
`(#:translated 0 ,(case scm
((scm s)
(datum->syntax
stx (eval-string (string-append "'" l))))
stx (eval-string (string-append "'" l)
#:lang 'scheme)))
((quote q)
#`'#,(datum->syntax
stx (eval-string (string-append "'" l)))))))
stx (eval-string (string-append "'" l)
#:lang 'scheme))))))
(((fx _ ":-" _ ) (#:term (#:atom nm _ _ _ _) l _ _) N M)
......@@ -578,7 +586,7 @@
(<p-lambda> (c)
(<let> ((n N) (m M))
(.. (d) (ferr* c))
(<code> (warn (format #f "Error somwhere beteen ~a -> ~a"
(<code> (warn (format #f "Error somewhere beteen ~a -> ~a"
(get-refstr n m) (get-refstr N M))))
(<p-cc> #f))))
......@@ -602,7 +610,7 @@
ferr)))
(<p-lambda> (c)
(.. (d) (f '()))
(<p-cc> (pp 'token (reverse d))))))
(<p-cc> (pp 'token (if d (reverse d) d))))))
(define (prolog-parse stx . l)
(with-fluids ((*translator* char-convert))
......
......@@ -3,6 +3,7 @@
#:use-module (logic guile-log prolog goal)
#:use-module (logic guile-log prolog pre)
#:use-module (logic guile-log prolog symbols)
#:use-module (ice-9 eval-string)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module ((logic guile-log) #:select ((_ . GL:_) <define> <code> <cc>))
......@@ -65,7 +66,7 @@
`(,#,(get-binding atom stx fa)
#,@(map fget (get.. "," x))))))
((#:term (and atom (#:atom f . _)) x #f . _)
((#:term (and atom (#:atom f . _)) x meta . _)
(add-sym atom)
(let ((meta (map fget (get.. "," meta))))
#`(unquote
......@@ -175,6 +176,12 @@
(add-sym atom)
#`(unquote #,(get-binding atom stx fa)))
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym atom)
(let ((meta (if (null? meta) meta (map fget (get.. "," meta)))))
#`(unquote (#,(get-binding atom stx fa) #,@meta))))
((#:term (and atom (#:atom f . _)) x #f . _)
(add-sym atom)
#`(unquote
......@@ -182,6 +189,14 @@
`(,#,(get-binding atom stx fa)
#,@(map fget (get.. "," x))))))
((#:term (and atom (#:atom f . _)) x meta . _)
(add-sym atom)
(let ((meta (if (null? meta) meta (map fget (get.. "," meta)))))
#`(unquote
(vector
`(,(#,(get-binding atom stx fa) #,@meta)
#,@(map fget (get.. "," x)))))))
((#:termvar v () . _)
(fluid-set! *var-list* (cons v (fluid-ref *var-list*)))
(hashq-set! (fluid-ref *variables*) v #t)
......@@ -262,11 +277,23 @@
(add-sym atom)
(get-binding atom stx fa))
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym atom)
(let ((meta (map fget (get.. "," meta))))
#`((get-binding atom stx fa) #,@meta)))
((#:term (and atom (#:atom f . _)) x #f . _)
(add-sym atom)
#`#((,#,(get-binding atom stx fa)
#,@(map fget (get.. "," x)))))
((#:term (and atom (#:atom f . _)) x meta . _)
(add-sym atom)
(let ((meta (map fget (get.. "," meta))))
#`(vector
`(,(#,(get-binding atom stx fa) #,@meta)
#,@(map fget (get.. "," x))))))
((#:termvar v () . _)
#`#((#,(datum->syntax stx v))))
......@@ -320,15 +347,17 @@
(<define> (when-eval-scheme f) (if (f) <cc>))
(define (mk-scheme stx s l unq?)
(let* ((sym (eval-string (string-append "'" l)))
(let* ((sym (eval-string (string-append "'" l) #:lang 'scheme))
(lam (if unq? (lambda (x) #`(unquote #,x)) (lambda (x) x)))
(w (datum->syntax stx sym))
(v #`(lambda () #,w)))
(case s
((do)
(lam #`(vector (list do-eval-scheme #,v))))
(lam #`(vector (list (@@ (logic guile-log prolog var) do-eval-scheme)
#,v))))
((when)
(lam #`(vector (list when-eval-scheme #,v))))
(lam #`(vector (list (@@ (logic guile-log prolog var) when-eval-scheme)
#,v))))
((v var)
(fluid-set! v-variables (cons sym (fluid-ref v-variables)))
(lam w))
......@@ -362,6 +391,11 @@
(add-sym atom)
#`(unquote #,(get-binding atom stx fa)))
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym atom)
(let ((meta (map fget (get.. "," meta))))
#`(unquote (#,(get-binding atom stx fa) #,@meta))))