Diff for /gforth/Attic/prims2y.fs between versions 1.2 and 1.4

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

Removed from v.1.2  
changed lines
  Added in v.1.4


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>