[BACK]Return to prims2y.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

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

version 1.1, 2003/09/08 13:05:15 version 1.4, 2003/10/01 09:15:45
Line 188  struct% Line 188  struct%
     cell%    field type-store \ xt of store code generator ( item -- )      cell%    field type-store \ xt of store code generator ( item -- )
 end-struct type%  end-struct type%
   
   struct%
       cell%    field register-number
       cell%    field register-type \ pointer to type
       cell% 2* field register-name \ c name
   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
   
   struct%
       cell% max-stacks * field state-sss
   end-struct state%
   
 variable next-stack-number 0 next-stack-number !  variable next-stack-number 0 next-stack-number !
 create stacks max-stacks cells allot \ array of stacks  create stacks max-stacks cells allot \ array of stacks
   256 constant max-registers
   create registers max-registers cells allot \ array of registers
   variable nregisters 0 nregisters ! \ number of registers
   
 : stack-in-index ( in-size item -- in-index )  : stack-in-index ( in-size item -- in-index )
     item-offset @ - 1- ;      item-offset @ - 1- ;
Line 269  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 351  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 391  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 405  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 415  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 423  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 474  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 486  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
Line 614  does> ( item -- ) Line 643  does> ( item -- )
 wordlist constant type-names \ this is here just to meet the requirement  wordlist constant type-names \ this is here just to meet the requirement
                     \ that a type be a word; it is never used for lookup                      \ that a type be a word; it is never used for lookup
   
   : define-type ( addr u -- xt )
       \ define single type with name addr u, without stack
       get-current type-names set-current >r
       2dup nextname stack-type-name
       r> set-current
       latestxt ;
   
 : stack ( "name" "stack-pointer" "type" -- )  : stack ( "name" "stack-pointer" "type" -- )
     \ define stack      \ define stack
     name { d: stack-name }      name { d: stack-name }
     name { d: stack-pointer }      name { d: stack-pointer }
     name { d: stack-type }      name { d: stack-type }
     get-current type-names set-current      stack-type define-type
     stack-type 2dup nextname stack-type-name      stack-pointer rot >body stack-name nextname make-stack ;
     set-current  
     stack-pointer latestxt >body stack-name nextname make-stack ;  
   
 stack inst-stream IP Cell  stack inst-stream IP Cell
 ' inst-in-index inst-stream stack-in-index-xt !  ' inst-in-index inst-stream stack-in-index-xt !
 ' inst-stream <is> inst-stream-f  ' inst-stream <is> inst-stream-f
 \ !! initialize stack-in and stack-out  \ !! initialize stack-in and stack-out
   
   \ registers
   
   : make-register ( type addr u -- )
       \ define register with type TYPE and name ADDR U.
       nregisters @ max-registers < s" too many registers" ?print-error
       2dup nextname create register% %allot >r
       r@ register-name 2!
       r@ register-type !
       nregisters @ r@ register-number !
       1 nregisters +!
       rdrop ;
   
   : register ( "name" "type" -- )
       \ define register
       name { d: reg-name }
       name { d: reg-type }
       reg-type define-type >body
       reg-name make-register ;
   
   \ stack-states
   
   : stack-state ( a-addr u uoffset "name" -- )
       create ss% %allot >r
       r@ ss-offset !
       r@ ss-registers 2!
       rdrop ;
   
   0 0 0 stack-state default-ss
   
   \ state
   
   : state ( "name" -- )
       \ create a state initialized with default-sss
       create state% %allot state-sss { sss }
       max-stacks 0 ?do
           default-ss sss i th !
       loop ;
   
   : set-ss ( ss stack state -- )
       state-sss swap stack-number @ th ! ;
   
 \ offset computation  \ offset computation
 \ the leftmost (i.e. deepest) item has offset 0  \ the leftmost (i.e. deepest) item has offset 0
 \ the rightmost item has the highest offset  \ the rightmost item has the highest offset
Removed from v.1.1  
changed lines
  Added in v.1.4

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