if then else debugged

parent 896d8c1a
......@@ -51,7 +51,8 @@ constant = #(nlocals nstack constants code)
(<declare-s> void INTERUPT ())
(<declare-s> void gp_gc ())
(<declare-s> void gp_gp_prune (SCM s))
(<declare-s> void gp_gp_prune (SCM s))
(<declare-s> void gp_gp_prune_tail (SCM s))
(<declare-s> SCM gp_get_state_token ())
(<declare-s> SCM car (SCM x))
(<declare-s> SCM cdr (SCM x))
......@@ -147,6 +148,7 @@ constant = #(nlocals nstack constants code)
(<=> pinned? (<scm> #f)))))
(define-syntax-rule (EQ x y) (<call> scm_is_eq x y))
(define-syntax-rule (PRUNE s) (<call> gp_gp_prune s))
(define-syntax-rule (PRUNE-TAIL s) (<call> gp_gp_prune_tail s))
(define-syntax-rule (GPPAIR? x s) (TRUE (<call> gp_pair x s)))
(define-syntax-rule (GPCAR x s) (LOOKUP (<call> gp_car x s) s))
(define-syntax-rule (GPCDR x s) (LOOKUP (<call> gp_gp_cdr x s) s))
......@@ -972,31 +974,36 @@ constant = #(nlocals nstack constants code)
(BACKTRACK p instructions inst-pt fp sp))))))))
(define-syntax-rule (STORE-STATE tp tag s p stack)
(define-syntax-rule (STORE-STATE tp tag s fr p stack)
(GPCONS (GPCONS tag
(GPCONS p
(<if> tp
(GPCONS s (<call> scm_fluid_ref *delayers*) s)
(GPCONS s (<scm> #f) s))
(<let> ((sfr (GPCONS s fr s)))
(<if> tp
(GPCONS
sfr
(<call> scm_fluid_ref *delayers*) s)
(GPCONS
sfr (<scm> #f) s)))
s)
s)
stack s))
(define-syntax-rule (STORE-STATE-NEG tp tag s scut p stack)
(define-syntax-rule (STORE-STATE-NEG tp tag s fr scut p stack)
(GPCONS (GPCONS tag
(GPCONS p
(<if> tp
(GPCONS
(GPCONS s scut s)
(<call> scm_fluid_ref *delayers*) s)
s)
(<let> ((sfr (GPCONS s (GPCONS fr scut s) s)))
(<if> tp
(GPCONS
sfr
(<call> scm_fluid_ref *delayers*) s)
(GPCONS sfr (<scm> #f) s)))
s)
s)
stack s))
(define-syntax-rule (STORE-STATE-SOFT s tag p fp nstack)
(<let> ((int v (scm->int tag)))
(<=> (SVAR-REF fp nstack v) p)))
(<=> (SVAR-REF fp nstack v) p)))
(define-syntax-rule (CLEAR-SP-XP sp xp)
......@@ -1019,15 +1026,16 @@ constant = #(nlocals nstack constants code)
(<if> (EQ (GGPCAR x) tag)
(<let*> ((x1 (GGPCDR x))
(x2 (GGPCDR x1))
(x3 (GGPCDR x2)))
(x3 (GGPCDR x2))
(ss (GGPCDR (GGPCAR x2))))
(<if> (TRUE x3)
(<begin>
(<call> scm_fluid_set_x *delayers* x3)
(<=> s (GGPCAR x2))
(<c> 4))
(<=> s ss)
(<c> 5))
(<begin>
(<=> s (GGPCAR x2))
(<c> 4))))
(<=> s ss)
(<c> 5))))
(<begin>
(<=> stack (GPCDR stack s))
(<next> lp))))))
......@@ -1041,11 +1049,13 @@ constant = #(nlocals nstack constants code)
(x3 (GGPCDR x2)))
(<=> p (GGPCAR x1))
(<=> stack (GGPCDR stack))
(<if> (TRUE x3)
(<let> ((ss (GGPCAR x2)))
(<call> scm_fluid_set_x *delayers* x3)
(<=> s ss))
(<=> s (GGPCAR x2))))
(<let*> ((sx (GGPCAR x2))
(fr (GGPCDR sx))
(ss (GGPCAR sx)))
(<if> (TRUE x3)
(<call> scm_fluid_set_x *delayers* x3))
(<=> s ss)
fr))
(<begin>
(<=> stack (GGPCDR stack))
(<next> lp))))))
......@@ -1057,7 +1067,8 @@ constant = #(nlocals nstack constants code)
(<if> (EQ (GGPCAR x) tag)
(<let*> ((x1 (GGPCDR x)))
(<=> p (GGPCAR x1))
(<=> stack (GGPCDR stack)))
(<=> stack (GGPCDR stack))
(PRUNE-TAIL (GGPCDR (GGPCAR (GGPCDR x1)))))
(<begin>
(<=> stack (GGPCDR stack))
(<next> lp))))))
......@@ -1068,16 +1079,34 @@ constant = #(nlocals nstack constants code)
(<let> ((x (GGPCAR stack)))
(<if> (EQ (GGPCAR x) tag)
(<let*> ((x1 (GGPCDR x))
(x2 (GGPCDR x1)))
(x2 (GGPCDR x1))
(x3 (GGPCDR x2))
(s0 (GGPCAR x2))
(x4 (GGPCDR x2))
(fr (GGPCAR x4))
(sc (GGPCDR x4)))
(<=> p (GGPCAR x1))
(<=> s s0)
(<=> scut sc)
(<=> stack (GGPCDR stack))
(<if> (GGPAIR? x2)
(<let> ((ss (GGPCAR x2)))
(<call> scm_fluid_set_x *delayers*
(GGPCDR x2))
(<=> s (GGPCAR ss))
(<=> scut (GGPCDR ss)))
(<=> s x2)))
(<if> (TRUE x3)
(<call> scm_fluid_set_x *delayers* x3))
fr)
(<begin>
(<=> stack (GGPCDR stack))
(<next> lp))))))
(define-syntax-rule (RESTORE-STATE-TAIL-NEG-0 scut p tag stack)
(<recur> lp ()
(<let> ((x (GGPCAR stack)))
(<if> (EQ (GGPCAR x) tag)
(<let*> ((x1 (GGPCDR x))
(x2 (GGPCDR x1))
(x4 (GGPCDR x2))
(sc (GGPCDR x4)))
(<=> p (GGPCAR x1))
(<=> scut sc)
(<=> stack (GGPCDR stack)))
(<begin>
(<=> stack (GGPCDR stack))
(<next> lp))))))
......@@ -2075,10 +2104,10 @@ constant = #(nlocals nstack constants code)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0)))
(int tp (scm->int (<ref> inst-pt (<c> 1))))
(SCM ss (NEWFRAME s)))
(SCM fr (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<=> s ss)
(<=> ctrl-stack (STORE-STATE tp np s p ctrl-stack))
(<=> ctrl-stack (STORE-STATE tp np s fr p ctrl-stack))
(<=> s fr)
(<=> p np)
(<call> INTERUPT)
(NEXT inst-pt))
......@@ -2087,6 +2116,7 @@ constant = #(nlocals nstack constants code)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0)))
(int tp (scm->int (<ref> inst-pt (<c> 1))))
(SCM so s)
(SCM ss (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<=> s ss)
......@@ -2100,7 +2130,7 @@ constant = #(nlocals nstack constants code)
*gp-not-n* s))))
s))
(<=> s (<call> gp_set *gp-is-delayed?* (<scm> #f) s))
(<=> ctrl-stack (STORE-STATE-NEG tp np ss scut p ctrl-stack))
(<=> ctrl-stack (STORE-STATE-NEG tp np so ss scut p ctrl-stack))
(<=> p np)
(<=> cut np)
(<call> INTERUPT)
......@@ -2123,10 +2153,10 @@ constant = #(nlocals nstack constants code)
(<let> ((SCM np (<ref> inst-pt (<c> 0))))
(<=> cut (<ref> inst-pt (<c> 1)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(RESTORE-STATE-TAIL-NEG s scut p np ctrl-stack)
(<let> ((int n (scm->int (<call> gp_gp_lookup *gp-not-n* s)))
(SCM d (<call> gp_gp_lookup *gp-is-delayed?* s)))
(UNWIND-TAIL s)
(<let> ((SCM fr (RESTORE-STATE-TAIL-NEG s scut p np ctrl-stack))
(int n (scm->int (<call> gp_gp_lookup *gp-not-n* s)))
(SCM d (<call> gp_gp_lookup *gp-is-delayed?* s)))
(UNWIND-TAIL fr)
(<if> (<and> (q> n (<c> 1))
(<call> scm_is_true d))
(<begin>
......@@ -2155,9 +2185,9 @@ constant = #(nlocals nstack constants code)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(RESTORE-STATE-TAIL s p tag ctrl-stack)
(UNWIND-TAIL s)
(NEXT inst-pt))
(<let> ((ss (RESTORE-STATE-TAIL s p tag ctrl-stack)))
(UNWIND-TAIL ss)
(NEXT inst-pt)))
(LABEL unwind-light-tail)
(PRSTACK sp fp)
......@@ -2200,8 +2230,7 @@ constant = #(nlocals nstack constants code)
(PRSTACK sp fp)
(<let> ((SCM n (<*> inst-pt)))
(<=> cut (<ref> inst-pt (<c> 1)))
(RESTORE-STATE-TAIL-NEG s scut p n ctrl-stack)
(UNWIND-TAIL s)
(RESTORE-STATE-TAIL-NEG-0 scut p n ctrl-stack)
(<call> gp_fluid_force_bang *gp-is-delayed?* (<scm> #f) s)
(BACKTRACK p instructions inst-pt fp sp))
......@@ -2619,7 +2648,7 @@ constant = #(nlocals nstack constants code)
(LABEL mk-fkn)
(PRSTACK sp fp)
(<let*> ((int n (scm->int (<*> inst-pt))))
(<let*> ((int n (scm->int (<*> inst-pt))))
(<++> inst-pt)
(<recur> lp ((int i n))
(<if> (q<= i (<c> 0))
......
This source diff could not be displayed because it is too large. You can view the blob instead.
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