[gforth] / gforth / prims2x.fs  

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.80 and 1.85

version 1.80, Fri Feb 9 20:15:31 2001 UTC version 1.85, Tue Feb 27 10:30:02 2001 UTC
Line 101 
Line 101 
     loop      loop
     drop ;      drop ;
   
   : insert-wordlist { 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 
Line 138 
 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 205 
Line 209 
     cell% 2* field prim-c-code      cell% 2* field prim-c-code
     cell% 2* field prim-forth-code      cell% 2* field prim-forth-code
     cell% 2* field prim-stack-string      cell% 2* field prim-stack-string
       cell%    field prim-num            \ ordinal number
     cell%    field prim-items-wordlist \ unique items      cell%    field prim-items-wordlist \ unique items
     item% max-effect * field prim-effect-in      item% max-effect * field prim-effect-in
     item% max-effect * field prim-effect-out      item% max-effect * field prim-effect-out
Line 228 
Line 233 
 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 235 
Line 243 
 wordlist constant primitives  wordlist constant primitives
   
 : create-prim ( prim -- )  : create-prim ( prim -- )
     get-current >r      dup prim-name 2@ primitives ['] constant insert-wordlist ;
     primitives set-current  
     dup prim-name 2@ nextname constant  
     r> set-current ;  
   
 : stack-in ( stack -- addr )  : stack-in ( stack -- addr )
     \ address of number of stack items in effect in      \ address of number of stack items in effect in
Line 447 
Line 452 
         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 479 
Line 484 
     item declaration ;      item declaration ;
   
 \ types pointed to by stacks for use in combined prims  \ types pointed to by stacks for use in combined prims
 s" Cell"  single 0 create-type cell-type  \ !! output-c-combined shouldn't use these names!
 s" Float" single 0 create-type float-type  s" Cell"  single 0 create-type w
   s" Float" single 0 create-type r
 s" sp" save-mem cell-type  s" (Cell)" make-stack data-stack  
 s" fp" save-mem float-type s" "       make-stack fp-stack  s" sp" save-mem w s" (Cell)" make-stack data-stack
 s" rp" save-mem cell-type  s" (Cell)" make-stack return-stack  s" fp" save-mem r s" "       make-stack fp-stack
 s" IP" save-mem cell-type  s" error don't use # on results" make-stack inst-stream  s" rp" save-mem w s" (Cell)" make-stack return-stack
   s" IP" save-mem w s" error don't use # on results" make-stack inst-stream
 ' 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
Line 514 
Line 520 
     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 insert-wordlist
       declarations compute-offsets
       output @ execute ;
   
 : 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 578 
Line 590 
     ." NEXT_P1;" cr      ." NEXT_P1;" cr
     stores      stores
     fill-tos      fill-tos
     ." NEXT_P2;" cr ;      ." NEXT_P2;" ;
   
 : type-c ( c-addr u -- )  : type-c-code ( c-addr u xt -- )
     \ like TYPE, but replaces "TAIL;" with tail code      \ like TYPE, but replaces "TAIL;" with tail code produced by xt
       { xt }
     begin ( c-addr1 u1 )      begin ( c-addr1 u1 )
         2dup s" TAIL;" search          2dup s" TAIL;" search
     while ( c-addr1 u1 c-addr3 u3 )      while ( c-addr1 u1 c-addr3 u3 )
         2dup 2>r drop nip over - type          2dup 2>r drop nip over - type
         output-c-tail          xt execute
         2r> 5 /string          2r> 5 /string
         \ !! resync #line missing          \ !! resync #line missing
     repeat      repeat
Line 622 
Line 635 
  stack-pointer-updates   stack-pointer-updates
  ." {" cr   ." {" cr
  ." #line " c-line @ . quote c-filename 2@ type quote cr   ." #line " c-line @ . quote c-filename 2@ type quote cr
  prim prim-c-code 2@ type-c   prim prim-c-code 2@ ['] output-c-tail type-c-code
  ." }" cr   ." }" cr
  output-c-tail   output-c-tail
  ." }" cr   ." }" cr
Line 745 
Line 758 
   
 [IFDEF] documentation  [IFDEF] documentation
 : register-doc ( -- )  : register-doc ( -- )
     get-current documentation set-current      prim prim-name 2@ documentation ['] create insert-wordlist
     prim prim-name 2@ nextname create  
     prim prim-name 2@ 2,      prim prim-name 2@ 2,
     prim prim-stack-string 2@ condition-stack-effect 2,      prim prim-stack-string 2@ condition-stack-effect 2,
     prim prim-wordset 2@ 2,      prim prim-wordset 2@ 2,
     prim prim-c-name 2@ condition-pronounciation 2,      prim prim-c-name 2@ condition-pronounciation 2,
     prim prim-doc 2@ 2,      prim prim-doc 2@ 2, ;
     set-current ;  
 [THEN]  [THEN]
   
   
Line 888 
Line 899 
     loop ;      loop ;
   
 : process-combined ( -- )  : process-combined ( -- )
       combined combined-prims num-combined @ cells
       combinations ['] constant insert-wordlist
     prim compute-effects      prim compute-effects
     prim init-effects      prim init-effects
     output-combined perform ;      output-combined perform ;
Line 910 
Line 923 
     fetches ;      fetches ;
   
 : part-output-c-tail ( -- )  : part-output-c-tail ( -- )
     output-c-tail ;      stores ;
   
   : output-combined-tail ( -- )
       part-output-c-tail
       prim >r combined to prim
       in-part @ >r in-part off
       output-c-tail
       r> in-part ! r> to prim ;
   
 : output-part ( p -- )  : output-part ( p -- )
     to prim      to prim
Line 923 
Line 943 
     prim add-depths \ !! right place?      prim add-depths \ !! right place?
     ." {" cr      ." {" cr
     ." #line " c-line @ . quote c-filename 2@ type quote cr      ." #line " c-line @ . quote c-filename 2@ type quote cr
     prim prim-c-code 2@ type-c \ !! deal with TAIL      prim prim-c-code 2@ ['] output-combined-tail type-c-code
     ." }" cr      ." }" cr
     part-output-c-tail      part-output-c-tail
     ." }" cr ;      ." }" cr ;
Line 956 
Line 976 
 : output-forth-combined ( -- )  : output-forth-combined ( -- )
     ;      ;
   
   
   \ peephole optimization rules
   
   \ 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-peephole ( -- )
       combined-prims num-combined @ 1- cells combinations search-wordlist
       s" the prefix for this combination must be defined earlier" ?print-error
       ." {"
       execute prim-num @ 5 .r ." ,"
       combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ,"
       combined prim-num @ 5 .r ." }, /* "
       combined prim-c-name 2@ type ."  */"
       cr ;
   
   
 \ the parser  \ the parser
   
 eof-char max-member \ the whole character set + EOF  eof-char max-member \ the whole character set + EOF
Line 989 
Line 1027 
     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 
Line 1142 
    {{ 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 ( -- )
   
Line 1115 
Line 1153 
   
 (( {{ make-prim to prim 0 to combined  (( {{ make-prim to prim 0 to combined
       line @ name-line ! filename 2@ name-filename 2!        line @ name-line ! filename 2@ name-filename 2!
         function-number @ prim prim-num !
       start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }}  white ++        start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }}  white ++
    (( simple-primitive || combined-primitive ))     (( simple-primitive || combined-primitive )) {{ 1 function-number +! }}
 )) <- primitive ( -- )  )) <- primitive ( -- )
   
 (( (( comment || primitive || nl white ** )) ** eof ))  (( (( comment || primitive || nl white ** )) ** eof ))

Generate output suitable for use with a patch program
Legend:
Removed from v.1.80  
changed lines
  Added in v.1.85
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help