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

version 1.1, 2003/09/08 13:05:15 version 1.3, 2003/09/29 20:51:16
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 -- }  : normal-stack-access1 { n stack state -- }
       state state-sss stack stack-number @ th @ { ss }
       ss ss-registers 2@ n u> if ( addr ) \ in ss-registers?
           n th @ dup if ( register ) \ and is ss-registers[n] a register?
               \ then use the register
               register-name 2@ type exit
           endif
       endif
       drop
     stack stack-pointer 2@ type      stack stack-pointer 2@ type
     n if      n ss ss-offset @ - stack normal-stack-access0 ;
         n stack normal-stack-access0  
     else  
         ." TOS"  
     endif ;  
   
 : normal-stack-access ( n stack -- )  : normal-stack-access ( n stack state -- )
     dup inst-stream-f = if      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 417  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 431  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 441  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 449  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 614  does> ( item -- ) Line 640  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.3


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