all tests passes

parent d325d81e
......@@ -280,10 +280,10 @@
(define-guile-log <succeds>
(syntax-rules ()
((_ (cut s p cc) g)
((_ (cut s p cc) g ...)
(let* ((s (gp-newframe s))
(ccc (lambda (ss pp) (gp-unwind s) (cc s p))))
(parse<> (cut s p ccc) g)))))
(parse<> (cut s p ccc) (<and> g ...))))))
......
......@@ -30,15 +30,9 @@ SCM make_logical()
return ret;
}
inline SCM logical_lookup(SCM x, SCM s)
inline SCM logical_lookup(SCM x, SCM l)
{
SCM l;
if(SCM_CONSP(s))
s = SCM_CDR(s);
else
return x;
SCM s = l;
/*
{
//new tree code here
......@@ -52,8 +46,6 @@ inline SCM logical_lookup(SCM x, SCM s)
}
*/
l = s;
if(!GP(x))
return x;
......@@ -83,14 +75,8 @@ inline SCM logical_lookup(SCM x, SCM s)
return x;
}
inline SCM logical_lookup2(SCM x, SCM s)
inline SCM logical_lookup2(SCM x, SCM l)
{
SCM l;
if(SCM_CONSP(s))
s = SCM_CDR(s);
else
return x;
/*
{
......@@ -106,8 +92,7 @@ inline SCM logical_lookup2(SCM x, SCM s)
goto retry_tree;
}
*/
l = s;
SCM s = l;
if(!GP(x))
return x;
......@@ -151,13 +136,17 @@ SCM logical_add(SCM x, SCM v, SCM s)
return scm_cons(SCM_CAR(s),gp_tree_add(ss,hash,x,v));
}
*/
SCM ss = s;
s = SCM_CDR(s);
if(SCM_CONSP(s))
return scm_cons(SCM_CAR(ss),
scm_cons(SCM_CAR(s),scm_cons(scm_cons(x,v),SCM_CDR(s))));
else
scm_misc_error("logical_add","malformed s",SCM_EOL);
if(!SCM_CONSP(s)) goto er;
SCM ss = SCM_CDR(s);
if(!SCM_CONSP(ss)) goto er;
SCM l = SCM_CDR(ss);
return scm_cons(SCM_CAR(s),
scm_cons(SCM_CAR(ss),scm_cons(scm_cons(x,v),l)));
er:
scm_misc_error("logical_add","malformed s",SCM_EOL);
return SCM_BOOL_F;
}
......
......@@ -332,8 +332,24 @@ static inline SCM gp_set_unbound_bang(SCM *id, SCM s)
static inline SCM * gp_lookup(SCM *id, SCM s)
{
gp_debug0("lookup>\n");
if(!SCM_CONSP(s)) goto er;
id = GP_GETREF(logical_lookup(GP_UNREF(id),GP_CDR(s)));
if(!SCM_CONSP(s)) goto er;
if(!SCM_CONSP(SCM_CDR(s))) goto er;
SCM l = SCM_CDDR(s);
if(!scm_is_eq(l,SCM_EOL)) goto advanced;
retry:
if(GP_POINTER(id))
{
id = GP_GETREF(GP_SCM(id));
goto retry;
}
return id;
advanced:
id = GP_GETREF(logical_lookup(GP_UNREF(id),l));
gp_debug0("lookup> /2\n");
if(!GP_STAR(id))
......@@ -343,12 +359,59 @@ static inline SCM * gp_lookup(SCM *id, SCM s)
}
gp_debug0("lookup> /3\n");
if(GP_POINTER(id))
{
id = GP_GETREF(GP_SCM(id));
goto advanced;
}
gp_debug2("lookup> %x 0 val = %x\n",id,SCM_UNPACK(*id)) ;
return id;
er:
scm_misc_error("gp_lookup","wrong format of s",SCM_EOL);
return id;
}
static inline SCM * gp_lookup2(SCM *id, SCM s)
{
gp_debug0("lookup>\n");
if(!SCM_CONSP(s)) goto er;
if(!SCM_CONSP(SCM_CDR(s))) goto er;
SCM l = SCM_CDDR(s);
if(!scm_is_eq(l,SCM_EOL)) goto advanced;
retry:
if(GP_POINTER(id))
{
id = GP_GETREF(GP_SCM(id));
goto retry;
}
return id;
advanced:
id = GP_GETREF(logical_lookup2(GP_UNREF(id),l));
gp_debug0("lookup> /2\n");
if(!GP_STAR(id))
{
gp_debug0("lookup> no star\n");
return id;
}
gp_debug0("lookup> /3\n");
if(GP_POINTER(id))
{
id = GP_GETREF(GP_SCM(id));
goto advanced;
}
gp_debug2("lookup> %x 0 val = %x\n",id,SCM_UNPACK(*id)) ;
return id;
......@@ -998,20 +1061,18 @@ static inline SCM ggp_set(SCM var, SCM val, SCM s)
if(GP(var))
{
id = GP_GETREF(var);
if(gp->_logical_)
id = GP_GETREF(logical_lookup2(GP_UNREF(id),SCM_CDR(s)));
else
id = gp_lookup(id,s);
id = gp_lookup2(id,s);
if(GP_STAR(id))
if(GP(val))
{
return gp_set_ref(id,GP_UNREF(gp_lookup(UN_GP(val),s)),s);
}
else
{
return gp_set_val(id,val, s);
}
if(GP(val))
{
return gp_set_ref(id,GP_UNREF(gp_lookup(UN_GP(val),s)),s);
}
else
{
return gp_set_val(id,val, s);
}
}
scm_misc_error("gp-set!","wrong type of the variable to set",SCM_EOL);
return SCM_BOOL_F;
......
......@@ -27,7 +27,7 @@
(syntax-rules ()
((_ title x y)
(begin
(gp-clear)
(gp-clear *current-stack*)
(with-test-prefix "start"
(pass-if (format #f "~a" 'x)
(equal? x y)))))))
......
......@@ -27,7 +27,7 @@
(syntax-rules ()
((_ title x y)
(begin
(gp-clear)
(gp-clear *current-stack*)
(with-test-prefix "start"
(pass-if (format #f "~a" 'x)
(equal? x y)))))))
......
......@@ -19,7 +19,7 @@
(define (check? x y)
(let ((ret (translate x)))
(format #t "check> ~a == ~a~%" ret y)
(<clear>)
(<clear> *current-stack*)
(equal? ret y)))
......@@ -27,7 +27,7 @@
(syntax-rules ()
((_ x y)
(begin
(gp-clear)
(gp-clear *current-stack*)
(pass-if (format #f "~a" 'x)
(equal? x y))))))
......@@ -172,7 +172,6 @@
((<=> 'oil x) <cc>)
(<fail>)))
'(olive))
(gp-clear)
(check?
(<run> * (x)
......
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