major rework of operator/func compiler

parent ace0b2a3
......@@ -33,7 +33,8 @@ Version 0.5,
* corouttines
* tracing
* Better compilation error handling
* Support for namespaced operators in prolog (TODO)
* Support for X[a] and X{A} (TODO)
Version 0.6, TODO
* GC of the (almost) unreachable tail of a stream (all)
......
......@@ -213,7 +213,7 @@
(else x)))
(define-parser-directive-onfkn op (op-spc stx l N M)
(match (get.. "," l)
(match (pk (get.. "," l))
(((#:number prio _ _)
(#:atom spec . _)
(or (#:string x _ _) (#:atom x . _) (#:symbolic x _ _)))
......
......@@ -35,23 +35,6 @@
(pretty-print (syntax->datum x)))
x)))
(define-syntax define-goal-functor
(syntax-rules ()
((_ (nm . a) . code)
(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)))))
(define (get-goal-sym f)
(syntax->datum (object-property f 'prolog-functor-stx)))
......
......@@ -5,13 +5,13 @@
#:use-module (logic guile-log prolog pre)
#:use-module (logic guile-log prolog parser)
#:use-module (logic guile-log prolog load)
#:use-module (logic guile-log prolog operators)
#:use-module (logic guile-log)
#:use-module (system syntax)
#:use-module (ice-9 match)
#:use-module (ice-9 eval-string)
#:use-module (ice-9 pretty-print)
#:export (goal scm define-goal-transformer add-op-map op->fkn
get-functor-stx op->>fkn maybe-op))
#:export (goal scm define-goal-transformer))
(define do-print #f)
(define pp
......@@ -34,147 +34,12 @@
(when #t
(pretty-print (syntax->datum x)))
x)))
(define (get-functor-stx stx f)
(let ((f1 (object-property f 'goal-functor))
(f* (if (string? f)
(datum->syntax stx (string->symbol f))
(datum->syntax stx (procedure-name f)))))
(if f1
(let ((r (object-property f1 'prolog-functor-stx)))
(if r
r
f*))
f*)))
(define-syntax define-goal-transformer
(syntax-rules ()
((_ func (ftr . a) . code)
(begin
(define (ftr . a) . code)
(set-object-property! func 'goal-transformer ftr)
(set-object-property! ftr 'goal-functor func)))
((_ func ftr code)
(begin
(define ftr code)
(set-object-property! func 'goal-transformer ftr)
(set-object-property! ftr 'goal-functor func)))))
(define (term-functor f-stx kind n m)
(define e
(lambda (stx n m . l)
;(add-sym (syntax->datum f-stx))
#`(#,f-stx #,@(map (lambda (a) #`(quasiquote #,(arg stx a)))
l))))
(call-with-values (lambda () (syntax-local-binding f-stx))
(lambda (type val)
(case type
((global)
(let* ((sym (car val))
(mod (cdr val)))
(if (module-defined? (resolve-module mod) sym)
(let* ((f2 (module-ref (resolve-module mod) sym))
(f (object-property f2 'goal-transformer)))
(if f
f
e))
e)))
(else e)))))
(define (->string x)
(if (symbol? x)
(symbol->string x)
x))
(define op-map '())
(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)
(let ((op (if (symbol? op)
(symbol->string op)
op)))
(let lp ((ops op-map))
(match ops
((((_ . (? (lambda (x) (equal? x op)))) . f)
. _)
f)
((_ . l)
(lp l))
(_ #f)))))
(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)
(let ((op (->string op)))
(if (equal? type op)
(if (= n 1)
(let lp ((ops op-map))
(match ops
(((((or 'fx 'xf 'fy 'yf) . (? (lambda (x) (equal? x op)))) . f)
. _)
f)
((_ . l)
(lp l))
(_ (warn
(format #f "Could not find unary op ~a at ~a" op
(get-refstr N M)))
op)))
(let lp ((ops op-map))
(match ops
(((((or 'xfx 'xfy 'yfx 'yfy) .
(? (lambda (x) (equal? x op)))) . f)
. _)
f)
((_ . l)
(lp l))
(_ (warn
(format #f "Could not find unary op ~a at ~a" op
(get-refstr N M)))
op))))
(let ((f (assoc (cons type (->string op)) op-map)))
(if f
(cdr f)
(begin
(lambda (stx n m . l)
#`(apply #,(datum->syntax stx (string->symbol op))
'#,(map (lambda (x) (arg stx x)) l)))
op))))))
(define (mk-scheme stx s l scm?)
(let* ((sym (eval-string (string-append "'" l) #:lang 'scheme))
(w (datum->syntax stx sym)))
......@@ -192,21 +57,19 @@
((s scm)
(if scm? w (error "scm[] not allowed as a goal"))))))
(define (goal stx x)
(goal- stx x))
(define (goal- stx z)
(define (goal stx z)
(define (garg stx x) #``#,(arg stx x))
(match (pp 'goal z)
(()
#'<cc>)
(((kind _ op _) x y n m)
((op->fkn kind op 2 n m) stx n m x y))
(f-stxfkn #f op #f garg #t stx 2 n m (list x y)))
(((kind _ op _) x n m)
((op->fkn kind op 1 n m) stx n m x))
(f-stxfkn #f op #f garg #t stx 1 n m (list x)))
((#:group x)
(goal- stx x))
(goal stx x))
((#:list (or (#:variable x _ _ _)
(#:atom x _ _ _ _)
......@@ -218,23 +81,21 @@
((#:atom 'true . _) #'<cc>)
((#:atom 'fail . _) #'<fail>)
((#:atom '! . _) #'<cut>)
((#:atom v _ _ n m)
(goal- stx `(#:term ,z () #f ,n ,m)))
(goal stx `(#:term ,z () #f ,n ,m)))
((#:symbolic '! . _) #'<cut>)
((#:variable '_ n m)
(warn (format #f "compilation-error ~a '_' cannot be a goal"
(get-refstr n m))))
((#:term (#:atom v . _) () #f n m)
(let ((v-stx (datum->syntax stx v)))
((term-functor v-stx 'goal n m) stx n m)))
((#:term (and atom (#:atom f . _)) () #f n m)
(f->stxfkn #f f atom garg #t atx #f n m '()))
((#:term (#:atom v . _) l #f n m)
(let ((l (get.. "," l))
(v-stx (datum->syntax stx v)))
(apply (term-functor v-stx 'goal n m) stx n m l)))
((#:term (and atom (#:atom f amp _ _ _)) l #f n m)
(let ((l (get.. "," l)))
(f->stxfkn #f f atom garg #t stx #f n m l)))
((#:termvar v id l . _)
#`(goal-eval `#,(arg stx z)))
......@@ -242,19 +103,20 @@
((#:variable x id . _)
#`(goal-eval #,(datum->syntax stx x)))
((x) (goal- stx x))))
((x) (goal stx x))))
;;We do not, use eval-scm to eval objects in scm contexts
(define (scm stx x)
(define (sarg stx x) #``#,(arg stx x))
(match (pp 'scm x)
(((kind _ "-" _) (#:number x . _) n m)
(- x))
(((kind _ op _) x y n m)
((op->fkn kind op 2 n m) stx n m x y))
(f-stxfkn #f op #f garg #f stx 2 n m (list x y)))
(((kind _ op _) x n m)
((op->fkn kind op 1 n m) stx n m x))
(f-stxfkn #f op #f garg #f stx 1 n m (list x)))
((#:group x)
(scm x stx))
......@@ -267,13 +129,9 @@
((#:number x . _) x)
((#:symbolic x . _)
#`(quote #,(datum->syntax stx x)))
((#:atom x . _)
#`(quote #,(datum->syntax stx x)))
((and atom (#:atom f . _))
(f->stxfkn #f atom f atom sarg #f stx #f n m '()))
((#:term (#:atom v . _) l #f n m)
(let ((l (get.. "," l))
(v-stx (datum->syntax stx v)))
(apply (term-functor v-stx 'scm n m) stx n m l)))))
((#:term (and atom (#:atom f . _)) l #f n m)
(let ((l (get.. "," l)))
(f->stxfkn #f atom f atom sarg #f stx #f n m l)))))
......@@ -89,7 +89,7 @@
(define atom-tok (mk-token (f-seq first-atom (f* rest-var))))
(define any (f-reg "."))
(define special (f-reg "[].[(),;\"'{}|]"))
(define special (f-reg "[].[(),;\"'{}|@]"))
;; SWI-PROLOG OPERATOR PRECEDENCE PARSER
(define expr* #f)
......@@ -402,7 +402,7 @@
(if u
`(#:atom
,(string->symbol c1) ,(car u) ,(cadr u) ,n ,m)
`(#:symbolic ,(string->symbol c1) ,n ,m))))))
`(#:atom ,(string->symbol c1) #f #f ,n ,m))))))
(<and>
(.. (q) (ws c1))
(.. (u) (@tag q))
......@@ -410,7 +410,7 @@
(if u
`(#:atom
,(string->symbol c1) ,(car u) ,(cadr u) ,n ,m)
`(#:symbolic ,(string->symbol c1) ,n ,m)))))))))
`(#:atom ,(string->symbol c1) #f #f ,n ,m)))))))))
(define symbolic-tok2
(<p-lambda> (c)
......@@ -423,7 +423,7 @@
(if u
`(#:atom
,(string->symbol c1) ,(car u) ,(cadr u) ,n ,m)
`(#:symbolic ,(string->symbol c1) ,n ,m))))))
`(#:atom ,(string->symbol c1) #f #f ,n ,m))))))
(define op-tok
(<p-lambda> (c)
......@@ -431,7 +431,7 @@
(<let> ((n N) (m M))
(.. (c) (opsym c))
(.. (q) (ws c))
(<p-cc> `(#:symbolic ,(string->symbol c) ,n ,m)))))
(<p-cc> `(#:atom ,(string->symbol c) #f #f ,n ,m)))))
(define atom
(p-freeze 'atom
......
(define-module (logic guile-log prolog pre)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log prolog operators)
#:export (get.. get-c pp get-binding get-refstr *prolog-file*
attach-defined-module! get-attached-module
*closure-creations*))
(define pp
......@@ -39,76 +39,11 @@
(x (list (f x)))))
(define (get-binding mod local? x stx opify)
(define (wrap x)
(if mod
(if local?
`(@@ ,mod ,x)
`(@ ,mod ,x))
x))
(match x
((#:atom f #f #f n m)
(datum->syntax stx (wrap (opify f))))
((#: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)
((#: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)
#`(#,(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))
(define mod (procedure-property f 'module))
(if (and (not not-pretty?)
(symbol? (procedure-name f))
(if mod
(eq? (resolve-module mod) (current-module))
(module-defined?
(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)))
'())))))
(define *closure-creations* (make-fluid (make-hash-table)))
\ No newline at end of file
(define *closure-creations* (make-fluid (make-hash-table)))
......@@ -2,6 +2,7 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (logic guile-log prolog pre)
#:use-module (logic guile-log prolog operators)
#:export (clear-syms add-sym rem-sym get-syms rem-syms))
(define (get... x)
......@@ -14,7 +15,7 @@
(define (clear-syms)
(fluid-set! syms vlist-null))
(define (add-sym mod local? sym)
(when (not mod)
(when (and (not mod) (get-op-fkn (match sym ((#:atom f . _) f) (_ #f))))
(match sym
((#:atom f #f #f n m)
(fluid-set! syms (vhash-consq f #t (fluid-ref syms))))
......
This diff is collapsed.
......@@ -2260,7 +2260,7 @@ int _gp_unify_raw(SCM **spp, int nargs, SCM *cl, SCM *max)
gp_debus0("/gp-unify!>\n");
if(ret)
{
if(vlist_p(l[0]) && oldi != l[2])
if(vlist_p(l[0]) && (oldi != l[2] || old != l[0]))
l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
PACK_ALL(ci, old, l[0], ggp,s);
......
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