pretty god tag

parent 6900c404
......@@ -76,6 +76,7 @@
prolog-closure-closure
prolog-closure-parent
prolog-closure-state
prolog-closure-closed?
))
;; Tos silence the compiler, those are fetched from the .so file
......@@ -175,8 +176,9 @@
(make-prolog-closure closure parent state)
prolog-closure?
(closure prolog-closure-closure)
(parent closure-parent)
(state closure-state))
(parent prolog-closure-parent)
(state prolog-closure-state)
(closed? prolog-closure-closed?))
(set-closure-struct! <closure-type>)
......
......@@ -4,4 +4,5 @@
make-prolog-closure
prolog-closure-closure
prolog-closure-parent
prolog-closure-state))
prolog-closure-state
prolog-closure-closed?))
(define-module (logic guile-log guile-prolog fluid)
#:use-module (logic guile-log)
#:export(make_fluid fluid_ref fluid_set))
(<define> (make_fluid Init Out) (<=> Out ,(make-fluid (<lookup> Init))))
(<define> (fluid_ref Fluid Out) (<=> Out ,(fluid-ref (<lookuo> Fluid))))
(<define> (fluid_set Fluid Val) (<code> (fluid-set! (<lookup> Fluid)
(<lookup> Val))))
(define-module (logic guile-log guile-prolog interpreter)
#:use-module ((logic guile-log) #:select
(<clear> <define> <let> <let*> <=> <lookup>))
(<clear> <define> <let> <let*> <=> <lookup> <match> <fail>
<cut>))
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog fluid)
#:use-module (ice-9 match)
......@@ -131,6 +132,11 @@
(let ((S (current-input-port)))
(read_term s p cc S T O)))))
(<define> (ftof X Y I H)
(<match> (#:mode +) (X Y)
(#(XL) #(YL) (<cut> (vtosym XL YL I H)))
(_ _ (<cut> <fail>))))
(compile-prolog-string
"
leave :- throw(leave).
......@@ -189,12 +195,9 @@ 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(X,Y,_,_) :- atomic(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(F,G,H,I) :- ftof(F,G,H,I).
vtosym(X,X,_,_) :- !.
......
......@@ -127,8 +127,16 @@
(() '())
(x (error "match error in flatten"))))
(define simple-lam #f)
(define (top x)
(match (pp 'top x)
((('xfy _ "|" _) args rs n m)
(set! simple-lam #t)
(top `(((xfx _ ":-" _)
(#:term (#:atom simple-1276 #f #f ,n ,m) ,args #f ,n ,m)
,rs ,n ,m)) ))
(((('xfx _ ":-" _) (#:term (#:atom v . _) y . _) z n m))
(if (is-dynamic? v)
`(#:translated
......@@ -187,7 +195,20 @@
`(#:term (#:atom assertz #f #f ,n ,m)
,x _ ,n ,m))))
(list v (get.. "," y) '())))))
(list v (get.. "," y) '())))
((rs)
(set! simple-lam #t)
(top `(((xfx _ ":-" _)
(#:term (#:atom simple-1277 #f #f 0 0) () #f 0 0)
(,rs) 0 0))))
(rs
(set! simple-lam #t)
(top `(((xfx _ ":-" _)
(#:term (#:atom simple-1277 #f #f 0 0) () #f 0 0)
(,rs) 0 0))))))
(define-syntax-rule (wi x) (if lam? x (with-fluids ((lambdas '())) x)))
......@@ -244,7 +265,21 @@
res_)
'()))))))
(let ((l (map (gen-fkn stx lam?) (pp 'com com))))
(let* ((last-name #f)
(nm (if name name
(gensym "closure-")))
(l (map (gen-fkn stx lam? (if simple-lam nm #f)
(lambda (x) (set! last-name x)))
(pp 'com com)))
(name (if simple-lam
nm
(if name name
(if last-name last-name
nm)))))
(if lam?
(let* ((nm (datum->syntax stx name))
(vs (fluid-ref v-variables))
......@@ -254,15 +289,17 @@
(pk 'lam)
(add-lambda (list name
vs
#`(letrec ((parent
(lambda #,vstx
(let ()
#,@l
#,@evl
(make-prolog-closure
#,nm parent
(list #,@vstx))))))
parent)))
(pp 'closure
#`(letrec
((parent
(lambda #,vstx
(let ()
#,@l
#,@evl
(make-prolog-closure
#,nm parent
(list #,@vstx))))))
parent))))
(pp 'res #`(let () #,@ini (#,nm #,@vstx))))
(with-syntax (((lam-def ...)
(let lp ((l (fluid-ref lambdas)))
......@@ -305,7 +342,7 @@
(set-procedure-property! nm 'module dir))))
(define (gen-fkn stx lam?)
(define (gen-fkn stx lam? nm nm-store)
(lambda (com)
(match com
((f . (((l . r) ...) ...))
......@@ -313,7 +350,8 @@
(define vs '())
(define ret
(with-fluids ((lambdas '()))
(let* ((v-l (pp 'v-l (map2 get-variables l)))
(let* ((f (if nm nm f))
(v-l (pp 'v-l (map2 get-variables l)))
(v-r (pp 'v-r (map2 (lambda (x)
(get-variables (list x))) r)))
(v-new (pp 'v-new (map2 (difference stx) v-r v-l)))
......@@ -341,16 +379,19 @@
(with-syntax (((((lhs ...) ...) ...) lhs)
(((rhs ...) ...) rhs)
((((v ...) ...) ...) v-new)
(f (datum->syntax stx f)))
(fstx (datum->syntax stx f)))
(if lam?
#'(define f
(<<case-lambda>>
((lhs ...
(<var> (v ...)
rhs)) ...)
...))
(begin
(nm-store f)
(pp 'fkn
#'(define fstx
(<<case-lambda>>
((lhs ...
(<var> (v ...)
rhs)) ...)
...))))
#'(define-or-set! f
#'(define-or-set! fstx
(<<case-lambda>>
((lhs ...
(<var> (v ...)
......@@ -488,6 +529,27 @@
(eval-when (compile eval load)
(define lamman (make-fluid)))
(define mod (current-module))
(define-syntax-rule (eval-in line stx)
(eval (let ((v stx))
`(let-syntax ((f (lambda (x)
(let ((x (datum->syntax ',v
(line ',v))))
(with-syntax ((g x))
#''g)))))
f))
mod))
(define (eval-inII line stx l)
(eval (let ((v stx))
`(let-syntax ((f (lambda (x)
(let ((x (datum->syntax ',v
(,line ',v ',l))))
(with-syntax ((g x))
#''g)))))
f))
mod))
(define (read-prolog-term stream module)
(let ((stx (vector 'syntax-object 'a '((top))
(cons* 'hygiene (module-name module)))))
......@@ -496,9 +558,10 @@
(lambda ()
(term-init-variables)
(clear-syms)
(let* ((r (pp 'parse-term (prolog-parse-read stx))))
(let* ((r (pp 'parse-term
(eval-in prolog-parse-read stx))))
(if (and (pair? r) (pair? (car r)))
(let* ((r (pp 'term (term stx (reverse (car r)))))
(let* ((r (pp 'term (eval-inII 'term stx (reverse (car r)))))
(vl (pp 'vl (term-get-variables-list)))
(vs (pp 'vs (term-get-variables)))
(h (make-hash-table))
......@@ -536,31 +599,33 @@
(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))
(let ((fkn
(eval
`(let-syntax
((f
(lambda (x)
,((@@ (logic guile-log prolog base)
pp) 'lammit lam))))
f)
(current-module))))
(define-or-set-fkn! nm fkn))
(lp lams))
(() #t)))
(values
(apply
(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)
(eval `((@ (guile) let-syntax)
((ff (lambda (x)
,(pp 'eval
#`(lambda
#,(map
(lambda (x)
(datum->syntax stx x))
vs)
`#,r)))))
ff)
module)
w)
w wl ws))
......
......@@ -76,7 +76,7 @@
(#((f . l))
(<let> ((f (<lookup> f)))
(<cut>
(<let> ((x (object-property f 'prolog-functor-type)))
(<let> ((x (object-property f 'prolog-functor-type)))
(case x
((#:goal)
(<apply> f cut l))
......
......@@ -394,7 +394,9 @@
(<p-lambda> (c)
(.. (c0) (ws c))
(<let> ((n N) (m M))
(.. (c1) (atom c0 ))
(xx (c1)
(<or> (.. (atom c0))
(<p-cc> #f)))
(.. (c2) (l c1))
(.. (c3) (e c2))
(.. (c4) (r c3))
......
......@@ -47,7 +47,7 @@
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #t))
((#:lam-term (#:atom s . _) l _ _)
((#:lam-term (or (#:atom s . _) (and #f s)) l _ _)
#`(unquote #,(compile-lambda stx l s)))
((#:term (and atom (#:atom f . _)) () #f . _)
......@@ -169,7 +169,7 @@
((#:list v . _) (get-c fget v))
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #t))
((#:lam-term (#:atom s . _) l _ _)
((#:lam-term (or (#:atom s . _) (and #f s)) l _ _)
#`(unquote #,(compile-lambda stx l s)))
((#:term (and atom (#:atom f . _)) () #f . _)
......@@ -270,7 +270,7 @@
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #f))
((#:lam-term (#:atom s . _) l _ _)
((#:lam-term (or (#:atom s . _) (and #f s)) l _ _)
(compile-lambda stx l s))
((#:term (and atom (#:atom f . _)) () #f . _)
......@@ -383,7 +383,7 @@
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #t))
((#:lam-term (#:atom s . _) l _ _)
((#:lam-term (or (#:atom s . _) (and #f s)) l _ _)
#`(unquote #,(compile-lambda stx l s)))
......
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