[gforth] / gforth / prims2x.fs  

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.146 and 1.156

version 1.146, Thu Oct 16 18:48:03 2003 UTC version 1.156, Wed Jul 27 19:44:20 2005 UTC
Line 1 
Line 1 
 \ converts primitives to, e.g., C code  \ converts primitives to, e.g., C code
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 246 
Line 246 
   
 : init-item ( addr u addr1 -- )  : init-item ( addr u addr1 -- )
     \ initialize item at addr1 with name addr u      \ initialize item at addr1 with name addr u
     \ !! remove stack prefix      \ the stack prefix is removed by the stack-prefix
     dup item% %size erase      dup item% %size erase
     item-name 2! ;      item-name 2! ;
   
Line 280 
Line 280 
     cell%    field prim-effect-out-end      cell%    field prim-effect-out-end
     cell% max-stacks * field prim-stacks-in  \ number of in items per stack      cell% max-stacks * field prim-stacks-in  \ number of in items per stack
     cell% max-stacks * field prim-stacks-out \ number of out items per stack      cell% max-stacks * field prim-stacks-out \ number of out items per stack
       cell% max-stacks * field prim-stacks-sync \ sync flag per stack
 end-struct prim%  end-struct prim%
   
 : make-prim ( -- prim )  : make-prim ( -- prim )
Line 535 
Line 536 
 : store-single { item -- }  : store-single { item -- }
     item item-stack @ { stack }      item item-stack @ { stack }
     store-optimization @ in-part @ 0= and item same-as-in? and      store-optimization @ in-part @ 0= and item same-as-in? and
     item item-in-index  stack state-in  stack-reg 0= and \  in in memory?      item item-in-index  stack state-in  stack-reg       \  in reg/mem
     item item-out-index stack state-out stack-reg 0= and \ out in memory?      item item-out-index stack state-out stack-reg = and \ out reg/mem
     0= if      0= if
         item really-store-single cr          item really-store-single cr
     endif ;      endif ;
Line 649 
Line 650 
     stack item item-stack !      stack item item-stack !
     item declaration ;      item declaration ;
   
   get-current prefixes set-current
   : ... ( item -- )
       \ this "prefix" ensures that the appropriate stack is synced with memory
       dup item-name 2@ s" ..." str= 0= abort" '...' must end the item name"
       item-stack @ dup if
           stack-number @ prim prim-stacks-sync swap th on
       else \ prefixless "..." syncs all stacks
           max-stacks 0 +do
               prim prim-stacks-sync i th on
           loop
       endif ;
   set-current
   
   create ...-item ( -- addr ) \ just used for letting stack-prefixes work on it
   item% %allot                \ stores the stack temporarily until used by ...
   
   : init-item1 ( addr1 addr u -- addr2 )
       \ initialize item at addr1 with name addr u, next item is at addr2
       \ !! make sure that any mention of "..." is only stack-prefixed
       2dup s" ..." search nip nip if ( addr1 addr u )
           0 ...-item item-stack ! \ initialize to prefixless
           2dup ...-item item-name 2!
           ...-item rot rot execute-prefix ( addr1 )
       else
           2 pick init-item item% %size +
       endif ;
   
 \ types pointed to by stacks for use in combined prims  \ types pointed to by stacks for use in combined prims
 \ !! output-c-combined shouldn't use these names!  \ !! output-c-combined shouldn't use these names!
 : stack-type-name ( addr u "name" -- )  : stack-type-name ( addr u "name" -- )
Line 716 
Line 744 
         default-ss s state-sss i th !          default-ss s state-sss i th !
     loop ;      loop ;
   
   : .state ( state -- )
       0 >body - >name .name ;
   
 : set-ss ( ss stack state -- )  : set-ss ( ss stack state -- )
     state-sss swap stack-number @ th ! ;      state-sss swap stack-number @ th ! ;
   
Line 742 
Line 773 
     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= s" # can only be on the input side" ?print-error ;      inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
   
   : init-simple { prim -- }
       \ much of the initialization is elsewhere
       max-stacks 0 +do
           prim prim-stacks-sync i th off
       loop ;
   
 : process-simple ( -- )  : process-simple ( -- )
       prim init-simple
     prim prim { W^ key } key cell      prim prim { W^ key } key cell
     combinations ['] constant insert-wordlist      combinations ['] constant insert-wordlist
     declarations compute-offsets      declarations compute-offsets
Line 910 
Line 948 
   
 : output-label2 ( -- )  : output-label2 ( -- )
     ." LABEL2(" prim prim-c-name 2@ type ." )" cr      ." LABEL2(" prim prim-c-name 2@ type ." )" cr
     ." NEXT_P2;" cr ;      ." NEXT_P1_5;" cr
       ." LABEL3(" prim prim-c-name 2@ type ." )" cr
       ." DO_GOTO;" cr ;
   
 : output-c-tail1 { xt -- }  : output-c-tail1 { xt -- }
     \ the final part of the generated C code, with xt printing LABEL2 or not.      \ the final part of the generated C code, with xt printing LABEL2 or not.
Line 921 
Line 961 
     fill-state      fill-state
     xt execute ;      xt execute ;
   
   : output-c-vm-jump-tail ( -- )
       \ !! this functionality not yet implemented for superinstructions
       output-super-end
       print-debug-results
       stores
       fill-state
       ." LABEL2(" prim prim-c-name 2@ type ." )" cr
       ." LABEL3(" prim prim-c-name 2@ type ." )" cr
       ." DO_GOTO;" cr ;
   
 : output-c-tail1-no-stores { xt -- }  : output-c-tail1-no-stores { xt -- }
     \ the final part of the generated C code for combinations      \ the final part of the generated C code for combinations
     output-super-end      output-super-end
Line 932 
Line 982 
     tail-nextp2 @ output-c-tail1 ;      tail-nextp2 @ output-c-tail1 ;
   
 : output-c-tail2 ( -- )  : output-c-tail2 ( -- )
     ['] output-label2 output-c-tail1 ;      prim prim-c-code 2@ s" VM_JUMP(" search nip nip if
           output-c-vm-jump-tail
       else
           ['] output-label2 output-c-tail1
       endif ;
   
 : output-c-tail-no-stores ( -- )  : output-c-tail-no-stores ( -- )
     tail-nextp2 @ output-c-tail1-no-stores ;      tail-nextp2 @ output-c-tail1-no-stores ;
Line 960 
Line 1014 
 : print-entry ( -- )  : print-entry ( -- )
     ." LABEL(" prim prim-c-name 2@ type ." )" ;      ." LABEL(" prim prim-c-name 2@ type ." )" ;
   
   : prim-type ( addr u -- )
       \ print out a primitive, but avoid "*/"
       2dup s" */" search  nip nip  IF
           bounds ?DO  I c@ dup '* = IF  drop 'x  THEN  emit  LOOP
       ELSE  type  THEN ;
   
 : output-c ( -- )  : output-c ( -- )
     print-entry ."  /* " prim prim-name 2@ type ."  ( " prim prim-stack-string 2@ type ." ) */" cr      print-entry ."  /* " prim prim-name 2@ prim-type
       ."  ( " prim prim-stack-string 2@ type ." ) "
       state-in .state ." -- " state-out .state ."  */" cr
     ." /* " prim prim-doc 2@ type ."  */" cr      ." /* " prim prim-doc 2@ type ."  */" cr
     ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging      ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
     ." {" cr      ." {" cr
Line 1039 
Line 1101 
     prim prim-branch?      prim prim-branch?
     prim prim-c-code 2@  s" SUPER_END" search nip nip 0<> or      prim prim-c-code 2@  s" SUPER_END" search nip nip 0<> or
     prim prim-c-code 2@  s" SUPER_CONTINUE" search nip nip 0= and      prim prim-c-code 2@  s" SUPER_CONTINUE" search nip nip 0= and
     negate 0 .r ." , /* " prim prim-name 2@ type ."  */" cr ;      negate 0 .r ." , /* " prim prim-name 2@ prim-type ."  */" cr ;
   
 : gen-arg-parm { item -- }  : gen-arg-parm { item -- }
     item item-stack @ inst-stream = if      item item-stack @ inst-stream = if
Line 1110 
Line 1172 
 : output-alias ( -- )  : output-alias ( -- )
     ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ;      ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ;
   
 : output-c-prim-num ( -- )  defer output-c-prim-num ( -- )
   
   :noname ( -- )
     ." N_" prim prim-c-name 2@ type ." ," cr ;      ." N_" prim prim-c-name 2@ type ." ," cr ;
   is output-c-prim-num
   
 : output-forth ( -- )  : output-forth ( -- )
     prim prim-forth-code @ 0=      prim prim-forth-code @ 0=
Line 1442 
Line 1507 
   
 : output-part ( p -- )  : output-part ( p -- )
     to prim      to prim
     ." /* " prim prim-name 2@ type ."  ( " prim prim-stack-string 2@ type ." ) */" cr      ." /* " prim prim-name 2@ prim-type ."  ( " prim prim-stack-string 2@ type ." ) */" cr
     ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging      ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
     ." {" cr      ." {" cr
     print-declarations      print-declarations
Line 1550 
Line 1615 
     \ prim-num @ 4 .r ." ," ;      \ prim-num @ 4 .r ." ," ;
   
 : output-name-comment ( -- )  : output-name-comment ( -- )
     ."  /* " prim prim-name 2@ type ."  */" ;      ."  /* " prim prim-name 2@ prim-type ."  */" ;
   
 variable offset-super2  0 offset-super2 ! \ offset into the super2 table  variable offset-super2  0 offset-super2 ! \ offset into the super2 table
   
Line 1559 
Line 1624 
     rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , "      rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , "
     prim prim-branch? negate . ." ,"      prim prim-branch? negate . ." ,"
     state-in  state-number @ 2 .r ." ,"      state-in  state-number @ 2 .r ." ,"
     state-out state-number @ 2 .r ." ," ;      state-out state-number @ 2 .r ." ,"
       inst-stream stack-in @ 1 .r ." ,"
   ;
   
 : output-costs-gforth-simple ( -- )  : output-costs-gforth-simple ( -- )
     output-costs-prefix      output-costs-prefix
Line 1575 
Line 1642 
     output-name-comment      output-name-comment
     cr ;      cr ;
   
 : output-costs ( -- )  \  : output-costs ( -- )
     \ description of superinstructions and simple instructions  \      \ description of superinstructions and simple instructions
     ." {" prim compute-costs  \      ." {" prim compute-costs
     rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ,"  \      rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ,"
     offset-super2 @ 5 .r ." ,"  \      offset-super2 @ 5 .r ." ,"
     super2-length dup 2 .r ." }," offset-super2 +!  \      super2-length dup 2 .r ." ," offset-super2 +!
     output-name-comment  \      inst-stream stack-in @ 1 .r ." },"
     cr ;  \      output-name-comment
   \      cr ;
   
 : output-super2-simple ( -- )  : output-super2-simple ( -- )
     prim prim-c-name 2@ prim prim-c-name-orig 2@ d= if      prim prim-c-name 2@ prim prim-c-name-orig 2@ d= if
Line 1687 
Line 1755 
 (( letter (( letter || digit )) **  (( letter (( letter || digit )) **
 )) <- c-ident ( -- )  )) <- c-ident ( -- )
   
 (( ` # ?? (( letter || digit || ` : )) ++  (( ` # ?? (( letter || digit || ` : )) ++ (( ` . ` . ` . )) ??
 )) <- stack-ident ( -- )  )) <- stack-ident ( -- )
   
 (( nowhitebq nowhite ** ))  (( nowhitebq nowhite ** ))
Line 1742 
Line 1810 
   
 (( ` \ comment-body nleof )) <- comment ( -- )  (( ` \ comment-body nleof )) <- comment ( -- )
   
 (( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) **  (( {{ start }} stack-ident {{ end init-item1 }} white ** )) **
 <- stack-items  <- stack-items ( addr1 -- addr2 )
   
 (( {{ prim prim-effect-in }}  stack-items {{ prim prim-effect-in-end ! }}  (( {{ prim prim-effect-in }}  stack-items {{ prim prim-effect-in-end ! }}
    ` - ` - white **     ` - ` - white **

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help