read_term write_term test passes

parent 73011189
......@@ -76,7 +76,7 @@
(define (<-ch x)
(list->string (list x)))
(<define> (char_conversion_ ch1 ch2)
(<define> (char_conversion ch1 ch2)
(<let> ((ch1 (<lookup> ch1))
(ch2 (<lookup> ch2)))
(if (or (<var?> ch1) (<var?> ch2))
......@@ -90,7 +90,10 @@
(representation_error character))
(else
(<code> (add-char-conversion ch1- ch2-))))))))
(set! char_conversion char_conversion_)
(set! (@ (logic guile-log prolog names) char_conversion)
char_conversion)
(init-flags)
(<define> (current_char_conversion ch1 ch2)
......@@ -145,7 +148,5 @@
(_
(format #t "COMPILE ERROR: Bad character format in char_conversion at ~a~%" (get-refstr N M)))))
(set! (@ (logic guile-log prolog names) char_conversion)
char_conversion)
(set! (@ (logic guile-log prolog names) char-convert)
char-convert)
......@@ -481,7 +481,7 @@
(let ((a (gp-lookup a s)))
(cond
((string? a)
(format #f "~a"
(format #f (if quoted? "'~a'" "~a")
(list->string
(let lp ((l (string->list a)))
(if (pair? l)
......@@ -556,7 +556,8 @@
(domain_error write_option opt)))))
(lp opts)))
(()
(<cut> (<code> (format s "~a" (scm->pl S t ns q i n)))))
(<and>
(<cut> (<code> (format s "~a" (scm->pl S t ns q i n))))))
(_
(instantiation_error)))))))))
((t opts)
......@@ -609,7 +610,7 @@
((s t opts)
(<let*> ((ss (<lookup> s))
(s (stream-alias-lookup ss)))
(cond
(cond
((<var?> s)
(instantiation_error))
((not (prolog-stream-alias? s))
......@@ -625,7 +626,7 @@
(else
(<var> (vars varnames singletons)
(<recur> lp ((opt opts))
(<recur> lp ((opts opts))
(<match> (#:mode - #:name read_term_opts) (opts)
((opt . opts)
(<let> ((opt (<lookup> opt)))
......@@ -644,7 +645,8 @@
(domain_error read_option opt)))
(lp opts)))))
(()
(<cut> (read* s t vars varnames singletons)))
(<and>
(<cut> (read* s t vars varnames singletons))))
(_
(instantiation_error)))))))))
......
......@@ -275,23 +275,32 @@
mk-id))
(define atom@
(p-freeze 'atom
(<p-lambda> (c)
(.. (c) (ws c))
(<let> ((n N) (m 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))
(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_))
......@@ -398,13 +407,13 @@
(if (eq? c2 c3)
(<p-cc> `(#:termstring ,c1 () ,n ,m))
(<let*> ((c3 (<scm> c3))
(a (match c3
(((_ _ "," _) x y _ _)
(list x y))
(_ #f))))
(if a
(<p-cc> `(#:termstring ,c1 ,a ,n ,m))
(<p-cc> `(#:termstring ,c1 ,c3 ,n ,m)))))))
(a (match c3
(((_ _ "," _) x y _ _)
(list x y))
(_ #f))))
(if a
(<p-cc> `(#:termstring ,c1 ,a ,n ,m))
(<p-cc> `(#:termstring ,c1 ,c3 ,n ,m)))))))
mk-id)))
(define list-tok
......
......@@ -39,17 +39,23 @@
(x (list (f x)))))
(define (get-binding x stx)
(match x
((#:atom f #f #f n m)
(datum->syntax stx f))
((#:atom f amp (and l ((_ _ "," _) _ _ _)) n m)
((#:atom f amp (#:string a . _) n m)
#`(#,(datum->syntax stx amp) (#,(datum->syntax stx (string->symbol a))) #,(datum->syntax stx f)))
((#:atom f amp (#:atom a . _) n m)
#`(#,(datum->syntax stx amp) (#,(datum->syntax stx a)) #,(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)))))
((#:atom a _ _ n m) a)
((#:string a n m)
(string->symbol 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)
......@@ -67,16 +73,18 @@
(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 (and (not not-pretty?) (module-ref (current-module) (procedure-name f)))
'()
(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)))
'()))))
(if not-pretty?
(st (module-name (current-module)))
'())))))
\ No newline at end of file
(define-module (logic guile-log prolog symbols)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (logic guile-log prolog pre)
#:export (clear-syms add-sym rem-sym get-syms rem-syms))
(define (get... x)
(match x
(((_ _ "," _) . l)
(get.. "," x))
(_ x)))
(define syms (make-fluid vlist-null))
(define (clear-syms)
(fluid-set! syms vlist-null))
......@@ -10,13 +17,16 @@
(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)
((#:atom f amp (and atom ((or #:string #:atom) a . _)) n m)
(add-sym `(#:atom ,f ,amp (,atom) ,n ,m)))
((#:atom f amp l n m)
(let ((l (map
(lambda (x)
(match x
((#:atom a _ _ n m) a)
((#:string a . _) (string->symbol a))
(_ (error "wrong @ argument in ~a" (get-refstr n m)))))
(get.. "," l))))
(get... l))))
(let ((mod (resolve-module l)))
(cond
((eq? (current-module) (module-ref mod f))
......
......@@ -132,7 +132,7 @@
(lambda (stx x)
(define (fget x) (term stx x))
(define (fgoal x) (term-goal stx x))
(match (pp 'term x)
(match x
(() '())
((#:group x) (fget x))
((#:variable '_ . _) #',((@@ (logic guile-log umatch) gp-make-var)))
......@@ -148,7 +148,7 @@
(add-sym atom)
#`(unquote #,(get-binding atom stx)))
((#:term (and atom (#:atom f . _)) x . _)
((#:term (and atom (#:atom f . _)) x . _)
(add-sym atom)
#`(unquote
(vector
......
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