rudimentary lambda support

parent a01a4fdb
......@@ -69,7 +69,7 @@
(pretty-print (syntax->datum x)))
x)))
(define (compile stx l)
(define* (compile stx l #:optional (name #f) (lam? #f))
(define (less x y)
(match (pp 'less-x x)
((#:translated n x)
......@@ -216,11 +216,19 @@
res_)
'()))))))
(let ((l (map (gen-fkn stx) (pp 'com com))))
(ppp 'res #`(begin
(add-non-defined
(quote #,(datum->syntax stx (get-syms))))
#,@ini #,@l #,@evl)))))
(let ((l (map (gen-fkn stx lam?) (pp 'com com))))
(if lam?
(ppp 'res #`(let ()
#,@ini
(let ()
#,@l
#,@evl
#,(datum->syntax stx name))))
(ppp 'res #`(begin
(add-non-defined
(quote #,(datum->syntax stx (get-syms))))
#,@ini #,@l #,@evl))))))
(define-syntax save-operator-table
(lambda (x)
......@@ -239,7 +247,7 @@
#,((get-rhs stx) rhs))))
(define (gen-fkn stx)
(define (gen-fkn stx lam?)
(lambda (com)
(match com
((f . (((l . r) ...) ...))
......@@ -255,12 +263,20 @@
(((rhs ...) ...) rhs)
((((v ...) ...) ...) v-new)
(f (datum->syntax stx f)))
#'(define-or-set! f
(<<case-lambda>>
((lhs ...
(<var> (v ...)
rhs)) ...)
...))))))))
(if lam?
#'(define f
(<<case-lambda>>
((lhs ...
(<var> (v ...)
rhs)) ...)
...))
#'(define-or-set! f
(<<case-lambda>>
((lhs ...
(<var> (v ...)
rhs)) ...)
...)))))))))
(define (union v1 v2)
(define tab (make-hash-table))
......@@ -357,6 +373,13 @@
(compile #'n
(prolog-parse #'n (syntax->datum #'str)))))))
(define (re-compile stx str nm)
(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
(lambda (x)
(syntax-case x ()
......
......@@ -150,8 +150,7 @@
(call-with-eh f))
h))))
(let ((s (fluid-ref *current-stack*)))
(let ((s (fluid-ref *current-stack*)))
(match x
;; To avoid an inifinite recursion
(('misc-error _ _ (_ 123) _)
......@@ -196,4 +195,4 @@
(define *call-expression* (gp-make-var #f))
(set! (@@ (logic guile-log prolog names) type_error) type_error)
(set! (@@ (logic guile-log prolog names) existence_error) existence_error)
\ No newline at end of file
(set! (@@ (logic guile-log prolog names) existence_error) existence_error)
......@@ -334,6 +334,51 @@
(<p-cc> `(#:term ,c1 ,(<scm> c3) ,n ,m)))))
mk-id)))
(define scm-tok
(let* ((l (f-tag "["))
(r (f-tag "]"))
(e (mk-token (f* (s-not! r)))))
(p-freeze 'scm-term
(<p-lambda> (c)
(.. (c0) (ws c))
(<let> ((n N) (m M))
(.. (c1) (atom c0 ))
(.. (c2) (l c1))
(.. (c3) (e c2))
(.. (c4) (r c3))
(.. (c5) (ws c4))
(if (eq? c2 c3)
(<p-cc> `(#:scm-term ,c1 () ,n ,m))
(<p-cc> `(#:scm-term ,c1 ,(<scm> c3) ,n ,m)))))
mk-id)))
(define lam-tok
(let* ((l (f-tag "{"))
(r (f-tag "}"))
(l! (f-tag! "{"))
(r! (f-tag! "}"))
(e (letrec ((body (lambda (n)
(f*
(f-or
ws+
(f-seq l! (Ds (body (+ n 1))) r!)
(s-not! (f-or l r)))))))
(mk-token (body 0)))))
(p-freeze 'lam-tok
(<p-lambda> (c)
(.. (c0) (ws c))
(<let> ((n N) (m M))
(.. (c1) (atom c0 ))
(.. (c2) (l c1))
(.. (c3) (e c2))
(.. (c4) (r c3))
(.. (c5) (ws c4))
(if (eq? c2 c3)
(<p-cc> `(#:lam-term ,c1 () ,n ,m))
(<p-cc> `(#:lam-term ,c1 ,(<scm> c3) ,n ,m)))))
mk-id)))
(define termvar-tok
(let ((l (f-tag "("))
(r (f-tag ")")))
......@@ -435,7 +480,7 @@
#;(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
termstring-tok term-tok paranthesis scm-tok lam-tok
number string dstring atom variable op-tok))
(define e (mk-operator-expression tok symbolic-tok *prolog-ops*))
......@@ -474,6 +519,16 @@
(with-fluids ((*current-stack* s))
(match x
(((fx _ ":-" _ ) (#:scm-term (#:atom scm _ _ _ _) l _ _) N M)
`(#:translated 0 ,(case scm
((scm s)
(datum->syntax
stx (eval-string (string-append "'" l))))
((quote q)
#`'#,(datum->syntax
stx (eval-string (string-append "'" l)))))))
(((fx _ ":-" _ ) (#:term (#:atom nm _ _ _ _) l _ _) N M)
(call-with-values
(lambda () (syntax-local-binding (datum->syntax stx nm)))
......
......@@ -10,7 +10,7 @@
term-get-variables-list term-get-variables term))
(define arg #f)
(define arg-goal #f)
(define compile-lambda #f)
(define do-print #f)
(define pp
(case-lambda
......@@ -25,6 +25,7 @@
(define get-double-quote-flag-fkn #f)
(define (fa x) x)
(define x_x #',GL:_)
(define (mk-arg goal?)
......@@ -41,6 +42,15 @@
((#:string str . _) str)
((#:dstring str . _) ((get-double-quote-flag-fkn) str))
((#:list v . _) (get-c fget v))
((#:scm-term (#:atom s . _) l _ _)
(case s
((scm s)
#`(unquote #,(datum->syntax
stx (eval-string
(string-append "'" l)))))))
((#:lam-term (#:atom s . _) l _ _)
#`(unquote #,(compile-lambda stx l s)))
((#:term (and atom (#:atom f . _)) () . _)
(add-sym atom)
#`(unquote #,(get-binding atom stx fa)))
......@@ -145,6 +155,16 @@
((#:string str . _) str)
((#:dstring str . _) ((get-double-quote-flag-fkn) str))
((#:list v . _) (get-c fget v))
((#:scm-term (#:atom s . _) l _ _)
(case s
((scm s)
#`(unquote #,(datum->syntax
stx (eval-string
(string-append "'" l)))))))
((#:lam-term (#:atom s . _) l _ _)
#`(unquote #,(compile-lambda stx l s)))
((#:term (and atom (#:atom f . _)) () . _)
(add-sym atom)
#`(unquote #,(get-binding atom stx fa)))
......@@ -226,6 +246,16 @@
((#:list v . _) (get-c fget v))
((#:string str . _) str)
((#:dstring str . _) ((get-double-quote-flag-fkn) str))
((#:scm-term (#:atom s . _) l _ _)
(case s
((scm s)
(datum->syntax
stx (eval-string
(string-append "'" l))))))
((#:lam-term (#:atom s . _) l _ _)
(compile-lambda stx l s))
((#:term (and atom (#:atom f . _)) () . _)
(add-sym atom)
(get-binding atom stx fa))
......@@ -298,6 +328,17 @@
((#:list v . _) (get-c fget v))
((#:string str . _) str)
((#:dstring str . _) ((get-double-quote-flag-fkn) str))
((#:scm-term (#:atom s . _) l _ _)
(case s
((scm s)
#`(unquote #,(datum->syntax
stx (eval-string
(string-append "'" l)))))))
((#:lam-term (#:atom s . _) l _ _)
#`(unquote #,(compile-lambda stx l s)))
((#:term (and atom (#:atom f . _)) () . _)
(add-sym atom)
#`(unquote #,(get-binding atom stx fa)))
......
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