namespaces initial implementation, pretty-printer

parent ad404124
......@@ -104,7 +104,8 @@
(flatten (append x l)))
((x . l)
(cons x (flatten l)))
(x x)))
(() '())
(x (error "match error in flatten"))))
(define (top x)
(match (pp 'top x)
......@@ -112,7 +113,7 @@
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(mk-rhs stx
`(#:term (#:atom assertz ,n ,m)
`(#:term (#:atom assertz #f #f ,n ,m)
,(car x) ,n ,m))))
(match y
(()
......@@ -124,7 +125,7 @@
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(mk-rhs stx
`(#:term (#:atom assertz ,n ,m)
`(#:term (#:atom assertz #f #f ,n ,m)
,(car x) ,n ,m))))
(list v '() z)))
......@@ -147,11 +148,11 @@
((#:translated _ _)
x)
((#:atom v n m)
((#:atom v _ _ n m)
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom assertz ,n ,m)
`(#:term (#:atom assertz #f #f ,n ,m)
,x ,n ,m))))
(list v '() '())))
......@@ -159,7 +160,7 @@
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom assertz ,n ,m)
`(#:term (#:atom assertz #f #f ,n ,m)
,x ,n ,m))))
(list v (get.. "," y) '())))))
......
......@@ -72,9 +72,9 @@
(define (parse-PI err N M)
(letrec ((PI (lambda (x)
(match x
(((_ _ "/" _) (#:atom f _ _) (#:number n _ _) _ _)
(((_ _ "/" _) (#:atom f . _) (#:number n _ _) _ _)
(list (cons f n)))
((#:atom f _ _)
((#:atom f . _)
(list f))
((#:list a _ _) (apply append (map PI (get.. "," a))))
(_ (format #f err M N))))))
......@@ -203,16 +203,16 @@
(define-parser-directive-onfkn op (op-spc stx l N M)
(match (get.. "," l)
(((#:number prio _ _)
(#:atom spec _ _)
(or (#:string x _ _) (#:atom x _ _) (#:symbolic x _ _)))
(#:atom spec . _)
(or (#:string x _ _) (#:atom x . _) (#:symbolic x _ _)))
(prolog-run 1 (op prio (make-spec spec) x))
#f)
(((#:number prio _ _)
(#:atom spec _ _)
(#:atom spec . _)
(#:list li _ _))
(match (get.. "," li)
(((or (#:atom x _ _) (#:string x _ _) (#:symbolic x _ _)) ...)
(((or (#:atom x . _) (#:string x _ _) (#:symbolic x _ _)) ...)
(prolog-run 1 (op prio (make-spec spec) x))
#f)
(_ (format #t "Bad op/3 directive at ~a~%" (get-refstr N M)) #t)))
......@@ -226,7 +226,7 @@
(match l
((#:string str _ _)
#`(load (ensure_loaded_ #,str)))
((#:atom atm _ _)
((#:atom atm . _)
#`(load (ensure_loaded_ #,(symbol->string atm))))
(_ (format #t "COMPILE ERROR: Bad ensure_loaded/1 directive at ~a~%"
(get-refstr N M)) #t)))
......@@ -243,8 +243,8 @@
(error "initializattion is not for dynamic evaluation"))
(define-parser-directive-onfkn initialization (initialization-spec stx goal N M)
`(#:untranslate
(((xfx 1 ":-" 1) (#:atom local_initialization ,N ,M)
((xfy 1 "," 1) ,goal (#:atom fail ,N ,M) ,N ,M) ,N ,M))))
(((xfx 1 ":-" 1) (#:atom local_initialization #f #f ,N ,M)
((xfy 1 "," 1) ,goal (#:atom fail #f #f ,N ,M) ,N ,M) ,N ,M))))
(define *prolog-flags* (make-fluid '()))
(define (set-flag key val)
......@@ -341,8 +341,8 @@
(define-parser-directive-onfkn set_prolog_flag (prolog-flag stx l N M)
(match (get.. "," l)
(((#:atom k _ _)
(or (#:atom v _ _)
(((#:atom k . _)
(or (#:atom v . _)
(#:number v _ _)))
(let ((k (module-ref (current-module) k))
(v (if (number? v) v (module-ref (current-module) v))))
......
......@@ -30,30 +30,18 @@
(define G #f)
(define H #f)
#;
(define-syntax-rule (define-error (nm a ...) code)
(define (nm s p cc a ...)
(abort-to-prompt tag
(lambda ()
(G
(abort-to-prompt tag
(lambda ()
(G
(lambda ()
(catch tag
(lambda () (<abort> s p cc
'prolog non-reentrant (fkn-it code)))
(catch #t
(lambda ()
(<abort> s p cc
'prolog non-reentrant (fkn-it code)))
H)))))))
(define-syntax-rule (define-error (nm a ...) code)
(define (nm s p cc a ...)
;(pk 'error (list a ...))
(abort-to-prompt tag
(lambda ()
(G
(lambda ()
(catch #t
(lambda () (<abort> s p cc
'prolog non-reentrant (fkn-it code)))
H)))))))
(define evaluation_error
(case-lambda
((s p cc)
......@@ -134,82 +122,54 @@
(define scheme-wrapper
(let ()
(letrec ((g (lambda (fkn)
(letrec ((g (lambda (fkn)
(call-with-prompt tag
fkn
(lambda (k f)
(g f)))))
(h (lambda x
(define-syntax-rule (wrap f)
(abort-to-prompt tag
(lambda ()
(catch #t
(lambda () f)
h))))
(let ((s (fluid-ref *current-stack*)))
(match x
;; To avoid an inifinite recursion
(('misc-error _ _ (_ 123) _)
x)
#;(('wrong-type-arg #f . _))
(('system-error "open-file" pat
(_ file) (2))
(abort-to-prompt tag
(lambda ()
(catch #t
(lambda ()
(existence_error s p cc source_sink file))
h))))
(wrap (existence_error s p cc source_sink file)))
(('numerical-overflow . _)
(abort-to-prompt tag
(lambda ()
(catch #t
(lambda ()
(evaluation_error s p cc 'num))
h))))
(wrap (evaluation_error s p cc 'num)))
(('wrong-type-arg fkn str ("exact integer" val) . _)
(abort-to-prompt
tag
(lambda ()
(catch #t
(lambda () (type_error s p cc integer val))
h))))
(wrap (type_error s p cc integer val)))
(('wrong-type-arg fkn str (arg val) . _)
(let ((val (gp-lookup val s)))
(cond
((gp-var? val s)
(abort-to-prompt
tag
(lambda ()
(catch #t
(lambda () (instantiation_error s p cc))
h))))
(wrap (instantiation_error s p cc)))
((member fkn ariths)
(abort-to-prompt
tag
(lambda ()
(catch #t
(lambda () (type_error s p cc number val))
h))))
(warap (type_error s p cc number val)))
((member fkn arith-ints)
(abort-to-prompt
tag
(lambda ()
(catch #t
(lambda () (type_error s p cc integer val))
h))))
(wrap (type_error s p cc integer val)))
(else
(abort-to-prompt
tag
(lambda ()
(catch #t
(lambda () (syntax_error s p cc
(format #f "~s" x)))
h)))))))
(_ (abort-to-prompt
tag
(lambda ()
(catch #t
(lambda ()
(syntax_error s p cc (format #f "~s" x)))
h)))))))))
(wrap (syntax_error s p cc (format #f "~s" x)))))))
(_ (wrap (syntax_error s p cc (format #f "~s" x)))))))))
(set! G g)
(set! H h)
(lambda (thk) (g (lambda () (catch #t thk h)))))))
......
......@@ -31,12 +31,14 @@
(begin
(<define> (nm cut . a)
(<with-cut> cut . code))
(attach-defined-module! nm)
(set-object-property! nm 'prolog-functor-type #:goal)
(set-object-property! nm 'prolog-functor-stx #'nm)))
((_ nm code)
(begin
(define nm code)
(attach-defined-module! nm)
(set-object-property! nm 'prolog-functor-type #:goal)
(set-object-property! nm 'prolog-functor-stx #'nm)))))
......@@ -48,12 +50,14 @@
((_ (nm . a) . code)
(begin
(define (nm . a) . code)
(attach-defined-module! nm)
(set-object-property! nm 'prolog-functor-type #:goal)
(set-object-property! nm 'prolog-functor-stx #'nm)))
((_ nm code)
(begin
(define nm code)
(attach-defined-module! nm)
(set-object-property! nm 'prolog-functor-type #:goal)
(set-object-property! nm 'prolog-functor-stx #'nm)))))
......
......@@ -157,8 +157,7 @@
'(tp ...))
(define-goal-transformer nm-func (nm-tr stx n m a ...)
#`(code nm-code #,(tp stx a) ...))
(set-object-property! nm-func 'prolog-operator op)
(add-op-map op-type op nm-tr))))
(add-op-map op-type op nm-tr nm-func))))
(meta-mk-prolog-op mk-prolog-biop stx nm-code
(x y) (tp1 tp2) <2>)
......@@ -207,7 +206,7 @@
(scm-ck 'code 'nm-code (tp 'a) ...)))
(define-goal-transformer nm-func (nm-tr stx n m a ...)
#`(code nm-code #,(tp stx a) ...))
(add-op-map op-type op nm-tr))))
(add-op-map op-type op nm-tr nm-func))))
(meta-mk-scheme-op mk-scheme-biop stx nm-code
......@@ -261,7 +260,7 @@
(define-goal-functor fk-name (fk-error op))
(define-goal-transformer fk-name tr-name (tr-error op))
(set-procedure-property! fk-name 'name 'fk-name)
(add-op-map tp op tr-name)))
(add-op-map tp op tr-name fk-name)))
(mk-prolog-abstract 'xfy "^" circumflex tr-cirkum)
(mk-prolog-abstract 'fy ":-" directive tr-directive)
......@@ -466,7 +465,7 @@ floor(x) (floor x)
(_
#`(<or> #,(goal stx x) #,(goal stx y)))))
(add-op-map 'xfy ";" tr-disjunction)
(add-op-map 'xfy ";" tr-disjunction disjunction)
......
......@@ -93,7 +93,8 @@
(define op-map '())
(define (add-op-map kind op f)
(define (add-op-map kind op f func)
(set-procedure-property! func 'prolog-operator op)
(set! op-map (cons (cons (cons kind (->string op)) f) op-map)))
(define (op->>fkn op N M)
......@@ -164,13 +165,13 @@
(goal stx x))
((#:list (or (#:variable x _ _)
(#:atom x _ _)
(#:atom x _ _ _ _)
(#:string x _ _)) _ _)
(datum->syntax stx (pk `(load-prolog ,x))))
((#:atom 'true . _) #'<cc>)
((#:atom 'fail . _) #'<fail>)
((#:atom v n m)
((#:atom v _ _ n m)
(goal stx `(#:term ,z () ,n ,m)))
((#:symbolic '! . _) #'<cut>)
......@@ -227,7 +228,7 @@
(define (fff stx x)
(match x
((#:atom f _ _)
(datum->syntax stx f))
((and atom (#:atom f _ _ _ _))
(get-binding atom stx))
((#:variable v _ _)
(datum->syntax stx v))))
\ No newline at end of file
......@@ -11,6 +11,7 @@
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog char)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog pre)
#:use-module (rnrs io ports)
#:replace (write open close read)
#:export (nl pp current_input current_output standard_input standard_output
......@@ -428,7 +429,7 @@
(nl (fluid-ref *current-output*)))))
(define* (scm->pl s x #:optional (quoted? #f) (ignore? #f) (numbervars? #f))
(define* (scm->pl s x #:optional (ns? #f) (quoted? #f) (ignore? #f) (numbervars? #f))
(define *variables* (make-hash-table))
(define i 0)
(define (next)
......@@ -451,13 +452,27 @@
(let ((f (gp-lookup f s)))
(if (string? f)
(format #f "'~a'(~a~{, ~a~})" f (lp a) (map lp (gp->scm l s)))
(format #f "~a(~a~{, ~a~})"
(procedure-name f)
(lp a) (map lp (gp->scm l s))))))
(let ((op (procedure-property f 'prolog-operator)))
(if (and op (not ns?))
(format #f "'~a'(~a~{, ~a~})"
op
(lp a) (map lp (gp->scm l s)))
(let ((ll (map (lambda (x) (format #f "'~a'" x)) (get-attached-module f ns?))))
(if (pair? ll)
(format #f "~a@@(~a~{, ~a~})(~a~{, ~a~})"
(procedure-name f) (car ll) (cdr ll)
(lp a) (map lp (gp->scm l s)))
(format #f "~a(~a~{, ~a~})"
(procedure-name f)
(lp a) (map lp (gp->scm l s))))))))))
(#((f))
(if (string? f)
(format #f "'~a'()" f)
(format #f "~a()" (procedure-name 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))))))
((a . l)
(format #f "[~a]" (list-it x)))
......@@ -484,7 +499,10 @@
(hashq-set! *variables* a n)
n))))
((procedure? a)
(format #f "~a" (procedure-name a)))
(let ((ll (map (lambda (x) (format #f "'~a'" x)) (get-attached-module a ns?))))
(if (pair? ll)
(format #f "~a@@(~a~{, ~a~})" (procedure-name a) (car ll) (cdr ll))
(format #f "~a" (procedure-name a)))))
(else
(format #f "~a" a)))))))
(lp x))
......@@ -508,9 +526,11 @@
((binary-port? s)
(permission_error input binary_stream ss))
(else
(<let> ((q #t)
(i #t)
(n #f))
(<let> ((ns #f)
(q #f)
(i #t)
(n #f))
(<recur> lp ((opts opts))
(<match> (#:mode - #:name write_term_opts) (opts)
((opt . opts)
......@@ -521,9 +541,9 @@
(else
(<match> (#:mode - #:name write_term_opt) (opt)
(#((,quoted ,true))
(<code> (set! q #t)))
(<code> (set! q #t) (set! ns #t)))
(#((,quoted ,false))
(<code> (set! q #f)))
(<code> (set! q #f) (set! ns #f)))
(#((,ignore_ops ,true))
(<code> (set! i #t)))
(#((,ignore_ops ,false))
......@@ -536,7 +556,7 @@
(domain_error write_option opt)))))
(lp opts)))
(()
(<cut> (<code> (format s "~a" (scm->pl S t q i n)))))
(<cut> (<code> (format s "~a" (scm->pl S t ns q i n)))))
(_
(instantiation_error)))))))))
((t opts)
......
......@@ -25,7 +25,7 @@
(action))))
(lambda x (action)))
(pk `(compiling and/or load of ,str))
;(pk `(compiling and/or load of ,str))
scm))
(define ensure_loaded_ load-prolog_)
......
......@@ -10,20 +10,15 @@
#:use-module (logic guile-log prolog names)
#:use-module ((logic guile-log) #:select (<let> <pp> <scm> <code> <let*>
<var> <=> <fail> <match>
<cut> <and>
<cut> <and> <or>
(_ . GL:_)))
#:re-export (*prolog-file* get-refstr)
#:export (prolog-parse define-parser-directive add-op rem-op
define-parser-directive-onfkn prolog-parse-read
ops->assq assq->ops get-refstr
get-ops *prolog-file*
ops->assq assq->ops
get-ops
round floor ceil))
(define *prolog-file* (make-fluid #f))
(define (get-refstr N M)
(if (fluid-ref *prolog-file*)
(format #f "~a:(~a,~a)" (fluid-ref *prolog-file*) M N)
(format #f "~a:(~a,~a)" (module-name (current-module)) M N)))
(define do-print #f)
(define pp
......@@ -269,16 +264,37 @@
(.. (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))))
mk-id))
(define atom@
(p-freeze 'atom
(<p-lambda> (c)
(.. (c) (ws c))
(<let> ((n N) (m M))
(.. (c) (atom-tok c))
(.. (c) (ws c))
(<p-cc> `(#:atom ,(string->symbol c) ,n ,m))))
(.. (c1) (atom-tok c))
(<or>
(<and>
(.. (c) ((f-seq (s-char #\@) (s-char #\@)) c1))
(.. (cx) (expr c))
(.. (c) (ws cx))
(<p-cc> `(#:atom ,(string->symbol c1) @@ ,cx ,n ,m)))
(<and>
(.. (c) ((s-char #\@) c1))
(.. (cx) (expr c))
(.. (c) (ws cx))
(<p-cc> `(#:atom ,(string->symbol c1) @ ,cx ,n ,m))))))
mk-id))
(define atom (f-or atom@ atom_))
(define paranthesis
(let ((l (f-tag "("))
(r (f-tag ")")))
......@@ -425,7 +441,7 @@
(define (f-parse-1 stx m)
(<p-lambda> (c)
(.. (d) (m GL:_))
(<p-cc> (cons (parse-1 S stx (<scm> d)) c))))
(<p-cc> (cons (pp 'p1 (parse-1 S stx (<scm> d))) c))))
;; For now we do not do anything here but it is possible to implement
;; parser directions here
......@@ -449,7 +465,7 @@
(with-fluids ((*current-stack* s))
(match x
(((fx _ ":-" _ ) (#:term (#:atom nm _ _) l _ _) N M)
(((fx _ ":-" _ ) (#:term (#:atom nm _ _ _ _) l _ _) N M)
(call-with-values
(lambda () (syntax-local-binding (datum->syntax stx nm)))
(lambda (type val)
......
......@@ -2,7 +2,8 @@
#:use-module (ice-9 match)
#:use-module (logic guile-log prolog error)
#:use-module (ice-9 pretty-print)
#:export (get.. get-c pp))
#:export (get.. get-c pp get-binding get-refstr *prolog-file*
attach-defined-module! get-attached-module))
(define pp
(case-lambda
......@@ -15,7 +16,7 @@
(define (get.. op l)
(match l
(((_ _ "," _) x y _ _)
(((_ _ (? (lambda (x) (equal? op x))) _) x y _ _)
(cons x (get.. op y)))
(x (list x))))
......@@ -38,4 +39,44 @@
(x (list (f x)))))
\ No newline at end of file
(define (get-binding x stx)
(match x
((#:atom f #f #f n m)
(datum->syntax stx f))
((#:atom f amp (and l ((_ _ "," _) _ _ _)) n m)
(let ((l (map
(lambda (x)
(match x
((#:atom a _ _ n m) a)
(_ (error "wrong @ argument in ~a" (get-refstr n m)))))
(get.. "," l))))
#`(#,(datum->syntax stx amp) #,(datum->syntax stx l) #,(datum->syntax stx f))))
((#:atom f amp (#:atom f . _) n m)
#`(#,(datum->syntax stx amp) #,(datum->syntax stx `(language prolog prolog-modules ,f)) #,(datum->syntax stx f)))))
(define *prolog-file* (make-fluid #f))
(define (get-refstr N M)
(if (fluid-ref *prolog-file*)
(format #f "~a:(~a,~a)" (fluid-ref *prolog-file*) M N)
(format #f "~a:(~a,~a)" (module-name (current-module)) M N)))
(define* (attach-defined-module! f #:optional (mod (current-module)))
(set-procedure-property! f 'module (module-name mod)))
(define* (get-attached-module f #:optional (not-pretty? #t))
(define (st l) (map symbol->string l))
(let ((x (procedure-property f 'module)))
(if x
(if not-pretty?
(st x)
(let ((r (module-name (current-module))))
(if (equal? r x)
'()
(st x))))
(if not-pretty?
(st (module-name (current-module)))
'()))))
\ No newline at end of file
......@@ -10,11 +10,11 @@
(define (get-fkn a)
(cond
((string? a)
(format "'~a'" a))
(format #f "'~a'" a))
((symbol? a)
(format "~a" a))
(format #f "~a" a))
((procedure? a)
(format "~a" (procedure-name a)))))
(format #f "~a" (procedure-name a)))))
(match x
......@@ -29,7 +29,7 @@
(a
(if (procedure? a)
(format "~a" (procedure-name a))
(format #f "~a" (procedure-name a))
(format #f "~a" a)))))
(define-syntax-rule (prolog-run n a ...)
......@@ -41,8 +41,8 @@
(begin
(<clear>)
(<run> n ()
(<catch> 'prolog #f
lam
(<catch> 'prolog #f
lam
(<lambda> (tag next l)
(<format> #t "DYNAMIC ERROR:~%=> ~a~%~%" (var->code (<scm> l)))
(<ret> (<scm> l)))))))))
(define-module (logic guile-log prolog symbols)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:export (clear-syms add-sym rem-sym get-syms rem-syms))
(define syms (make-fluid vlist-null))
(define (clear-syms)
(fluid-set! syms vlist-null))
(define (add-sym sym)
(fluid-set! syms (vhash-consq sym #t (fluid-ref syms))))
(match sym
((#:atom f #f #f n m)
(fluid-set! syms (vhash-consq f #t (fluid-ref syms))))
((#:atom f amp (and l ((_ _ "," _) _ _ _)) n m)
(let ((l (map
(lambda (x)
(match x
((#:atom a _ _ n m) a)
(_ (error "wrong @ argument in ~a" (get-refstr n m)))))
(get.. "," l))))
(let ((mod (resolve-module l)))
(cond
((eq? (current-module) (module-ref mod f))
(fluid-set! syms (vhash-consq f #t (fluid-ref syms))))))))
((#:atom f amp (#:atom f . _) n m)
(let ((mod (resolve-module `(language prolog prolog-modules ,f))))
(cond
((eq? (current-module) (module-ref mod f))
(fluid-set! syms (vhash-consq f #t (fluid-ref syms)))))))))
(define (rem-sym sym)
(fluid-set! syms (vhash-delq sym (fluid-ref syms))))
(define (get-syms)
......
......@@ -40,15 +40,15 @@
((#:string str . _) str)
((#:dstring str . _) ((get-double-quote-flag-fkn) str))
((#:list v . _) (get-c fget v))
((#:term (#:atom f . _) () . _)
(add-sym f)
#`(unquote #,(datum->syntax stx f)))
((#: