Diff for /gforth/prims2x.fs between versions 1.80 and 1.81

version 1.80, 2001/02/09 20:15:31 version 1.81, 2001/02/23 10:43:40
Line 101  skipsynclines on Line 101  skipsynclines on
     loop      loop
     drop ;      drop ;
   
   : wordlist-insert { c-addr u wordlist xt -- }
       \ adds name "addr u" to wordlist using defining word xt
       \ xt may cause additional stack effects
       get-current >r wordlist set-current
       c-addr u nextname xt execute
       r> set-current ;
   
 : start ( -- addr )  : start ( -- addr )
  cookedinput @ ;   cookedinput @ ;
   
Line 131  skipsynclines on Line 138  skipsynclines on
 variable output          \ xt ( -- ) of output word for simple primitives  variable output          \ xt ( -- ) of output word for simple primitives
 variable output-combined \ xt ( -- ) of output word for combined primitives  variable output-combined \ xt ( -- ) of output word for combined primitives
   
 : printprim ( -- )  
  output @ execute ;  
   
 struct%  struct%
     cell%    field stack-number \ the number of this stack      cell%    field stack-number \ the number of this stack
     cell% 2* field stack-pointer \ stackpointer name      cell% 2* field stack-pointer \ stackpointer name
Line 228  variable in-part \ true if processing a Line 232  variable in-part \ true if processing a
 create combined-prims max-combined cells allot  create combined-prims max-combined cells allot
 variable num-combined  variable num-combined
   
   table constant combinations
     \ the keys are the sequences of pointers to primitives
   
 create current-depth max-stacks cells allot  create current-depth max-stacks cells allot
 create max-depth     max-stacks cells allot  create max-depth     max-stacks cells allot
 create min-depth     max-stacks cells allot  create min-depth     max-stacks cells allot
Line 447  does> ( item -- ) Line 454  does> ( item -- )
         endif          endif
         -1 s+loop          -1 s+loop
     \ we did not find a type, abort      \ we did not find a type, abort
     true abort" unknown prefix" ;      false s" unknown prefix" ?print-error ;
   
 : declaration ( item -- )  : declaration ( item -- )
     dup item-name 2@ execute-prefix ;      dup item-name 2@ execute-prefix ;
Line 514  s" IP" save-mem cell-type  s" error don' Line 521  s" IP" save-mem cell-type  s" error don'
     inst-stream clear-stack      inst-stream clear-stack
     prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items      prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items
     prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items      prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items
     inst-stream stack-out @ 0<> abort" # can only be on the input side" ;      inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
   
   : process-simple ( -- )
       prim prim { W^ key } key cell
       combinations ['] constant wordlist-insert
       declarations compute-offsets
       output @ execute
       1 function-number +! ;
   
 : flush-a-tos { stack -- }  : flush-a-tos { stack -- }
     stack stack-out @ 0<> stack stack-in @ 0= and      stack stack-out @ 0<> stack stack-in @ 0= and
Line 888  s" IP" save-mem cell-type  s" error don' Line 902  s" IP" save-mem cell-type  s" error don'
     loop ;      loop ;
   
 : process-combined ( -- )  : process-combined ( -- )
       combined combined-prims num-combined @ cells
       combinations ['] constant wordlist-insert
     prim compute-effects      prim compute-effects
     prim init-effects      prim init-effects
     output-combined perform ;      output-combined perform ;
Line 954  s" IP" save-mem cell-type  s" error don' Line 970  s" IP" save-mem cell-type  s" error don'
     cr ;      cr ;
   
 : output-forth-combined ( -- )  : output-forth-combined ( -- )
     ;  ;
   
   
   \ compile VM insts
   
   \ in order for this to work as intended, shorter combinations for each
   \ length must be present, and the longer combinations must follow
   \ shorter ones (this restriction may go away in the future).
     
   : output-pregen-combined ( -- )
       combined-prims num-combined @ 1- cells combinations search-wordlist
       s" the prefix for this combination must be defined earlier" ?print-error
       execute prim-c-name 2@ type space
       combined-prims num-combined @ 1- th @ prim-c-name 2@ type ."  -> "
       combined prim-c-name 2@ type cr ;
   
 \ the parser  \ the parser
   
Line 989  print-token ! Line 1019  print-token !
     endif      endif
     0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )      0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )
     dup c@ bl = if      dup c@ bl = if
         char+ dup c@ [char] " <> abort" sync line syntax"          char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error
         char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!          char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!
         char+          char+
     endif      endif
     dup c@ nl-char <> abort" sync line syntax"      dup c@ nl-char <> 0= s" sync line syntax" ?print-error
     skipsynclines @ if      skipsynclines @ if
         dup char+ rawinput !          dup char+ rawinput !
         rawinput @ c@ cookedinput @ c!          rawinput @ c@ cookedinput @ c!
Line 1104  Variable c-flag Line 1134  Variable c-flag
    {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nleof white ** )) ** {{ end prim prim-c-code 2! skipsynclines on }}     {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nleof white ** )) ** {{ end prim prim-c-code 2! skipsynclines on }}
    (( ` :  white ** nleof     (( ` :  white ** nleof
       {{ start }} (( nonl ++  nleof white ** )) ++ {{ end prim prim-forth-code 2! }}        {{ start }} (( nonl ++  nleof white ** )) ++ {{ end prim prim-forth-code 2! }}
    )) ?? {{  declarations compute-offsets printprim 1 function-number +! }}     )) ?? {{ process-simple }}
    nleof     nleof
 )) <- simple-primitive ( -- )  )) <- simple-primitive ( -- )
   

Removed from v.1.80  
changed lines
  Added in v.1.81


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