most things works

parent 4446c7d3
......@@ -10,7 +10,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:export (goal scm fff define-goal-transformer add-op-map op->fkn
get-functor-stx op->>fkn))
get-functor-stx op->>fkn maybe-op))
(define do-print #f)
(define pp
......@@ -112,6 +112,31 @@
(format #f "Could not find unary op ~a at ~a" op (get-refstr N M)))
op)))))
(define (maybe-op op n)
(cond
((= n 1)
(let lp ((ops op-map))
(match ops
(((((or 'fx 'xf 'fy 'yf) . (? (lambda (x) (equal? x op)))) . f)
. _)
f)
((_ . l)
(lp l))
(_ #f))))
((= n 2)
(let lp ((ops op-map))
(match ops
(((((or 'xfx 'xfy 'yfx 'yfy) .
(? (lambda (x) (equal? x op)))) . f)
. _)
f)
((_ . l)
(lp l))
(_ #f))))
(else
#f)))
(define (op->fkn type op n N M)
(define (errstr op) "Operator '~a' have no goal-translator defined" op)
......
......@@ -40,14 +40,19 @@
(x (list (f x)))))
(define (get-binding x stx)
(define (get-binding x stx opify)
(match x
((#:atom f #f #f n m)
(datum->syntax stx f))
(datum->syntax stx (opify f)))
((#:atom f amp (#:string a . _) n m)
#`(#,(datum->syntax stx amp) (#,(datum->syntax stx (string->symbol a))) #,(datum->syntax stx f)))
#`(#,(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)))
#`(#,(datum->syntax stx amp) (#,(datum->syntax stx a))
#,(datum->syntax stx f)))
((#:atom f amp (and l ((_ _ "," _) _ _ _ _)) n m)
(let ((l (map
(lambda (x)
......@@ -57,9 +62,13 @@
(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))))
#`(#,(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)))))
#`(#,(datum->syntax stx amp)
#,(datum->syntax stx `(language prolog prolog-modules ,f))
#,(datum->syntax stx f)))))
(define *prolog-file* (make-fluid #f))
......
......@@ -36,7 +36,10 @@
(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)))))))))
(fluid-set! syms (vhash-consq f #t (fluid-ref syms)))))))
(s (if (symbol? s)
(fluid-set! syms (vhash-consq s #t (fluid-ref syms)))))))
(define (rem-sym sym)
(fluid-set! syms (vhash-delq sym (fluid-ref syms))))
......
......@@ -25,6 +25,7 @@
(define get-double-quote-flag-fkn #f)
(define (fa x) x)
(define x_x #',GL:_)
(define (mk-arg goal?)
(letrec ((arg0
......@@ -42,13 +43,13 @@
((#:list v . _) (get-c fget v))
((#:term (and atom (#:atom f . _)) () . _)
(add-sym atom)
#`(unquote #,(get-binding atom stx)))
#`(unquote #,(get-binding atom stx fa)))
((#:term (and atom (#:atom f . _)) x . _)
(add-sym atom)
#`(unquote
(vector
`(,#,(get-binding atom stx)
`(,#,(get-binding atom stx fa)
#,@(map fget (get.. "," x))))))
((#:termvar v () . _)
......@@ -62,7 +63,7 @@
((and atom (#:atom v _ _ n m))
(add-sym atom)
#`(unquote #,(get-binding atom stx)))
#`(unquote #,(get-binding atom stx fa)))
((#:number n . _) n)
......@@ -70,7 +71,7 @@
(- n))
((#:symbolic s n m)
;(add-sym s)
(add-sym s)
#`(unquote #,(get-functor-stx stx (op->>fkn s n m))))
((or (('xfx _ '=.. _) x y n m)
......@@ -80,7 +81,7 @@
#`,(vector
`(,#,(get-functor-stx stx (op->fkn 'xfx '=.. 2 n m))
(fget x)
,#,(get-binding atom stx)
,#,(get-binding atom stx fa)
#,@(get-c fget z))))
(_ (cont))))
......@@ -146,13 +147,13 @@
((#:list v . _) (get-c fget v))
((#:term (and atom (#:atom f . _)) () . _)
(add-sym atom)
#`(unquote #,(get-binding atom stx)))
#`(unquote #,(get-binding atom stx fa)))
((#:term (and atom (#:atom f . _)) x . _)
(add-sym atom)
#`(unquote
(vector
`(,#,(get-binding atom stx)
`(,#,(get-binding atom stx fa)
#,@(map fget (get.. "," x))))))
((#:termvar v () . _)
......@@ -170,13 +171,14 @@
((and atom (#:atom v _ _ n m))
(add-sym atom)
#`(unquote #,(get-binding atom stx)))
#`(unquote #,(get-binding atom stx fa)))
((#:number n . _) n)
(((_ _ "-" _) (#:number n _ _) _ _)
(- n))
((#:symbolic s n m)
(add-sym s)
#`(unquote #,(get-functor-stx stx (op->>fkn s n m))))
((or (('xfx _ '=.. _) x y n m)
......@@ -186,7 +188,7 @@
#`,(vector
`(,#,(referee stx (get-functor-stx stx (op->fkn 'xfx '=.. 2 n m)))
(fget x)
,#,(get-binding atom stx)
,#,(get-binding atom stx fa)
#,@(get-c fget z))))
(_ (cont))))
......@@ -226,11 +228,11 @@
((#:dstring str . _) ((get-double-quote-flag-fkn) str))
((#:term (and atom (#:atom f . _)) () . _)
(add-sym atom)
(get-binding atom stx))
(get-binding atom stx fa))
((#:term (and atom (#:atom f . _)) x . _)
(add-sym atom)
#`#((,#,(get-binding atom stx)
#`#((,#,(get-binding atom stx fa)
#,@(map fget (get.. "," x)))))
((#:termvar v () . _)
......@@ -242,13 +244,14 @@
((and atom (#:atom v _ _ n m))
(add-sym atom)
#`(unquote #,(get-binding atom stx)))
#`(unquote #,(get-binding atom stx fa)))
((#:number n . _) n)
(((_ _ "-" _) (#:number n _ _) _ _)
(- n))
((#:symbolic s n m)
(add-sym s)
#`(unquote #,(get-functor-stx
stx
(op->>fkn s n m))))
......@@ -262,7 +265,7 @@
(op->fkn 'xfx '=.. 2
n m))
#,(fget x)
,#,(get-binding atom stx)
,#,(get-binding atom stx fa)
#,@(get-c fget z)))
(_ (cont))))
......@@ -297,13 +300,13 @@
((#:dstring str . _) ((get-double-quote-flag-fkn) str))
((#:term (and atom (#:atom f . _)) () . _)
(add-sym atom)
#`(unquote #,(get-binding atom stx)))
#`(unquote #,(get-binding atom stx fa)))
((#:term (and atom (#:atom f . _)) x . _)
(add-sym atom)
#`(unquote
(vector
`(,#,(get-binding atom stx)
`(,#,(get-binding atom stx fa)
#,@(map fget (get.. "," x))))))
((#:termvar v () . _)
......@@ -319,13 +322,14 @@
((and atom (#:atom v _ _ n m))
(add-sym atom)
#`(unquote #,(get-binding atom stx)))
#`(unquote #,(get-binding atom stx fa)))
((#:number n . _) n)
(((_ _ "-" _) (#:number n _ _) _ _)
(- n))
((#:symbolic s n m)
(add-sym s)
#`(unquote #,(get-functor-stx
stx
(op->>fkn s n m))))
......@@ -341,7 +345,7 @@
stx
(op->fkn 'xfx '=.. 2 n m))
#,(fget x)
,#,(get-binding atom stx)
,#,(get-binding atom stx fa)
#,@(get-c fget z)))))
(_ (cont))))
......
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