restored the balance

parent 7ff51c3a
......@@ -22,10 +22,10 @@ PSSOURCES = \
logic/guile-log/vlist.scm \
logic/guile-log/indexer.scm \
logic/guile-log/umatch.scm \
logic/guile-log/repr.scm \
logic/guile-log/match.scm \
logic/guile-log/attributed.scm \
logic/guile-log/macros.scm \
logic/guile-log/repr.scm \
logic/guile-log/match.scm \
logic/guile-log/undovar.scm \
logic/guile-log/interleave.scm \
logic/guile-log/run.scm \
......@@ -135,8 +135,8 @@ PSSOURCES = \
language/prolog/modules/library/forward_chaining.pl \
language/prolog/modules/ex/att.pl \
language/prolog/modules/examples/cluster.pl \
language/prolog/modules/library/clpb.pl \
language/prolog/modules/library/clpfd.pl
language/prolog/modules/library/clpb.pl
# language/prolog/modules/library/clpfd.pl
# language/prolog/modules/library/apply_macros.pl
AM_MAKEINFOFLAGS=--force
......
......@@ -204,7 +204,7 @@ mkdyn([[X|L]],(make_dynamic(X),U)) :- mkdyn(L,U).
all((X : Y) :- Z) :- !,fail.
all((H :- X)) :- !,
assertzf(H :- call(X)),
assertz(H :- call(X)),
fail.
all((:- Head)) :- !,
......@@ -222,7 +222,7 @@ all(Head) :-
(
Head =.. [F|L] ->
(
assertzf(Head)
assertz(Head)
) ;
atom(Head) -> assertz(Head)
),
......
......@@ -13,7 +13,6 @@ exception(X,Y,Tag) :- fail.
(<define> ($exe x atfail)
(<pp> x)
(<or>
(<and>
(<match> (#:mode -) (x)
......
......@@ -738,7 +738,10 @@ add/run * vlist *
(vector (make-bitmap-tag) (make-dynlist) #f #f))
(define (make) (cons (make-1) (make-1)))
(define (p x) (if (procedure? x) (x) x))
(define (p x) (if (and (procedure? x)
(eq? (car (procedure-minimum-arity x)) 0))
(x)
x))
(let ((env (if raw? (make) (make-fluid (make)))))
(define (env-ref) (fluid-ref env))
......@@ -749,11 +752,13 @@ add/run * vlist *
(d (get-dyn e))
(ar (get-ar e))
(l (get-li e))
(data (vector t a f c)))
(vector (next-bitmap-tag t)
(dynlist-add d data)
(my-list-add ar data)
(if l (bitmap-indexer-add s (p a) (p t) l) l))))
(data (if l
(vector t (p a) (p f) (p c))
(vector t a f c))))
(vector (next-bitmap-tag t)
(dynlist-add d data)
(my-list-add ar data)
(if l (bitmap-indexer-add s (p a) t l) l))))
(define (xxx-vlist vlist-truncate! x)
(if (vlist? x)
......@@ -870,14 +875,21 @@ add/run * vlist *
(a2 (if rm? (cdr e) (rm-raw s f (cdr e) one?))))
(cons a1 a2)))
(define (expose a)
(vector-set! a 1 (p (vector-ref a 1)))
(vector-set! a 2 (p (vector-ref a 2)))
(vector-set! a 3 (p (vector-ref a 3))))
(define (compile-raw e)
(let* ((l (get-dyn e))
(m (fold-dynlist-lr (lambda (x seed) (max seed (get-t x)))
(m (fold-dynlist-lr (lambda (x seed)
(expose x)
(max seed (get-t x)))
l 0))
(a (make-vector (+ 1 (first-set-bit m)))))
(fold-dynlist-lr (lambda (x seed)
(expose x)
(let ((t (get-t x)))
(vector-set! a (first-set-bit t) x)))
l 0)
......@@ -1142,7 +1154,7 @@ add/run * vlist *
(let ((fr (gp-newframe s)))
((dynamic-walk-lr f)
s p (gp-cp head s)
(lambda (p a vec)
(lambda (p cut a vec last?)
(let ((p (lambda () (gp-unwind fr) (p))))
((<lambda> ()
(<let> ((c (<cp> (get-c vec))))
......@@ -1280,16 +1292,18 @@ add/run * vlist *
(syntax-rules ()
((_ pat code)
(list (lambda () (mk-varpat pat))
(lambda (a b c cut x)
((<<lambda>> (pat (<with-cut> cut code)))
a b c x))
(lambda () 'true)))
(lambda ()
(lambda (a b c cut x)
((<<lambda>> (pat (<with-cut> cut code)))
a b c x)))
(lambda () "true")))
((_ pat code y)
(list (lambda () (mk-varpat pat))
(lambda (a b c cut x)
((<<lambda>> (pat (<with-cut> cut code)))
a b c x))
(lambda ()
(lambda (a b c cut x)
((<<lambda>> (pat (<with-cut> cut code)))
a b c x)))
(lambda () y)))
((_ pat)
......@@ -1312,24 +1326,26 @@ add/run * vlist *
(with-syntax (((pat2 ...) (pp (parse-pat-extended #'(pat ...)))))
(pp #`(list (lambda ()
#,(pp (mk-varpat-extended #'(pat ...))))
(lambda (a b c cut x)
(apply (<<lambda>> (pat2 ... (<with-cut> cut code)))
a b c x))
(lambda ()
(lambda (a b c cut x)
(apply (<<lambda>> (pat2 ... (<with-cut> cut code)))
a b c x)))
(lambda () 'true)))))
((_ (pat ...) code y)
(with-syntax (((pat2 ...) (pp (parse-pat-extended #'(pat ...)))))
(pp #`(list (begin
#,(mk-varpat-extended #'(pat ...)))
(lambda (a b c cut x)
(apply (<<lambda>> (pat2 ... (<with-cut> cut code)))
a b c x))
(lambda ()
(lambda (a b c cut x)
(apply (<<lambda>> (pat2 ... (<with-cut> cut code)))
a b c x)))
(lambda () y)))))
;; TODO this part needs hooks for attributed variables added
((_ (pat ...))
(with-syntax (((pat2 ...) (pp (parse-pat-extended #'(pat ...)))))
(pp #`(<lambda-dyn> (pat2 ...) <cc>)))))))
(pp #`(<lambda-dyn-extended> (pat2 ...) <cc>)))))))
(define (make-dyn mod name)
(define g #f)
......
......@@ -504,7 +504,7 @@ h([],true).
solve(V,N,X) :-
set_once,
(expand_term_0((?- X),Y) -> (h(Y,YY),YY) ; X),
project_the_attributes(V),
once(project_the_attributes(V)),
if_once(output_and_more(V,N,#f),output_and_more(V,N,#t)).
.
")
......
......@@ -234,6 +234,8 @@
;SWI Stuff
set set_x #;gcd
$member $append pp_dyn
dyntrace untr
))
......@@ -286,3 +288,73 @@ sort(X,L) :- msort(X,LL),unique(LL,L).
(load-prolog s (gp-lookup x s))
(cc s p))))
load)))))
(define original (make-hash-table))
(define-syntax-rule (aif (r) p a b) (let ((r p)) (if r a b)))
(define i 0)
(<define> (wr)
(<recur> lp ((i i) (n 0))
(if (> i 20)
(lp (- i 20) (+ n 20))
(<and>
(write n)
(<recur> lp ((i i))
(if (> i 0)
(<and>
(write ".")
(lp (- i 1)))
<cc>))))))
(<define*> (dyntrace f #:optional (simple? #f))
(<code>
(aif (r) (hashq-ref original f #f)
#t
(let* ((n (procedure-name f))
(mod (resolve-module (procedure-property f 'module)))
(v (lambda (x) (if simple? n (vector (cons f x)))))
(new (<lambda> x
(<dyn>
(<with-log-in-code>
(<code> (set! i (+ i 1)))
(wr)
(write `(enter + ,(v x)))
(nl))
(<with-log-in-code>
(wr)
(write `(enter - ,(v x)))
(nl)
(<code> (set! i (- i 1)))))
(<code> (set! i (+ i 1)))
(wr)
(write `(enter + ,(v x))) (nl)
(<apply> f x)
(<dyn>
(<with-log-in-code>
(wr)
(write `(leave + ,(v x)))
(nl)
(<code> (set! i (- i 1))))
(<with-log-in-code>
(<code> (set! i (+ i 1)))
(wr)
(write `(leave - ,(v x)))
(nl)))
(wr)
(write `(leave + ,(v x)))
(<code> (set! i (- i 1)))
(nl))))
(hashq-set! original new f)
(module-set! mod n new)
(set-procedure-properties! new (procedure-properties f))
(set-object-properties! new (object-properties f))))))
(<define> (untr f)
(<code>
(aif (r) (hashq-ref original f #f)
(let ((n (procedure-name f))
(mod (resolve-module (procedure-property f 'module))))
(module-set! mod n r)
(hashq-set! original f #f))
#t)))
......@@ -15,9 +15,10 @@
functorize adaptable_vars
<with-guile-log> <if-some>
<cc> <fail> <let> <let*> <var> <modvar> <hvar> </.> <when>
<define> <cut> <pp> <pp-dyn> <dyn> <unify>
<define> <define*> <cut> <pp> <pp-dyn> <dyn> <unify>
<recur> <letrec>
<lambda> <case-lambda> <with-fail> <with-cut> <with-s>
<lambda*>
<with-cc>
<<lambda>> <<case-lambda>> <<match>>
<match> <=> <r=> <==> *r* <funcall> <apply>
......@@ -41,6 +42,8 @@
<put-attr!> <put-attr-guarded!> <put-attr-weak-guarded!>
<get-attr> <del-attr> <del-attr!> <get-attrs>
<raw-attvar> <attvar-raw?> <set> <set!>
<with-log-in-code>
dls-match
))
(define (<wrap> f . l)
......@@ -701,6 +704,17 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(set-procedure-property! name 'module get-module)
name)))))
(define-syntax <define*>
(syntax-rules ()
((_ (name . a) code ...)
(define name
(letrec ((name (lambda* (<S> <Cut> <CC> . a)
(gp-gc)
(<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...)))))
(set-procedure-property! name 'module get-module)
name)))))
(define delayers (@@ (logic guile-log code-load) *delayers*))
(define (get-del l old)
......@@ -772,6 +786,14 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...))))))
(define-syntax <lambda*>
(syntax-rules ()
((_ as code ...)
(lambda* (<S> <Cut> <CC> . as)
(gp-gc)
(<with-guile-log> (<S> <Cut> <CC>)
(<and> code ...))))))
(define-syntax <case-lambda>
(syntax-rules ()
((_ (as code ...) ...)
......@@ -1397,3 +1419,9 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<==> val var)))))
(variable-set! (@@ (logic guile-log code-load) attributeU) attributeU)
(define-syntax-rule (<with-log-in-code> code ...)
(let ((p (lambda () #f))
(cc (lambda x #t))
(s (fluid-ref *current-stack*)))
(parse<> (p s p cc) (<and> code ...))))
(define-module (logic guile-log match)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log repr)
#:export (compile-match mockalambda))
(define compile-prolog #f)
(define (pp x) (pretty-print x) x)
(define-syntax-rule (aif (it) p a b) (let ((it p)) (if it a b)))
(define taglist (reverse (gp-get-taglist)))
......@@ -270,6 +273,16 @@
(begin (lam (car l)) (lp (- i 1) (cdr l)))
(if #f #f))))
(define delayers (@@ (logic guile-log code-load) *delayers*))
(define-syntax-rule (wrap (cut s p cc) x comp code)
(let ((old (fluid-ref delayers))
(s (gp-match x comp s)))
(if s
(dls-match (cut s p cc) old code)
(p))))
(define (mockalambda_ source? s pat code)
(define (get-extvars table)
(define temp '())
......@@ -303,93 +316,86 @@
#`(let ((o #,oth))
(list
(car o)
#,(case (length fvars)
(lambda ()
#,(case (length fvars)
((0)
#`(lambda (s p cc cut x)
(let ((s (gp-match x #,(rep comp) s)))
(if s
(#,lam s p cc cut)
(p)))))
#`(let ((co (pp #,(rep comp))))
(lambda (s p cc cut x)
(wrap (cut s p cc) x co
(#,lam cut)))))
((1)
#`(let ((co #,(rep comp)))
#`(let ((co (pp #,(rep comp))))
(lambda (s p cc cut x)
(let ((s (gp-match x co s)))
(if s
(let* ((f (car external-vars))
(v (fluid-ref f)))
(fluid-set! f #f)
(#,lam s p cc cut v))
(p))))))
(wrap (cut s p cc) x co
(<let*> ((f (car external-vars))
(v (fluid-ref f)))
(<code> (fluid-set! f #f))
(#,lam cut v))))))
((2)
#`(let ((co #,(rep comp)))
#`(let ((co (pp #,(rep comp))))
(lambda (s p cc cut x)
(let ((s (gp-match x co s)))
(if s
(let* ((f1 (car external-vars))
(v1 (fluid-ref f1))
(f2 (cadr external-vars))
(v2 (fluid-ref f2)))
(fluid-set! f1 #f)
(fluid-set! f2 #f)
(#,lam s p cc cut v1 v2))
(p))))))
(wrap (cut s p cc) x co
(<let*> ((f1 (car external-vars))
(v1 (fluid-ref f1))
(f2 (cadr external-vars))
(v2 (fluid-ref f2)))
(<code>
(fluid-set! f1 #f)
(fluid-set! f2 #f))
(#,lam cut v1 v2))))))
(else
#`(let ((co #,(rep comp)))
#`(let ((co (pp #,(rep comp))))
(lambda (s p cc cut x)
(let ((s (gp-match x co s)))
(if s
(let ((vs (mapi (lambda (x) (fluid-ref x))
#,(length fvars) external-vars)))
(for-eachi (lambda (x) (fluid-set! x #f))
#,(length fvars) external-vars)
(apply #,lam s p cc cut vs))
(p)))))))
(wrap (cut s p cc) x co
(<let> ((vs (mapi (lambda (x) (fluid-ref x))
#,(length fvars) external-vars)))
(<code>
(for-eachi (lambda (x) (fluid-set! x #f))
#,(length fvars) external-vars))
(<apply> #,lam cut vs))))))))
(cadr o)))
(list
(car oth)
(lambda ()
(case (length fvars)
((0)
(lambda (s p cc cut x)
(let ((s (gp-match x comp s)))
(if s
(lam s p cc cut)
(p)))))
(let ((co comp))
(lambda (s p cc cut x)
(wrap (cut s p cc) x co
(lam cut)))))
((1)
(lambda (s p cc cut x)
(let ((s (gp-match x comp s)))
(if s
(let* ((f (car fvars))
(let ((co comp))
(lambda (s p cc cut x)
(wrap (cut s p cc) x co
(<let*> ((f (car fvars))
(v (fluid-ref f)))
(fluid-set! f #f)
(lam s p cc cut v))
(p)))))
(<code> (fluid-set! f #f))
(lam cut v))))))
((2)
(lambda (s p cc cut x)
(let ((s (gp-match x comp s)))
(if s
(let* ((f1 (car fvars))
(let ((co comp))
(lambda (s p cc cut x)
(wrap (cut s p cc) x co
(<let*> ((f1 (car fvars))
(v1 (fluid-ref f1))
(f2 (cadr fvars))
(v2 (fluid-ref f2)))
(fluid-set! f1 #f)
(fluid-set! f2 #f)
(lam s p cc cut v1 v2))
(p)))))
(<code> (fluid-set! f1 #f)
(fluid-set! f2 #f))
(lam cut v1 v2))))))
(else
(lambda (s p cc cut x)
(let ((s (gp-match x comp s)))
(if s
(let ((vs (map (lambda (x) (fluid-ref x)) fvars)))
(for-each (lambda (x) (fluid-set! x #f)) fvars)
(apply lam s p cc cut vs))
(p))))))
(let ((co comp))
(lambda (s p cc cut x)
(wrap (cut s p cc) x co
(<let> ((vs (map (lambda (x) (fluid-ref x)) fvars)))
(<code> (for-each (lambda (x) (fluid-set! x #f)) fvars))
(<apply> lam cut vs))))))))
(cadr oth)))))
(define (mockalambda source? s pat code)
......
......@@ -80,16 +80,29 @@
(define (add-fkn x)
(let ((r (hashq-ref fkns x #f)))
(unless r
(hashq-set! fkns x (gensym "FKN")))))
(if (procedure? x)
(let ((n (procedure-name x))
(mod (procedure-property x 'module)))
(if (or #t (not mod))
(hashq-set! fkns x (gensym "FKN"))))
(hashq-set! fkns x (gensym "FKN"))))))
(define (get-fkn x)
(let ((r (hashq-ref fkns x #f)))
(unless r
(error (format #f
"BUG, prolog compile did not find fkn ~a"
x)))
(pp 'get-fkn `(,x ,r))
r))
(if r
r
(let ((n (procedure-name x))
(mod (let ((m (procedure-property x 'module)))
(if m
(if (pair? m)
m
(module-name m))
m))))
(if (and mod n)
`(@@ ,mod ,n)
(error (format #f
"BUG, prolog compile did not find fkn ~a"
x)))))))
(define (get-var x)
(let ((r (hashq-ref ex-house x #f)))
......
......@@ -490,4 +490,4 @@
(_
(type_error predicate_indicator X))))
(set! (@@ (logic guile-log prolog parser) assertz-source+) assertz-source+)
(set! (@@ (logic guile-log prolog parser) assertz-source+) assertz-source)
......@@ -42,8 +42,8 @@
(<define> (abort1 code)
(user-exception-hook code
(<lambda> ()
(if (<lookup> code) (<pp> `(abort ,code)) <cc>)
(<lambda> ()
;(if (<lookup> code) (<pp> `(abort ,code)) <cc>)
(<abort> 'prolog non-reentrant (ecp code S)))))
(define-syntax-rule (define-error (nm a ...) code)
......
......@@ -15,7 +15,7 @@
(let ((y #f))
(aif (r) (hashq-ref map x #f)
(if (eq? r #t)
(let ((r (mkvar #f)))
(let ((r (mkvar)))
(hashq-set! map x r)
#`,#,r)
#`,#,r)
......
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