recur now works en prolog eval goal

parent 82605e4f
...@@ -1146,6 +1146,9 @@ constant = #(nlocals nstack constants code) ...@@ -1146,6 +1146,9 @@ constant = #(nlocals nstack constants code)
(REGISTER softie-light) (REGISTER softie-light)
(REGISTER newframe) (REGISTER newframe)
(REGISTER newframe-light) (REGISTER newframe-light)
(REGISTER newframe-ps)
(REGISTER newframe-pst)
(REGISTER unwind) (REGISTER unwind)
(REGISTER unwind-tail) (REGISTER unwind-tail)
(REGISTER unwind-light) (REGISTER unwind-light)
...@@ -1906,7 +1909,12 @@ constant = #(nlocals nstack constants code) ...@@ -1906,7 +1909,12 @@ constant = #(nlocals nstack constants code)
(SCM scut (<scm> 0)) (SCM scut (<scm> 0))
(int iter (<c> 0))) (int iter (<c> 0)))
(UNPACK-ENV free narg nlocals) #:defs ((define-syntax-rule (get vc e)
(<if> e
(<ref> variables vc)
(SVAR-REF fp nstack vc))))
(UNPACK-ENV free narg nlocals)
(UNPACK-1 free always middle session cnst) (UNPACK-1 free always middle session cnst)
(PRSTACK sp fp) (PRSTACK sp fp)
...@@ -2089,6 +2097,37 @@ constant = #(nlocals nstack constants code) ...@@ -2089,6 +2097,37 @@ constant = #(nlocals nstack constants code)
(STORE-STATE-SOFT s tag p fp nstack) (STORE-STATE-SOFT s tag p fp nstack)
(<call> INTERUPT) (<call> INTERUPT)
(NEXT inst-pt)) (NEXT inst-pt))
(LABEL newframe-ps)
(PRSTACK sp fp)
(<let*> ((SCM tag (<ref> inst-pt (<c> 0)))
(ulong x (scm->ulong (<ref> inst-pt (<c> 0))))
(int p1 (<and> x (<c> #ffff)))
(int s1 (<and> (q>> x (<c> 16)) (<c> #ffff)))
(int p2 (<and> (q>> x (<c> 32)) (<c> 1)))
(int s2 (<and> (q>> x (<c> 32)) (<c> 2)))
(SCM fr (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(set p1 p2 p)
(set s1 s2 s)
(<=> ctrl-stack (STOR-STATE tag ctrl-stack)))
(LABEL newframe-pst)
(<let*> ((SCM tag (<ref> inst-pt (<c> 0)))
(ulong x (scm->ulong (<ref> inst-pt (<c> 0))))
(int p1 (<and> x (<c> #ffff)))
(int s1 (<and> (q>> x (<c> 16)) (<c> #ffff)))
(int t1 (<and> (q>> x (<c> 32)) (<c> #ffff)))
(int p2 (<and> (q>> x (<c> 48)) (<c> 1)))
(int s2 (<and> (q>> x (<c> 48)) (<c> 2)))
(SCM fr (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(set p1 p2 p)
(set s1 s2 s)
(set t1 t2 (<call> scm_fluid_ref *delayers*) s)
(<=> ctrl-stack (STOR-STATE tag ctrl-stack)))
(PRSTACK sp fp)
(LABEL newframe-light) (LABEL newframe-light)
(PRSTACK sp fp) (PRSTACK sp fp)
......
...@@ -377,16 +377,16 @@ compile_goal(\\+\\+\\+X,Tail,V,[L,LL]) :- !, ...@@ -377,16 +377,16 @@ compile_goal(\\+\\+\\+X,Tail,V,[L,LL]) :- !,
compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !, compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
L=[['newframe-negation',Al,0]|LX], L=[['newframe-negation',Al,0]|LX],
get_QAESBB2(V,Q,A,E,S,B,B2), get_QAESBB2(V,Q,AA,E,S,B,B2),
set_QAE(V,[],[[0|_]],0), set_QAE(V,[],[[0|_]],0),
new_var(VP,V,TagP1), new_var(VP,V,TagP1),
new_var(VS,V,TagS1), new_var(VS,V,TagS1),
new_var(VT,V,TagY1), new_var(VT,V,TagT1),
compile_goal(call_(X,A,Ad,[C0|_],Pre,Post,LP),#f,V,[LX,LLX]), compile_goal(call_(X,A,Ad,[C0|_],Pre,Post,LP),#f,V,[LX,LLX]),
new_var(VP,V,TagP2), new_var(VP,V,TagP2),
new_var(VS,V,TagS2), new_var(VS,V,TagS2),
new_var(VT,V,TagT2), new_var(VT,V,TagT2),
set_QAESBB2(V,Q,A,E,S,B,B2), set_QAESBB2(V,Q,AA,E,S,B,B2),
(A=[[0|_]|_] -> Tp is 0 ; Tp is 1), (A=[[0|_]|_] -> Tp is 0 ; Tp is 1),
Ad=[A0,Cut_p], Ad=[A0,Cut_p],
( (
......
...@@ -223,15 +223,36 @@ t(X,X) :- b_getval(pretty,#t),!. ...@@ -223,15 +223,36 @@ t(X,X) :- b_getval(pretty,#t),!.
t('store-state'). t('store-state').
t(newframe). t(newframe).
t(newframe-ps).
t(newframe-pst).
t('newframe-light'). t('newframe-light').
t(unwind). t(unwind).
t(unwind-ps).
t(unwind-psc).
t(unwind-pst).
t(unwind-psct).
t('unwind-light'). t('unwind-light').
t('unwind-tail'). t('unwind-tail').
t('unwind-light-tail'). t('unwind-light-tail').
t(softie). t(softie).
t('softie-psc').
t('softie-ps').
t('softie-pc').
t('softie-light'). t('softie-light').
t('post-s'). t('post-s').
t('post-q'). t('post-q').
t('post-c').
t('post-sc').
t('store-ps').
t('store-p').
t('restore-c').
t('fail-psc').
t('fail-pc').
t('newframe-negation'). t('newframe-negation').
t('unwind-negation'). t('unwind-negation').
......
...@@ -51,6 +51,61 @@ ...@@ -51,6 +51,61 @@
(define op2: #f) (define op2: #f)
(define get-module #f) (define get-module #f)
(define namespace-switch #f) (define namespace-switch #f)
(<define> (get-vars a)
(<<match>> (#:mode -) (a)
((_ . _)
(<cc> a))
(#("," #(("," x y)) z)
(<values> (zz) (get-vars z))
(<cc> (cons (cons x y) zz)))
(z (<cc> z))))
(<define> (subst code vars)
(#(("op2*" (and a #((f l))) code))
(<values> (vs) (get-vars l))
(let ((va (map car vs))
(vb (map cdr vs)))
(<values> (c)
(subst code
(append (cons*
(cons f #f)
(map (lambda (x) (cons (car x) #f)) vs))
vars)))
(<values> (l) (subst vb vars))
(<cc> (lambda (x) (vector (list "op2*"
(map (lambda (v w) (cons v (w x)))
va vb)
(c x)))))))
(#(a)
(<values> aa (subst a vars))
(<cc> (lambda (x) (vector (aa x)))))
(#(a b)
(<values> aa (subst a vars))
(<values> bb (subst b vars))
(<cc> (lambda (x) (vector (aa x) (bb x)))))
((a . b)
(<values> aa (subst a vars))
(<values> bb (subst b vars))
(<cc> (lambda (x) (cons (aa x) (bb x)))))
(a
(lambda (x)
(let ((r (assq a vars)))
(if r
(let ((r (cdr r)))
(if r
(list-ref x r)
a))
a)))))
(<define> (goal-eval* cut scut x) (<define> (goal-eval* cut scut x)
(<<match>> (#:mode - #:name goal-eval) ((pp 'goal-eval x)) (<<match>> (#:mode - #:name goal-eval) ((pp 'goal-eval x))
(#((,op2: mod #((n . l)))) (#((,op2: mod #((n . l))))
...@@ -63,6 +118,22 @@ ...@@ -63,6 +118,22 @@
(procedure-name n)) (procedure-name n))
l))))))) l)))))))
(#(("op2*" #((f val)) code))
(<values> (vars.vals) (get-vals val))
(let* ((vars (map car vars.vals))
(vals (map cdr vars.vals))
(vvars (lp ((i 0) (vv vars))
(if (pair? vv)
(cons (cons (car vv) i)
(lp (+ i 1) (cdr vv)))
'())))
(code2 #f)
(lp (<lambda> x
(goal-eval* cut scut (code2 x)))))
(<values (code3) (subst code (cons (cons f lp) vvars)))
(<code> (set! code2 code3))
(<apply> lp vals)))
(#((f . l)) (#((f . l))
(<let> ((f (<lookup> f))) (<let> ((f (<lookup> f)))
(<let> ((x (object-property f 'prolog-functor-type))) (<let> ((x (object-property f 'prolog-functor-type)))
......
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