Some improvements but still a diffficult bug remains

parent 2b013fa5
This diff is collapsed.
......@@ -4,7 +4,7 @@
#:use-module (logic guile-log)
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log guile-prolog coroutine)
#:use-module (logic guile-log guile-prolog coroutine)
#:use-module (logic guile-log guile-prolog gc-call)
#:use-module (language prolog modules boot dcg)
#:pure
......
......@@ -30,8 +30,7 @@
(<define> (put_assoc_x HEntry H0 Node)
(<let> ((HEntry (<scm> HEntry))
(H0 (<lookup> H0)))
(<code> (s! H0 (vhash-cons HEntry (<lookup> Node)
(r H0))))))
(<code> (s! H0 (vhash-set! HEntry (<lookup> Node) (r H0))))))
(<define> (get_assoc HEntry H0 Node)
(<let*> ((HEntry (<scm> HEntry))
......
......@@ -71,7 +71,7 @@ add/run * vlist *
(define (pp . x) (pretty-print (syntax->datum x)) (car (reverse x)))
(define (ppp a x) (pretty-print (list a (syntax->datum x))) x)
(define (make-indexer) (vector #f #f 0 #f 0 #f #f))
(define (make-indexer) (vector #f #f 0 #f 0 vlist-null vlist-null))
(define-inlinable (get-car v)
(vector-ref v 0))
......@@ -199,13 +199,13 @@ add/run * vlist *
(cond
((string? a)
(if r2
(let ((x (vhash-assoc a r2))
(y (vhash-assoc a r3)))
(let ((x (if r2 (vhash-assoc a r2) r2))
(y (if r3 (vhash-assoc a r3) r3)))
(if x
(values r1 r2 r3 (cdr x) (if y (cdr y) (make-empty)))
(values r1 r2 r3 (make-empty) (if y (cdr y) (make-empty)))))
(if r3
(let ((x (vhash-assoc a r3)))
(let ((x (if r3 (vhash-assoc a r3) r3)))
(values r1 vlist-null r3 (make-empty)
(if x (cdr x) (make-empty))))
(values r1 vlist-null vlist-null (make-empty) (make-empty)))))
......@@ -213,13 +213,13 @@ add/run * vlist *
((procedure? a)
(let ((s (symbol->string (procedure-name a))))
(if r1
(let ((x (vhash-assoc a r1))
(y (vhash-assoc s r3)))
(let ((x (if r1 (vhash-assoc a r1) r1))
(y (if r2 (vhash-assoc s r3) r2)))
(if x
(values r1 r2 r3 (cdr x) (if y (cdr y) (make-empty)))
(values r1 r2 r3 (make-empty) (if y (cdr y) (make-empty)))))
(if r3
(let ((x (vhash-assoc s r3)))
(let ((x (if r3 (vhash-assoc s r3) r3)))
(values vlist-null
r2 r3
(make-empty)
......@@ -232,7 +232,7 @@ add/run * vlist *
(else
(if r1
(let ((x (vhash-assoc a r1)))
(let ((x (if r1 (vhash-assoc a r1) r1)))
(if x
(values r1 r2 r3 (cdr x) #f)
(values r1 r2 r3 (make-empty) #f)))
......@@ -247,13 +247,13 @@ add/run * vlist *
(cond
((string? a)
(if r2
(let ((x (vhash-assoc a r2))
(y (vhash-assoc a r3)))
(let ((x (if r2 (vhash-assoc a r2) r2))
(y (if r3 (vhash-assoc a r3) r3)))
(if x
(values r1 r2 r3 (cdr x) (if y (cdr y) (make-empty)))
(values r1 r2 r3 (make-empty) (if y (cdr y) (make-empty)))))
(if r3
(let ((x (vhash-assoc a r3)))
(let ((x (if r3 (vhash-assoc a r3) r3)))
(values r1 vlist-null r3 (make-empty)
(if x (cdr x) (make-empty))))
(values r1 vlist-null vlist-null (make-empty) (make-empty)))))
......@@ -261,13 +261,13 @@ add/run * vlist *
((procedure? a)
(let ((s (symbol->string (procedure-name a))))
(if r1
(let ((x (vhash-assoc a r1))
(y (vhash-assoc s r3)))
(let ((x (if r1 (vhash-assoc a r1) r1))
(y (if r3 (vhash-assoc s r3) r3)))
(if x
(values r1 r2 r3 (cdr x) (if y (cdr y) (make-empty)))
(values r1 r2 r3 (make-empty) (if y (cdr y) (make-empty)))))
(if r3
(let ((x (vhash-assoc s r3)))
(let ((x (if r3 (vhash-assoc s r3) r3)))
(values vlist-null
r2 r3
(make-empty)
......@@ -509,7 +509,7 @@ add/run * vlist *
(define (bitmap-indexer-add! s e f dlink)
(match (bitmap-indexer-add!- s e f dlink)
((_ . a) (pk 'res a))))
((_ . a) a)))
(define (bitmap-indexer-add!- s e f dlink)
(pu e dlink
......@@ -541,7 +541,7 @@ add/run * vlist *
xx)))
(((? not-tag?) x)
(match (pk (dive! dlink not-tag))
(match (dive! dlink not-tag)
((#f . ((? not-tag?) a b (and (set! sv) v)))
(sv (logior v f))
(list not-tag a (bitmap-indexer-add!- s x f b))
......@@ -853,7 +853,7 @@ add/run * vlist *
(define (walk-raw s p cut a F walk-dynlist e rev more?)
(let* ((ar (get-ar e))
(db (get-li e)))
(let lp ((l (pk 'indeces (rev (get-index-set s a db)))))
(let lp ((l (rev (get-index-set s a db))))
(if (not (pair? l))
(p)
(if (null? (cdr l))
......
......@@ -393,6 +393,7 @@ conversation2(X,All) :-
tree,
consult(T,V,N,All).
-trace.
consult(X,V,N,All) :-
do[(fluid-set! -nsol- (<lookup> All))],
catch((solve(V,N,X) ; (nl,write(no),nl,fail)),finish,
......@@ -400,7 +401,7 @@ consult(X,V,N,All) :-
vtosym(X,Y) :- make_vhash(H),make_fluid(0,I),rec_analyze(X),vtosym4(X,Y,H,I).
%vtosym(X,Y,_,_) :- write([1,X,Y]),nl,fail.
%vtosym_(X,Y,_,_) :- write([1,X,Y]),nl,fail.
vtosym_(X,Y,H,I) :-
attvar(X) -> (!,
(vhashq_ref(H,X,Y) -> true ;
......@@ -412,7 +413,6 @@ vtosym_(X,Y,H,I) :-
vtosym4(XX,YY,H,I),
wrap_namespace(X,Y,YY)) ; fail.
vtosym_([X|XL],[U|UL],H,I) :-
!,vtosym4(X,U,H,I), vtosym4(XL,UL,H,I).
......@@ -441,6 +441,7 @@ output_and_more(V,N,More) :-
)
).
%write_out(X,Y) :- write(writeout(X,Y)),nl,fail.
write_out([],[]).
write_out([V|Vs],[N|Ns])
:- nl,write(\" \"),write(N),write(\" = \"),write(V),
......@@ -471,6 +472,7 @@ more :-
empty :- peek_char(X),char_code(X,Code),Code==10->get_char(_);true.
-trace.
solve(V,N,X) :- set_once,X,
if_once(output_and_more(V,N,#f),output_and_more(V,N,#t)).
.
......
......@@ -247,12 +247,11 @@ sort(X,L) :- msort(X,LL),unique(LL,L).
(<define> (pp_dyn x y) (<pp-dyn> x y))
(define-guile-log load
(lambda (x)
(pk (syntax->datum x))
(syntax-case x ()
((load w x)
#'(parse<> w (<code> (load-prolog (<lookup> x)))))
#'(parse<> w (<code> (load-prolog S (<lookup> x)))))
(load
#'(let ((load (lambda (s p cc x)
(load-prolog (gp-lookup x s))
(load-prolog s (gp-lookup x s))
(cc s p))))
load)))))
......@@ -102,7 +102,7 @@
(<define> (trace-fkn b f lev . l)
(if (<= lev trace-level )
(<and>
;(<pp-dyn> `(,b enter ,f) `(,b leave ,f))
(<pp-dyn> `(,b enter ,f) `(,b leave ,f))
((@ (logic guile-log iso-prolog) write) (list b 'trace f #;l))
((@ (logic guile-log iso-prolog) nl)))
<cc>))
......@@ -215,7 +215,7 @@
(map (lambda (x) (pat-match stx x)) l)
'()))))
(define (ass x ext)
(define (assert-source x ext)
(let ((res (assertz-source
(fluid-ref *current-stack*)
(lambda () (error "failed to compile assertz"))
......@@ -247,8 +247,11 @@
(_
(error x))))))
ext)))
(pp #`((<lambda> () #,res)
(fluid-ref *current-stack*) (lambda () #f) (lambda x #t)))))
(pp #`(let* ((fr1 (gp-newframe (fluid-ref *current-stack*)))
(fr2 (gp-newframe fr1)))
(with-fluids ((*current-stack* fr2))
((<lambda> () #,res) fr2 (lambda () #f) (lambda x #t))
(gp-unwind fr1))))))
(define (top x i)
(match (pp 'top x)
......@@ -290,7 +293,7 @@
(if (is-dynamic? v)
(let ((f functors))
(set! functors '())
`(,i #:translated 1 ,(ass x (ext f))))
`(,i #:translated 1 ,(assert-source x (ext f))))
(let ((fu (pp v functors)))
(set! functors '())
(match y
......@@ -339,7 +342,7 @@
(if (is-dynamic? v)
(let ((f functors))
(set! functors '())
`(,i #:translated 1 ,(ass x (ext f))))
`(,i #:translated 1 ,(assert-source x (ext f))))
(let ((fu (pp v functors)))
(set! functors '())
(list i v '() z fu))))
......@@ -371,8 +374,7 @@
(list
i
#:init
#`(prolog-run-*
#,(mk-rhs stx x)))))
#`(prolog-run-* #,(mk-rhs stx x)))))
((#:translated n (#:init x))
(list
......@@ -380,8 +382,7 @@
#:translated n
(list
#:init
#`(prolog-run-*
#,(mk-rhs stx x)))))
#`(prolog-run-* #,(mk-rhs stx x)))))
((#:translated n (#:include fn x))
(set! functors '())
......@@ -395,7 +396,7 @@
((and sym (#:atom v _ _ n m))
(add-sym #f #f sym)
(if (is-dynamic? v)
`(,i #:translated 1 ,(ass x #f))
`(,i #:translated 1 ,(assert-source x #f))
(list i v '() '() '())))
(((_ _ ":" _) (#:atom mod . _) (#:term (#:atom v _ _ na ma) y . l)
......@@ -426,7 +427,7 @@
((#:term (and sym (#:atom v . _)) y _ n m)
(add-sym #f #f sym)
(if (is-dynamic? v)
`(,i #:translated 1 ,(ass x #f))
`(,i #:translated 1 ,(assert-source x #f))
(let ((fu functors))
(set! functors '())
(list i v (get.. "," y) '() fu))))
......
......@@ -515,13 +515,13 @@
(define lam
(with-fluids ((*current-language* (lookup-language 'scheme)))
(set! src
(if extention?
(ppp 'comp `(,(G lambda) (,@vfkn ,@vars ,@ovars)
(if (pair? extention?)
(pp 'comp `(,(G lambda) (,@vfkn ,@vars ,@ovars)
((@@ (logic guile-log functional-database)
<lambda-dyn-extended>) ,aa
(,(GL <var>) ,vars ,ff)
,(list (G cons) `,aaa `,fff))))
(ppp 'comp `(,(G lambda) (,@vfkn ,@vars ,@ovars)
(pp 'comp `(,(G lambda) (,@vfkn ,@vars ,@ovars)
((@@ (logic guile-log functional-database)
<lambda-dyn>) ,aa
(,(GL <var>) ,vars ,ff)
......
......@@ -63,6 +63,9 @@
)
#:re-export(sin cos atan exp log sqrt))
(define (transfer-o-p from to)
(set-object-properties! to (object-properties from)))
(define do-print #f)
(define pp
(case-lambda
......@@ -297,7 +300,7 @@
(begin
(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)
(set-procedure-property! fk-name 'name 'fk-name)
(bind-operator-to-functor fk-name op)))
(mk-prolog-abstract 'fy ":-" op1:- tr-directive)
......@@ -369,10 +372,10 @@
#`(<iss> #,(-arg- stx x) #,(scm stx y))))))
(define (my-rem x y) (- x (* (quotient x y) y)))
(define-syntax-rule (shr x y) (ash x (- y)))
(mk-scheme-biop 'yfx "+" tr-+ op2+ .+ s s)
(mk-scheme-biop 'yfx "-" tr-- op2- .- s s)
(mk-scheme-unop 'fy "-" tr-u- op1- .-1 s )
(mk-scheme-unop 'fy "+" tr-u+ op1+ .+1 s )
(mk-scheme-biop 'yfx "+" tr-+ oop2+ .+ s s)
(mk-scheme-biop 'yfx "-" tr-- oop2- .- s s)
(mk-scheme-unop 'fy "-" tr-u- oop1- .-1 s )
(mk-scheme-unop 'fy "+" tr-u+ oop1+ .+1 s )
(mk-scheme-unop 'fy "\\" tr-bitnot #{\\}# lognot s )
(mk-scheme-biop 'yfx "*" tr-* op2* .* s s)
(mk-scheme-biop 'yfx "/" tr-/ op2/ ./ s s)
......@@ -387,6 +390,28 @@
(mk-scheme-biop 'yfx "/\\" tr-bitand #{/\\}# logand s s)
(mk-scheme-biop 'yfx "\\/" tr-bitor #{\\/}# .logior s s)
(define (name-as f g) (set-procedure-property! f 'name (procedure-name g)))
(define o-
(case-lambda
((s x y) (oop2- s x y))
((s x) (oop1- s x))))
(transfer-o-p oop2- o-)
(set-procedure-property! o- 'name 'op2-)
(define op1- o-)
(define op2- o-)
(define o+
(case-lambda
((s x y) (oop2+ s x y))
((s x) (oop1+ s x))))
(transfer-o-p oop2+ o+)
(set-procedure-property! o+ 'name 'op2+)
(define op1+ o+)
(define op2+ o+)
(mk-prolog-biop-when 'xfx "<" tr-< op2< .< s s)
(mk-prolog-biop-when 'xfx ">" tr-> op2> .> s s)
(mk-prolog-biop-when 'xfx ">=" tr->= op2>= my->= s s)
......@@ -394,10 +419,10 @@
(mk-prolog-biop-when 'xfx "=:=" tr-equal =:= my-equal? s s)
(mk-prolog-biop-when-not 'xfx "=\\=" tr-not-equal #{=\\=}# my-equal? s s)
(mk-scheme-biop 'yfx "+" tr-+g gop2+ + s s)
(mk-scheme-biop 'yfx "-" tr--g gop2- - s s)
(mk-scheme-unop 'fy "-" tr-u-g gop1- -1 s )
(mk-scheme-unop 'fy "-" tr-u-g gop1+ +1 s )
(mk-scheme-biop 'yfx "+" tr-+g ggop2+ + s s)
(mk-scheme-biop 'yfx "-" tr--g ggop2- - s s)
(mk-scheme-unop 'fy "-" tr-u-g ggop1- -1 s )
(mk-scheme-unop 'fy "-" tr-u-g ggop1+ +1 s )
(mk-scheme-unop 'fy "\\" tr-bitnotg #{g\\}# lognot s )
(mk-scheme-biop 'yfx "*" tr-*g gop2* * s s)
(mk-scheme-biop 'yfx "/" tr-/g gop2/ / s s)
......@@ -409,6 +434,25 @@
(mk-scheme-biop 'yfx "/\\" tr-bitandg #{g/\\}# logand s s)
(mk-scheme-biop 'yfx "\\/" tr-bitorg #{g\\/}# logior s s)
(define go-
(case-lambda
((s x y) (ggop2- s x y))
((s x) (ggop1- s x))))
(name-as go- op2-)
(transfer-o-p ggop2- go-)
(set! gop1- go-)
(set! gop2- go-)
(define go+
(case-lambda
((s x y) (ggop2+ s x y))
((s x) (ggop1+ s x))))
(name-as go+ op2+)
(transfer-o-p ggop2+ go+)
(set! gop1+ go+)
(set! gop2+ go+)
(mk-prolog-biop-when 'xfx "<" tr-<g gop2< < s s)
(mk-prolog-biop-when 'xfx ">" tr->g gop2> > s s)
(mk-prolog-biop-when 'xfx ">=" tr->=g gop2>= >= s s)
......@@ -426,14 +470,24 @@
(define (.> x y)
(check-num (> (is-a-num? x) (is-a-num? y))))
(define (.+ x y)
(check-num (+ (is-a-num? x) (is-a-num? y))))
(define (.- x y)
(check-num (- (is-a-num? x) (is-a-num? y))))
(define (.-1 x)
(check-num (- (is-a-num? x))))
(define (.+1 x)
(check-num (+ (is-a-num? x))))
(define .+
(case-lambda
((x y)
(check-num (+ (is-a-num? x) (is-a-num? y))))
((x)
(check-num (+ (is-a-num? x))))))
(define .-
(case-lambda
((x y)
(check-num (- (is-a-num? x) (is-a-num? y))))
((x)
(check-num (- (is-a-num? x))))))
(define .-1 .-)
(define .+1 .+)
(define (.* x y)
(check-num (* (is-a-num? x) (is-a-num? y))))
(define (./ x y)
......@@ -964,7 +1018,7 @@ floor(x) (floor x)
(<ret> `(halt ,x))))))
s p cc x))))
(define (name-as f g) (set-procedure-property! f 'name (procedure-name g)))
(name-as gop2- op2-)
(name-as gop2+ op2+)
(name-as gop2- op2-)
......
......@@ -156,12 +156,16 @@ when none is available, reading FILE-NAME with READER."
(define-syntax load-q
(make-variable-transformer
(lambda (x)
(let* ((src (syntax-source x))
(let* ((src (syntax-source x))
(file (and src (assq-ref src 'filename)))
(dir (and (string? file) (dirname file))))
(dir (and (string? file) (dirname file))))
(syntax-case x ()
((_ arg ...)
#`(load-in-vicinity-q #,(or dir #'(getcwd)) arg ...))
((_ s arg ...)
#`(let* ((fr1 (gp-newframe s))
(fr2 (gp-newframe fr1)))
(with-fluids ((*current-stack* fr2))
(load-in-vicinity-q #,(or dir #'(getcwd)) arg ...))
(gp-unwind fr1)))
(id
(identifier? #'id)
#`(lambda args
......@@ -175,33 +179,34 @@ when none is available, reading FILE-NAME with READER."
module-interface-args)))
(module-use-interfaces! (current-module) interfaces))))
(define-syntax-rule (load-prolog str)
(define-syntax-rule (load-prolog s str)
(begin
#;(with-fluids ((*current-language* (lookup-language 'scheme)))
(load (load-prolog_ str)))
(load-q (load-prolog_ str))))
(load-q s (load-prolog_ s str))))
(define (load-prolog_ str)
(define (load-prolog_ s str)
(let* ((str str)
(pl (string-append str ".pl"))
(scm (string-append str ".pl.scm")))
(define (action)
(let ((r (pk 'mod? (is-module-file? pl))))
(if r
(write-module-scratch r pl)
(with-output-to-file scm
(lambda ()
(format #t "(compile-prolog-file ~s)~%" pl))))))
(catch #t
(lambda ()
(let* ((mpl (stat:mtime (stat pl)))
(mscm (stat:mtime (stat scm))))
(when (< (+ mscm 10) mpl)
(action))))
(lambda x (action)))
(define (action)
(let ((r (pk 'mod? (is-module-file? pl))))
(if r
(write-module-scratch r pl)
(with-output-to-file scm
(lambda ()
(format #t "(compile-prolog-file ~s)~%" pl))))))
(catch #t
(lambda ()
(let* ((mpl (stat:mtime (stat pl)))
(mscm (stat:mtime (stat scm))))
(when (< (+ mscm 10) mpl)
(action))))
(lambda x (action)))
;(pk `(compiling and/or load of ,str))
scm))
scm))
(define ensure_loaded #f)
......@@ -519,10 +519,9 @@
(<p-lambda> (c)
(.. (c2) (expr c))
(when (match c2
((_ _ "," _) #f)
((_ _ _ _) #t)
(_ #f))
(<cc> c2)))
(((_ _ "," _) . _) #f)
(_ #t))
(<p-cc> c2)))
mk-id))
(define paranthesis
......@@ -551,7 +550,7 @@
(xx (c1) (<or> (.. (atom c0))
(.. (qstring c0))
(.. ((f-and
(f-not* (f-seq funop ws l isNonFkn))
#;(f-not (f-seq funop ws l ws isNonFkn))
symbolic-tok)
c0))))
(.. (c2) (l c1))
......
......@@ -46,25 +46,28 @@
(<ret> (<scm> l))))))))
(define-syntax-rule (prolog-run-* code ...)
(let ((fr ((@ (logic guile-log umatch) gp-newframe)
(fluid-ref (@ (logic guile-log umatch) *current-stack*)))))
(with-fluids ((*current-stack* fr))
(let* ((fr1 ((@ (logic guile-log umatch) gp-newframe)
(fluid-ref (@ (logic guile-log umatch) *current-stack*))))
(fr2 ((@ (logic guile-log umatch) gp-newframe)
fr1)))
(with-fluids ((*current-stack* fr2))
(scheme-wrapper
(lambda ()
(<run> 1 ()
(<catch> 'prolog #f
(<run> 1 ()
(<catch> 'prolog #f
(<lambda> () code ...)
(<lambda> (tag next l)
(<format> #t "DYNAMIC ERROR:~%=> ~a~%~%" (var->code (<scm> l)))
(<ret> (<scm> l))))))))
((@ (logic guile-log umatch) gp-unwind) fr)))
((@ (logic guile-log umatch) gp-unwind) fr1)))
(define (prolog-run-0 f . l)
(let ((fr ((@ (logic guile-log umatch) gp-newframe)
(fluid-ref (@ (logic guile-log umatch) *current-stack*)))))
(with-fluids ((*current-stack* fr))
(prolog-run 1 ()
(<apply> f l)
(<code>
((@ (logic guile-log umatch) gp-unwind) fr))))))
(let* ((fr1 ((@ (logic guile-log umatch) gp-newframe)
(fluid-ref (@ (logic guile-log umatch) *current-stack*))))
(fr2 ((@ (logic guile-log umatch) gp-newframe)
fr1)))
(with-fluids ((*current-stack* fr2))
(prolog-run 1 ()
(<apply> f l))
((@ (logic guile-log umatch) gp-unwind) fr1))))
......@@ -97,6 +97,7 @@
(syntax-rules (*)
((_ (v) code ...)
(let ((fr (gp-newframe (fluid-ref *current-stack*))))
(with-fluids ((*current-stack* fr))
(if *kanren-assq*
(gp-logical++))
(let-with-lr-guard fr wind lg rg ((ret '()))
......@@ -108,10 +109,11 @@
(reverse ret))
(lambda (s p)
(set! ret (cons (tr (gp->scm v s) s) ret))
(p)))))))
(p))))))))
((_ (v ...) code ...)
(let ((fr (gp-newframe (fluid-ref *current-stack*))))
(with-fluids ((*current-stack* fr))
(if *kanren-assq*
(gp-logical++))
(let-with-lr-guard fr wind lg rg ((ret '()))
......@@ -125,13 +127,14 @@
(reverse r)))
(lambda (s p)
(set! ret (cons (tr (gp->scm (list v ...) s) s) ret))
(p)))))))
(p))))))))
((_ * . l) (<run> . l))
((_ m (v) code ...)
(let ((fr (gp-newframe (fluid-ref *current-stack*))))
(with-fluids ((*current-stack* fr))
(if *kanren-assq*
(gp-logical++))
(let-with-lr-guard fr wind lg rg ((n m) (ret '()))
......@@ -162,11 +165,12 @@
(set! ret '())
(p))) s)
r)
(p))))))))))
(p)))))))))))
((_ m (v ...) code ...)
(let ((fr (gp-newframe (fluid-ref *current-stack*))))
(with-fluids ((*current-stack* fr))
(if *kanren-assq*
(gp-logical++))
(let-with-lr-guard fr wind lg rg ((n m) (ret '()))
......@@ -199,7 +203,7 @@
(p)))
s)
r)
(p))))))))))))
(p)))))))))))))
(define-syntax <ask*>
(syntax-rules ()
......@@ -210,4 +214,4 @@
(<with-guile-log> (s p cc)
(<and> code ...)))))))
(mk<run> <ask> <ask*>)
\ No newline at end of file
(mk<run> <ask> <ask*>)
......@@ -206,7 +206,7 @@ AUTOMAKE = ${SHELL} /home/stis/src/guile-log/build-aux/missing automake-1.14
AWK = gawk
CC = gcc
CCDEPMODE = depmode=gcc3
CFLAGS = -g -O2
CFLAGS = -g -O2
CPP = gcc -E
CPPFLAGS =
CYGPATH_W = echo
......@@ -224,10 +224,10 @@ FGREP = /bin/grep -F
GREP = /bin/grep
GUILD = /usr/local/bin/guild
GUILE = /usr/local/bin/guile
GUILE_CFLAGS = -pthread -I/usr/local/include/guile/2.2
GUILE_CFLAGS = -pthread -I/usr/include/guile/2.0
GUILE_CONFIG = /usr/local/bin/guile-config
GUILE_EFFECTIVE_VERSION = 2.2
GUILE_LIBS = -lguile-2.2 -lgc
GUILE_LIBS = -lguile-2.0 -lgc
GUILE_TOOLS = /usr/local/bin/guild
INSTALL = /usr/bin/install -c
INSTALL_DATA = ${INSTALL} -m 644
......@@ -321,7 +321,7 @@ target_alias =
top_build_prefix = ../../../
top_builddir = ../../..
top_srcdir = ../../..
extlibdir = $(libdir)/guile/2.2/extensions
extlibdir = $(libdir)/guile/2.0/extensions
extlib_LTLIBRARIES = libguile-log.la
AM_CFLAGS = -I$(srcdir) $(WARN_CFLAGS) $(DEBUG_CFLAGS)
libguile_log_la_SOURCES = unify.c
......
......@@ -286,7 +286,7 @@ typedef int (*predicate_t)(SCM,SCM);
predicate_t predicates[1000];
//#define DB(X) X
// #define DB(X) X
// Fast but horribly hard really, this need to be in C
void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data)
{
......@@ -330,13 +330,13 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data)
if(scm_is_eq(x, predicate_tag_p)) goto predicate_tag;
}
if(SCM_CONSP(e))
if(scm_is_true(gp_pair(e,s)))
{
SCM x = SCM_CAR(e);
SCM l = SCM_CDR(e);
SCM x = gp_car(e,s);
SCM l = gp_gp_cdr(e,s);
SCM v = get_vars(db);
int i;
//printf("CONSP\n");fflush(stdout);
// printf("CONSP\n");fflush(stdout);
// gp_format3("vars: ~a\n e: ~a\n db: ~a~%",v,e,db_);fflush(stdout);
if(SCM_I_INUMP (v))
......@@ -395,7 +395,7 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data)
if(scm_is_true(gp_varp(e,s)))