namespace unification starts to shape up

parent 09f1418f
......@@ -212,12 +212,20 @@
(vlist->list vl))))))
(define-record-type <namespace-type>
(make-namespace val ns local?)
(make-namespace_ val ns local?)
namespace?
(val namespace-val)
(ns namespace-ns)
(local? namespace-local?))
(define (make-namespace a l b)
(let ((l (map (lambda (x)
(if (string? x)
(string->symbol x)
x))
l)))
(make-namespace_ a l b)))
(set-record-type-printer!
<namespace-type>
(lambda (vl port)
......
......@@ -95,7 +95,7 @@ it's old datastructure.
((not (<vhash?> h))
(type_error vhash h))
(else
(<code> (fluid-set! h (vhash-consq k
(<code> (fluid-set! h (vhash-consq k
(<lookup> v) (fluid-ref h))))))))
(<define> (peek_vhash h)
......
......@@ -2,7 +2,7 @@
#:use-module ((logic guile-log) #:select
(<clear> <define> <let> <let*> <=> <lookup> <match> <fail>
<cut> <wrap> <state-ref> <state-set!> <continue>
<code> <scm> <stall>))
<code> <scm> <stall> <case-lambda>))
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog fluid)
#:use-module (logic guile-log vlist)
......@@ -12,6 +12,7 @@
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog namespace)
#:use-module (logic guile-log prolog closed)
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log guile-prolog dynamic-features)
......@@ -72,9 +73,21 @@
-n-))
(define lold #f)
(<define> (stall)
(<code> (set! lold (<state-ref>)))
(<stall>))
(define *usr-state* (make-fluid #f))
(define stall
(<case-lambda>
(()
(<code>
(usr-set 'stall-ret '())
(fluid-set! *usr-state* S)
(set! lold (<state-ref>))))
((l)
(<code>
(usr-set 'stall-ret l)
(fluid-set! *usr-state* S)
(set! lold (<state-ref>))))
(<stall>)))
(<define> (thin_stall)
(<stall>))
......@@ -110,31 +123,36 @@
(read-char)
(if first?
(let ((action ((@ (guile) read))))
(if (integer? action)
(set! n? action)
(case action
((mute m) (set! mute? #t))
((all *) (set! all? #t))
((once) (set! n? 1))
((h help) (set! help? #t))
((s save) (set! save ((@ (guile) read))))
((l load) (set! load ((@ (guile) read))))
((c cont) (set! cont #t))
((ref) (set! ref ((@ (guile) read))))
((set) (set! set (list ((@ (guile) read))
((@ (guile) read)))))
((lo lold)
(set! old #t)
(if lold (<state-set!> lold)))
(else
(set! fail? #t))))
(cond
((or fail? help?)
#f)
((or load save cont ref set old)
#t)
(cond
((integer? action)
(set! n? action))
((pair? action)
action)
(else
(lp #t (peek-char) '()))))
(case action
((mute m) (set! mute? #t))
((all *) (set! all? #t))
((once) (set! n? 1))
((h help) (set! help? #t))
((s save) (set! save ((@ (guile) read))))
((l load) (set! load ((@ (guile) read))))
((c cont) (set! cont #t))
((ref) (set! ref ((@ (guile) read))))
((set) (set! set (list ((@ (guile) read))
((@ (guile) read)))))
((lo lold)
(set! old #t)
(if lold (<state-set!> lold)))
(else
(set! fail? #t)))
(cond
((or fail? help?)
#f)
((or load save cont ref set old)
#t)
(else
(lp #t (peek-char) '()))))))
(list->string (reverse (cons #\. r)))))
(#\,
......@@ -142,13 +160,6 @@
(if first?
(cons ch (string->list (read-line)))
(lp #f (peek-char) (cons ch r))))
(#\[
(if first?
((@ (guile) read))
(begin
(read-char)
(lp #f (peek-char) (cons ch r)))))
(_
(read-char)
......@@ -201,7 +212,7 @@ HELP FOR PROLOG COMMANDS
(.save | .s ) <ref> associate current state with ref
(.load | .l ) <ref> restore associate state with ref
(.cont | .c ) continue the execution from last stall point
(.lold | .lo) restore the last state at a stall
(.lold | .lo) restore the last state at a stall
---------------------------------------------------------------------
(.ref ) <ref> get value of reference variable ref
(.set ) <ref> <val> set user variable ref to value val
......@@ -250,8 +261,8 @@ HELP FOR PROLOG COMMANDS
(define (readline_term_str s p cc Str T O)
(with-input-from-string Str
(lambda ()
(let ((S (current-input-port)))
(read_term s p cc S T O)))))
(let ((port (current-input-port)))
(read_term s p cc port T O)))))
(<define> (ftof X Y I H)
(<match> (#:mode +) (X Y)
......@@ -261,6 +272,13 @@ HELP FOR PROLOG COMMANDS
(define -nsol- (make-fluid false))
(<wrap> add-fluid-dynamics -nsol-)
(<define> (wrap_namespace x y yy)
(<let> ((x (<lookup> x)))
(<=> y ,(make-namespace
yy
(namespace-ns x)
(namespace-local? x)))))
(compile-prolog-string
"
leave :- throw(leave).
......@@ -307,7 +325,11 @@ 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.
var(X) -> (!, (vhashq_ref(H,X,Y);hash_new(X,Y,H,I)));
namespace_p(X) -> (!, namespace_val(X,XX),pp(XX),
vtosym(XX,YY,H,I),
wrap_namespace(X,Y,YY)) ; fail.
vtosym([X|XL],[U|UL],H,I) :-
!,vtosym(X,U,H,I), vtosym(XL,UL,H,I).
......@@ -320,7 +342,7 @@ vtosym(F,G,H,I) :- ftof(F,G,H,I).
vtosym(X,X,_,_) :- !.
hash_new(X,Y,H,I) :-
Y = scm[(format #f \"X~a\" (fluid-ref (<lookup> I)))],
Y = scm[(string->symbol (format #f \"X~a\" (fluid-ref (<lookup> I))))],
fluid_set(I,scm[(+ 1 (fluid-ref (<lookup> I)))]),
vhashq_cons(H,X,Y).
......@@ -349,7 +371,7 @@ more :-
Ans == 'y' -> fail ;
Ans == 'n' -> throw(finish) ;
Ans == 'a' -> scm[(fluid-set! -all- true)]==1 ;
write(' wrong input'),more
write(' wrong input'),nl,more
)
)
).
......
......@@ -14,6 +14,9 @@
#:use-module (logic guile-log prolog conversion)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog closed)
#:use-module (logic guile-log prolog namespace)
#:use-module (system base language)
#:use-module (logic guile-log)
#:export (reset-flags reset-prolog)
#:re-export (;; Scheme functions
compile-prolog-string compile-prolog-file
......@@ -81,6 +84,9 @@
;; conversion
round floor ceiling truncate
;; modules
;; symbols directive
include
......@@ -99,7 +105,7 @@
halt
)
#:export (make-unbound-term))
#:export (make-unbound-term default_module))
(define reset-flags init-flags)
(define (reset-prolog)
......@@ -111,3 +117,9 @@
(begin
(define a (make-unbound-fkn 'a))
(set-procedure-property! a 'name 'a)))
(<define> (default_module)
(<code> (set-current-module
(language-make-default-environment (current-language)))))
\ No newline at end of file
......@@ -548,7 +548,7 @@
mod))
(define (read-prolog-term stream module)
(define (read-prolog-term state stream module)
(let ((stx (vector 'syntax-object 'a '((top))
(cons* 'hygiene (module-name module)))))
(with-fluids ((lambdas '()))
......@@ -617,15 +617,18 @@
(eval `((@ (guile) let-syntax)
((ff (lambda (x)
,(pp 'eval
#`(lambda
#,(map
(lambda (x)
(datum->syntax stx x))
vs)
`#,r)))))
(with-syntax ((code r))
#`(lambda
(s123 #,@(map
(lambda (x)
(datum->syntax stx x))
vs))
(fluid-let-syntax ((S (lambda (x)
#'s123)))
`code)))))))
ff)
module)
w)
(cons state w))
w wl ws))
end_of_file)))))))
......
......@@ -280,7 +280,7 @@
(mk-prolog-biop 'xfx "@<" tr-olt olt term< a a)
(mk-prolog-biop-not 'xfx "@>=" tr-0ge oge term< a a)
(mk-prolog-biop-not 'xfx "@=<" tr-0le ole term> a a)
;(mk-prolog-is 'xfx "is" tr-is is <r=> v s)
;(mk-prolog-is 'xfx "is" tr-is is <r=> v s)
(mk-prolog-biop 'xfx "is" tr-is is <iss> a s)
......
......@@ -15,6 +15,7 @@
#:use-module (logic guile-log prolog char)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog pre)
#:use-module (logic guile-log prolog namespace)
#:use-module (rnrs io ports)
#:replace (write open close read)
#:export (nl pp current_input current_output standard_input standard_output
......@@ -219,7 +220,7 @@
(r (<lookup> Repo))
(a (<lookup> Alias))
(e (<lookup> EOF)))
(<let*> ((mode (if (eq? t text)
(<let*> ((mode (if (eq? t text)
(cond
((eq? Mode write)
"w")
......@@ -540,27 +541,56 @@
(hashq-set! *variables* a n)
n))))
((procedure? a)
(let ((ll (map (lambda (x) (format #f "'~a'" x))
(let ((ll (map (lambda (x)
(if (symbol? x)
(symbol->string x)
x))
(get-attached-module a ns?))))
(if (pair? ll)
(match ll
(('language 'prolog 'modules x)
(format #f "~a@@~a"
(procedure-name a) x))
(("language" "prolog" "modules" x)
(format #f "~a@@~a"
(procedure-name a) x))
((_ . _)
(format #f "~a@@(~a~{, ~a~})"
(procedure-name a) (car ll) (cdr ll))
(format #f "~a" (procedure-name a)))))
(procedure-name a) (car ll) (cdr ll)))
(_
(format #f "~a" (procedure-name a))))))
((struct? a)
(cond
((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 "~a()[~a~{, ~a~}]"
pre (car args) (cdr args))
(format #f "~a()[]" pre))
(format #f "~a#~a"
(number->string
(object-address (prolog-closure-closure a))
31)
pre))))
((namespace? a)
(let ((v (lp (namespace-val a)))
(at (if (namespace-local? a)
'@@
'@))
(l (let ((l (namespace-ns a)))
(match l
(('language 'prolog 'modules x)
x)
(("language" "prolog" "modules" x)
x)
(_ l)))))
(format #f "~a~a~a" v at l)))
(else
(format #f "~a" 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 "~a()[~a~{, ~a~}]"
pre (car args) (cdr args))
(format #f "~a()[]" pre))
(format #f "~a#~a"
(number->string
(object-address (prolog-closure-closure a))
31)
pre))))
(else
(format #f "~a" a)))))))
(lp x))
......@@ -654,12 +684,10 @@
(<pp> `(,n ,x)))))
(<define> (read* s term v vn si)
(<let*> ((fr (<newframe>))
(s (<scm> s))
(<let*> ((s (<scm> s))
(e (call-with-values
(lambda () (read-prolog-term s (current-module)))
(lambda x x))))
(<code> (<unwind> fr))
(lambda () (read-prolog-term S s (current-module)))
(lambda x x))))
(<=> ,(list term v vn si) e)))
......
......@@ -169,7 +169,7 @@
(if (not (module-defined? mod a))
(let ((f (make-unbound-fkn a)))
(module-define! mod a f)
(set-procedure-property! f 'module (module-name (current-module)))
(set-procedure-property! f 'module (module-name mod))
(set-procedure-property! f 'name a)
f)
#f))
......
This diff is collapsed.
......@@ -35,7 +35,13 @@
(when do-print
(pretty-print (syntax->datum x)))
x)))
(define-syntax-rule (wrap@ u code)
(let ((r code)
(u (<scm> u)))
(if u
`(#:@ ,r ,@u)
r)))
(define % (s-char #\%))
(define precom (s-seq (s-char #\/) (s-char #\*)))
(define podcom (s-seq (s-char #\*) (s-char #\/)))
......@@ -228,38 +234,81 @@
(<p-cc> `(#:number ,(char->integer (string-ref c* 0)) ,n ,m))))
mk-id))
(define (mk-string x)
(list #:string (if (symbol? x)
(symbol->string x)
x) 0 0))
(define (mk-list . l)
(let ((l (reverse l)))
(let lp ((l (cdr l)) (r (car l)))
(if (pair? l)
(lp (cdr l) (list (list xfy 1000 "," #\,) (car l) r 0 0))
r))))
(define @tag-body
(let ((l (f-tag "("))
(r (f-tag ")")))
(<p-lambda> (c)
(.. (c) (ws c))
(<or>
(<and>
(.. (c) (l c))
(.. (cx) (expr c))
(.. (c) (r cx))
(.. (c) (ws c))
(<p-cc> cx))
(<and>
(.. (cx) (atom c))
(<p-cc> (mk-list (mk-string "language")
(mk-string "prolog")
(mk-string "modules")
(mk-string (list-ref cx 1)))))
(<and>
(.. (cx) (string c))
(<p-cc> (mk-list (mk-string "language")
(mk-string "prolog")
(mk-string "modules")
(mk-string (list-ref cx 1)))))))))
(define @tag
(let ((@ (f-tag "@"))
(@@ (f-tag "@@")))
(<p-lambda> (c)
(<let> ((n N) (m M))
(<and>
(.. (c) (ws c))
(<or>
(<and>
(.. (c) (@@ c))
(.. (cx) (@tag-body c))
(.. (c) (ws c))
(<p-cc> `(@@ ,cx)))
(<and>
(.. (c) (@ c))
(.. (cx) (@tag-body c))
(.. (c) (ws c))
(<p-cc> `(@ ,cx)))
(<p-cc> #f)))))))
(define string
(p-freeze 'string
(let ((@ (f-tag "@"))
(@@ (f-tag "@@"))
(l (f-tag "("))
(r (f-tag ")")))
(<p-lambda> (c)
(.. (c) (ws c))
(.. (c) (f-quote c))
(<let> ((n N) (m M))
(.. (c*) (str-body c))
(.. (c) (f-quote c*))
(.. (c) (ws c))
(xx (u)
(<or>
(<and>
(.. (c) (@@ c))
(.. (c) (l c))
(.. (cx) ((f-or expr ws) c))
(.. (c) (r cx))
(.. (c) (ws c))
(<p-cc> `(#:atom ,(string->symbol c*) @@ ,(<scm> cx) ,n ,m)))
(<and>
(.. (c) (@ c))
(.. (c) (l c))
(.. (cx) (expr c))
(.. (c) (r cx))
(.. (c) (ws c))
(<p-cc> `(#:atom ,(string->symbol c*) @ ,(<scm> cx) ,n ,m)))
(<p-cc> #f)))
(.. (c) (ws u))
(<p-cc> (if u u `(#:string ,c* ,n ,m))))))
(<p-lambda> (c)
(.. (c) (ws c))
(.. (c) (f-quote c))
(<let> ((n N) (m M))
(.. (c*) (str-body c))
(.. (c) (f-quote c*))
(.. (c) (ws c))
(.. (u) (@tag c))
(.. (c) (ws u))
(<p-cc> (if u
`(#:atom ,(string->symbol c*)
,(car u) ,(cadr u) ,n ,m)
`(#:string ,c* ,n ,m))))))
mk-id))
(define dstring
......@@ -271,7 +320,12 @@
(.. (c*) (dstr-body c))
(.. (c) (f-dquote c*))
(.. (c) (ws c))
(<p-cc> `(#:dstring ,c* ,n ,m))))
(.. (u) (@tag c))
(<p-cc>
(let ((r `(#:dstring ,c* ,n ,m)))
(if u
`(#:@ ,r ,@u)
r)))))
mk-id))
(define variable
......@@ -281,7 +335,9 @@
(<let> ((n N) (m M))
(.. (c) (variable-tok c))
(.. (q) (ws c))
(<p-cc> `(#:variable ,(string->symbol c) ,n ,m))))
(.. (u) (@tag q))
(<p-cc>
(wrap@ u `(#:variable ,(string->symbol c) ,n ,m)))))
mk-id))
(define symbolic-tok
......@@ -290,7 +346,11 @@
(<let> ((n N) (m M))
(.. (c) (symbolic c))
(.. (q) (ws c))
(<p-cc> `(#:symbolic ,(string->symbol c) ,n ,m)))))
(.. (u) (@tag q))
(<p-cc>
(if u
`(#:atom ,(string->symbol c) ,(car u) ,(cadr u) ,n ,m)
`(#:symbolic ,(string->symbol c) ,n ,m))))))
(define op-tok
(<p-lambda> (c)
......@@ -300,46 +360,20 @@
(.. (q) (ws c))
(<p-cc> `(#:symbolic ,(string->symbol c) ,n ,m)))))
(define atom_
(define atom
(p-freeze 'atom
(<p-lambda> (c)
(.. (c) (ws c))
(<let> ((n N) (m M))
(.. (c1) (atom-tok c))
(.. (c) (ws c1))
(<p-cc> `(#:atom ,(string->symbol c1) #f #f ,n ,m))))
(.. (u) (@tag c))
(<p-cc>
(if u
`(#:atom ,(string->symbol c1) ,(car u) ,(cadr u) ,n ,m)
`(#:atom ,(string->symbol c1) #f #f ,n ,m)))))
mk-id))
(define atom@
(let ((l (f-tag "("))
(r (f-tag ")"))
(@ (f-tag "@"))
(@@ (f-tag "@@")))
(p-freeze 'atom@
(<p-lambda> (c)
(.. (c) (ws c))
(<let> ((n N) (m M))
(.. (c1) (atom-tok c))
(<or>
(<and>
(.. (c) (@@ c1))
(.. (c) (l c))
(.. (cx) ((f-or expr ws) c))
(.. (c) (r cx))
(.. (c) (ws c))
(<p-cc> `(#:atom ,(string->symbol c1) @@ ,(<scm> cx) ,n ,m)))
(<and>
(.. (c) (@ c1))
(.. (c) (l c))
(.. (cx) (expr c))
(.. (c) (r cx))
(.. (c) (ws c))
(<p-cc> `(#:atom ,(string->symbol c1) @ ,(<scm> cx) ,n ,m))))))
mk-id)))
(define atom (f-or atom@ atom_))
(define paranthesis
(let ((l (f-tag "("))
(r (f-tag ")")))
......@@ -350,7 +384,8 @@
(.. (c3) (expr c2))
(.. (c4) (r c3))
(.. (c5) (ws c4))
(<p-cc> `(#:group ,(<scm> c3))))
(.. (u) (@tag c5))
(<p-cc> (wrap@ u `(#:group ,(<scm> c3)))))
mk-id)))
(define term-tok
......@@ -376,9 +411,11 @@
(<p-cc> a2))
(<p-cc> #f)))
(.. (c7) (ws c6))
(if (eq? c2 c3)
(<p-cc> `(#:term ,c1 () ,(<scm> c6) ,n ,m))
(<p-cc> `(#:term ,c1 ,(<scm> c3) ,(<scm> c6) ,n ,m)))))
(.. (u) (@tag c7))
(<p-cc>
(wrap@ u (if (eq? c2 c3)
`(#:term ,c1 () ,(<scm> c6) ,n ,m)
`(#:term ,c1 ,(<scm> c3) ,(<scm> c6) ,n ,m))))))
mk-id)))
(define scm-tok
......@@ -430,9 +467,11 @@
(xx (c5) (if cl
(.. (r c4))
(<p-cc> #f)))
(if (eq? c2 c3)
(<p-cc> `(#:lam-term ,c1 () ,cl ,n ,m))
(<p-cc> `(#:lam-term ,c1 ,(<scm> c3) ,cl ,n ,m)))))
(.. (u) (@tag c5))
(<p-cc>
(wrap@ u (if (eq? c2 c3)
`(#:lam-term ,c1 () ,cl ,n ,m)
`(#:lam-term ,c1 ,(<scm> c3) ,cl ,n ,m))))))
mk-id)))
(define termvar-tok
......@@ -447,9 +486,11 @@
(.. (c3) ((f-or expr ws) c2))
(.. (c4) (r c3))
(.. (c5) (ws c4))
(if (eq? c2 c3)
(<p-cc> `(#:termvar ,(string->symbol c1) () ,n ,m))
(<p-cc> `(#:termvar ,(string->symbol c1) ,(<scm> c3) ,n ,m)))))
(.. (u) (@tag c5))
(<p-cc>
(wrap@ u (if (eq? c2 c3)
`(#:termvar ,(string->symbol c1) () ,n ,m)
`(#:termvar ,(string->symbol c1) ,(<scm> c3) ,n ,m))))))
mk-id)))
(define termop-tok
......@@ -464,13 +505,15 @@
(.. (c3) ((f-or expr ws) c2))
(.. (c4) (r c3))
(.. (c5) (ws c4))
(.. (u) (@tag c5))
(if (match (<scm> c3)
(((_ _ "," _) _ _ _ _)
#t)
(_
#f))
(<p-cc> `(#:term (#:atom ,(string->symbol c1) ,n ,m)
,(<scm> c3) #f ,n ,m))
(<p-cc>
(wrap@ u `(#:term (#:atom ,(string->symbol c1) ,n ,m)
,(<scm> c3) #f ,n ,m)))
<fail>)))
mk-id)))
......@@ -486,9 +529,12 @@
(.. (c3) ((f-or expr ws) c2))
(.. (c4) (r c3))