--- gforth/Attic/prims2y.fs	2003/09/21 18:54:38	1.2
+++ gforth/Attic/prims2y.fs	2003/10/01 09:15:45	1.4
@@ -196,6 +196,7 @@ end-struct register%
 
 struct%
     cell% 2* field ss-registers  \ addr u; ss-registers[0] is TOS
+                                 \ 0 means: use memory
     cell%    field ss-offset     \ stack pointer offset: sp[-offset] is TOS
 end-struct ss% \ stack-state
 
@@ -287,6 +288,8 @@ end-struct prim%
 0 value combined \ in combined prims the combined prim
 variable in-part \ true if processing a part
  in-part off
+0 value state-in  \ state on entering prim
+0 value state-out \ state on exiting prim
 
 : prim-context ( ... p xt -- ... )
     \ execute xt with prim set to p
@@ -369,18 +372,29 @@ defer inst-stream-f ( -- stack )
 \ stack access stuff
 
 : normal-stack-access0 { n stack -- }
+    \ n has the ss-offset already applied (see ...-access1)
     n stack stack-access-transform @ execute ." [" 0 .r ." ]" ;
-    
-: normal-stack-access1 { n stack -- }
-    stack stack-pointer 2@ type
-    n if
-	n stack normal-stack-access0
+
+: state-ss { stack state -- ss }
+    state state-sss stack stack-number @ th @ ;
+
+: stack-reg { n stack state -- reg }
+    \ n is the index (TOS=0); reg is 0 if the access is to memory
+    stack state state-ss ss-registers 2@ n u> if ( addr ) \ in ss-registers?
+	n th @
     else
-	." TOS"
+	drop 0
     endif ;
 
-: normal-stack-access ( n stack -- )
-    dup inst-stream-f = if
+: normal-stack-access1 { n stack state -- }
+    n stack state stack-reg ?dup-if
+	register-name 2@ type exit
+    endif
+    stack stack-pointer 2@ type
+    n stack state state-ss ss-offset @ - stack normal-stack-access0 ;
+
+: normal-stack-access ( n stack state -- )
+    over inst-stream-f = if
 	." IMM_ARG(" normal-stack-access1 ." ," immarg ? ." )"
 	1 immarg +!
     else
@@ -409,7 +423,7 @@ defer inst-stream-f ( -- stack )
     stack stack-number @ part-num @ s-c-max-depth @
 \    max-depth stack stack-number @ th @ ( ndepth nmaxdepth )
     over <= if ( ndepth ) \ load from memory
-	stack normal-stack-access
+	stack state-in normal-stack-access
     else
 	drop n stack part-stack-access
     endif ;
@@ -423,7 +437,7 @@ defer inst-stream-f ( -- stack )
     stack stack-number @ part-num @ s-c-max-back-depth @
     over <= if ( ndepth )
 	stack combined ['] stack-diff prim-context -
-	stack normal-stack-access
+	stack state-out normal-stack-access
     else
 	drop n stack part-stack-access
     endif ;
@@ -433,7 +447,7 @@ defer inst-stream-f ( -- stack )
     in-part @ if
 	part-stack-read
     else
-	normal-stack-access
+	state-in normal-stack-access
     endif ;
 
 : stack-write ( n stack -- )
@@ -441,7 +455,7 @@ defer inst-stream-f ( -- stack )
     in-part @ if
 	part-stack-write
     else
-	normal-stack-access
+	state-out normal-stack-access
     endif ;
 
 : item-in-index { item -- n }
@@ -492,7 +506,7 @@ defer inst-stream-f ( -- stack )
  rdrop ;
 
 : item-out-index ( item -- n )
-    \ n is the index of item (in the in-effect)
+    \ n is the index of item (in the out-effect)
     >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ;
 
 : really-store-single ( item -- )
@@ -504,17 +518,14 @@ defer inst-stream-f ( -- stack )
     r@ item-out-index r@ item-stack @ stack-write ." );"
     rdrop ;
 
-: store-single ( item -- )
-    >r
-    store-optimization @ in-part @ 0= and r@ same-as-in? and if
-	r@ item-in-index 0= r@ item-out-index 0= xor if
-	    ." IF_" r@ item-stack @ stack-pointer 2@ type
-	    ." TOS(" r@ really-store-single ." );" cr
-	endif
-    else
-	r@ really-store-single cr
-    endif
-    rdrop ;
+: store-single { item -- }
+    item item-stack @ { stack }
+    store-optimization @ in-part @ 0= and item same-as-in? and
+    item item-in-index  stack state-in  stack-reg 0= and \  in in memory?
+    item item-out-index stack state-out stack-reg 0= and \ out in memory?
+    0= if
+	item really-store-single cr
+    endif ;
 
 : store-double ( item -- )
 \ !! store optimization is not performed, because it is not yet needed