if then else debugged

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