when starts working

parent d740146f
......@@ -78,6 +78,7 @@ SOURCES = \
logic/guile-log/guile-prolog/interpreter.scm \
logic/guile-log/guile-prolog/state.scm \
logic/guile-log/guile-prolog/postpone.scm \
logic/guile-log/guile-prolog/gc-call.scm \
logic/guile-log/guile-prolog/coroutine.scm \
language/prolog/spec.scm
......
......@@ -46,10 +46,7 @@ frozen(Var,Goal) :-
get_attr(Var, freezeId, Atts) ->
combine_atts(Atts,Goal);
Goal = true.
")
(compile-prolog-string
"
%when(Condition, Goal)
do_all_atts_when(Val,[Id, u(J,G) | L]) :-
......@@ -62,25 +59,28 @@ doVs(X,Vs) :- var(Vs) -> true ; [X]=Vs.
doNs(X,Ns) :- var(Ns) -> true ; ([N]=Ns,nonvar(X) -> N=true).
doGs(X,Gs) :- var(Gs) -> true ; ([G]=Gs,atomic(X) -> G=true).
whenId(Val,Var,#t) :-
raw_attvar(Var, Raw),
do_all_when(_,[]).
do_all_when(R,[[G,M,[K,O],Vs,Ns,Gs]|L]) :- !,
(
doVs(R,Vs),doNs(R,Ns),doGs(R,Gs),
var(O) ->
( (\\+call(M)) -> true ;
(
(K=false -> O=true;true),
call(G)
)
); true
), do_all_when(R,L).
whenId(Val,Var,#t) :-
raw_attvar(Var, Raw) ->
(
Raw = Val,
get_attr(Var,whenId,[G,M,[K,Once],Vs,Ns,Gs]),!,
doVs(Raw,Vs),doNs(Raw,Ns),doGs(Raw,Gs),
var(Once) ->
( (\\+call(M)) -> true ;
(
(K=false -> Once=true;true),
call(G)
)
); true
get_attr(Var,whenId,L),
do_all_when(Raw,L)
);
Raw=Val.
")
(compile-prolog-string
"
process_cond(M,(X,Y),L) :- !,
process_cond(Mx,X,L),
process_cond(My,Y,L),
......@@ -109,8 +109,8 @@ process_cond(M,[X|Y],L) :- !,
M=[Mx|My].
process_cond2(M,X,L) :-
var(X) -> add_var(M,X,L) ;
attvar(X) -> add_var(M,X,L) ;
var(X) -> add_var(M,X,L) ;
attvar(X) -> add_var(M,X,L) ;
X=..[F|U] -> (process_cond2(MM,U,L),M=..[F|MM]) ;
(M=X,L=LL).
......@@ -125,17 +125,15 @@ add_nonvar(nonvar(M),X,L) :-
add_ground(nonvar(M),X,L) :-
vhashq_ref(L,X,[Vs, Ns, Gs]) -> Gs=[M] ;
vhashq_cons(L,X,[Vs, Ns, [M]]).
")
(compile-prolog-string
"
construct_when(O,MG,G,[]).
construct_when(O,MG,G,[[X|Data] | L]) :-
construct_when(O,MG,G,[[X|Data] | L]) :- !,
(
get_attr(X,whenId,L) ->
put_attr(X,whenId,[[G,MG,O | Data] | L]) ;
put_attr(X,whenId,[[G,MG,O | Data]])
),
construct_when(MG,G,L).
construct_when(O,MG,G,L).
when(Cond,Goal) :-
process_when(Cond,MG,Data),
......@@ -143,15 +141,17 @@ when(Cond,Goal) :-
when(Cond,Goal,O) :-
process_when(Cond,MG,Data),
construct_when([true,O],MG,Goal,Data).
construct_when([true,O],MG,Goal,Data)
")
;; This will construct the datastructure and rewind the stack
;; It is a quite efficient process using vhashes and stack rewind.
(<define> (process_when condition MG Data)
(<gc-call> (cons MG Data)
(<lambda> ()
(<var> (L)
(<var> (Save)
(<gc-call> (list MG Data) Save
(<lambda> ()
(<var> (L)
(make_vhash L)
(process_cond MG condition, L)
(vhash_to_assoc L Data)))))
(process_cond MG condition L)
(vhash_to_assoc L Data)
(<=> Save ,(map car (<scm> Data))))))))
......@@ -137,4 +137,4 @@ it's old datastructure.
((not (<vhash?> h))
(type_error vhash h))
(else
(<=> l (vhash->assoc (fluid-ref h)))))))
(<=> l ,(vhash->assoc (fluid-ref h)))))))
......@@ -298,10 +298,10 @@ and-interleave
(parse<> w
(call (</.> code ...) (list x ...) (list l ...))))))
(<define> (<gc-call> X Lam)
(<let> ((pr P))
(<define> (<gc-call> X L Lam)
(<let> ((pr (<newframe>)))
(Lam)
(<let> ((res (<cp> X)))
(<let> ((res (<cp> X L)))
(<code> (<unwind> pr))
(<=> X res))))
......
......@@ -87,7 +87,7 @@
(define-syntax-rule (<lookup> x) (gp-lookup x S))
(define-syntax-rule (<newframe>) (gp-newframe S))
(define-syntax-rule (<unwind> p) (gp-unwind p))
(define-syntax-rule (<cp> x) (gp-cp x S))
(define-syntax-rule (<cp> x ...) (gp-cp x ... S))
(define-syntax-rule (<cons?> x) (gp-pair- (gp-lookup x S) S))
(define-syntax-rule (<var?> x) (gp-var? (gp-lookup x S) S))
(define-syntax-rule (<get-fixed> x y) (gp-get-fixed-free x y S))
......@@ -1100,7 +1100,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<define> (<get-attr> x m v)
(<let*> ((x (<lookup> x))
(ret (gp-get-attr x m S)))
(when ret (<=> v ,(pk 'a ret)))))
(when ret (<=> v ret))))
(<define> (<del-attr> x m) (<with-s> (gp-del-attr x m S) <cc>))
......
......@@ -323,7 +323,7 @@
(let* ((syms (get-syms))
(syms (union syms syms)))
(ppp 'res #`(begin
(pp 'res #`(begin
(eval-when (compile load eval)
(add-non-defined
(quote #,(datum->syntax stx syms))))
......
......@@ -482,17 +482,24 @@
(p))))))
(next l))))
(define (gp-cp x s)
(define gp-cp
(case-lambda
((x s)
(gp-cp x '() s))
((x l s)
(define vs (gp->scm l s))
(define tr (make-hash-table))
(let lp ((x x))
(let ((x (gp-lookup x s)))
(cond
((gp-attvar-raw? x s)
(if (not (hashq-ref tr x #f))
(begin
(hashq-set! tr x (gp-make-var))
(gp-att-data x s))))
(if (memq x vs)
#t
(if (not (hashq-ref tr x #f))
(begin
(hashq-set! tr x (gp-make-var))
(gp-att-data x s)))))
((gp-pair? x s)
(begin
......@@ -500,8 +507,10 @@
(lp (gp-cdr x s))))
((gp-var? x s)
(if (not (hashq-ref tr x #f))
(hashq-set! tr x (gp-make-var))))
(if (memq x vs)
#t
(if (not (hashq-ref tr x #f))
(hashq-set! tr x (gp-make-var)))))
((vector? x)
(let lp2 ((i (- (vector-length x) 1)))
......@@ -523,16 +532,20 @@
(let ((x (gp-lookup x s)))
(cond
((gp-attvar-raw? x s)
(let ((v (hashq-ref tr x 'BUG)))
(if (not (gp-attvar-raw? v s))
(gp-att-put-data v (lp (gp-att-data x s)) s))))
(if (memq x vs)
x
(let ((v (hashq-ref tr x 'BUG)))
(if (not (gp-attvar-raw? v s))
(gp-att-put-data v (lp (gp-att-data x s)) s)))))
((gp-pair? x s)
(cons (lp (gp-car x s))
(lp (gp-cdr x s))))
((gp-var? x s)
(hashq-ref tr x 'BUG))
(if (memq x vs)
x
(hashq-ref tr x 'BUG)))
((vector? x)
(apply vector (map lp (vector->list x))))
......@@ -557,7 +570,7 @@
(namespace-lexical? x)))))
(else
x)))))
x)))))))
(define (get-free-variables-map x s)
(define tr (make-hash-table))
......@@ -622,7 +635,7 @@
s)
(let ((u (newf s)))
(pk 'u u)
;(pk 'u u)
(hashq-set! *unmap* u unwinded)
u)))
......
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