[gforth] / gforth / prims2x.fs  

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.63 and 1.64

version 1.63, Tue Jan 9 16:11:36 2001 UTC version 1.64, Wed Jan 17 09:35:12 2001 UTC
Line 140 
Line 140 
     dup item% %size erase      dup item% %size erase
     item-name 2! ;      item-name 2! ;
   
   : map-items { addr end xt -- }
       \ perform xt for all items in array addr...end
       end addr ?do
           i xt execute
       item% %size +loop ;
   
 \ various variables for storing stuff of one primitive  \ various variables for storing stuff of one primitive
   
 2variable forth-name  2variable forth-name
Line 505 
Line 511 
 : declaration ( item -- )  : declaration ( item -- )
     dup item-name 2@ execute-prefix ;      dup item-name 2@ execute-prefix ;
   
   : declaration-list ( addr1 addr2 -- )
       ['] declaration map-items ;
   
   : declarations ( -- )
    wordlist dup items ! set-current
    effect-in effect-in-end @ declaration-list
    effect-out effect-out-end @ declaration-list ;
   
 : stack-prefix ( stack "prefix" -- )  : stack-prefix ( stack "prefix" -- )
     name tuck nextname create ( stack length ) 2,      name tuck nextname create ( stack length ) 2,
 does> ( item -- )  does> ( item -- )
Line 513 
Line 527 
     stack item item-stack !      stack item item-stack !
     item declaration ;      item declaration ;
   
 : declaration-list ( addr1 addr2 -- )  
  swap ?do  
   i declaration  
  item% %size +loop ;  
   
 : declarations ( -- )  
  wordlist dup items ! set-current  
  effect-in effect-in-end @ declaration-list  
  effect-out effect-out-end @ declaration-list ;  
   
 \ 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
Line 533 
Line 537 
     item item-stack @ xt execute dup @ >r +!      item item-stack @ xt execute dup @ >r +!
     r> item item-offset ! ;      r> item item-offset ! ;
   
 : compute-list ( addr1 addr2 xt -- )  : compute-offset-in ( addr1 addr2 -- )
     { xt }      ['] stack-in compute-offset ;
     swap u+do  
         i xt compute-offset  : compute-offset-out ( addr1 addr2 -- )
     item% %size +loop ;      ['] stack-out compute-offset ;
   
 : clear-stack { -- }  : clear-stack { -- }
     dup stack-in off stack-out off ;      dup stack-in off stack-out off ;
Line 545 
Line 549 
 : compute-offsets ( -- )  : compute-offsets ( -- )
     data-stack clear-stack  fp-stack clear-stack return-stack clear-stack      data-stack clear-stack  fp-stack clear-stack return-stack clear-stack
     inst-stream clear-stack      inst-stream clear-stack
     effect-in  effect-in-end  @ ['] stack-in  compute-list      effect-in  effect-in-end  @ ['] compute-offset-in  map-items
     effect-out effect-out-end @ ['] stack-out compute-list      effect-out 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<> abort" # can only be on the input side" ;
   
 : flush-a-tos { stack -- }  : flush-a-tos { stack -- }
Line 578 
Line 582 
  dup item-type @ type-fetch @ execute ;   dup item-type @ type-fetch @ execute ;
   
 : fetches ( -- )  : fetches ( -- )
  effect-in-end @ effect-in ?do      effect-in effect-in-end @ ['] fetch map-items ;
    i fetch  
  item% %size +loop ;  
   
 : stack-pointer-update { stack -- }  : stack-pointer-update { stack -- }
     \ stack grow downwards      \ stack grow downwards
Line 606 
Line 608 
  dup item-type @ type-store @ execute ;   dup item-type @ type-store @ execute ;
   
 : stores ( -- )  : stores ( -- )
  effect-out-end @ effect-out ?do      effect-out effect-out-end @ ['] store map-items ;
    i store  
  item% %size +loop ;  
   
 : output-c-tail ( -- )  : output-c-tail ( -- )
     \ the final part of the generated C code      \ the final part of the generated C code
Line 640 
Line 640 
 : print-debug-args ( -- )  : print-debug-args ( -- )
     ." #ifdef VM_DEBUG" cr      ." #ifdef VM_DEBUG" cr
     ." if (vm_debug) {" cr      ." if (vm_debug) {" cr
     effect-in-end @ effect-in ?do      effect-in effect-in-end @ ['] print-debug-arg map-items
         i print-debug-arg  
         item% %size +loop  
     ." fputc('\n', vm_out);" cr      ." fputc('\n', vm_out);" cr
     ." }" cr      ." }" cr
     ." #endif" cr ;      ." #endif" cr ;
Line 678 
Line 676 
     endif ;      endif ;
   
 : disasm-args ( -- )  : disasm-args ( -- )
  effect-in-end @ effect-in ?do      effect-in effect-in-end @ ['] disasm-arg map-items ;
    i disasm-arg  
  item% %size +loop ;  
   
 : output-disasm ( -- )  : output-disasm ( -- )
     \ generate code for disassembling VM instructions      \ generate code for disassembling VM instructions
Line 700 
Line 696 
     endif ;      endif ;
   
 : gen-args-parm ( -- )  : gen-args-parm ( -- )
  effect-in-end @ effect-in ?do      effect-in effect-in-end @ ['] gen-arg-parm map-items ;
    i gen-arg-parm  
  item% %size +loop ;  
   
 : gen-arg-gen { item -- }  : gen-arg-gen { item -- }
     item item-stack @ inst-stream = if      item item-stack @ inst-stream = if
Line 711 
Line 705 
     endif ;      endif ;
   
 : gen-args-gen ( -- )  : gen-args-gen ( -- )
  effect-in-end @ effect-in ?do      effect-in effect-in-end @ ['] gen-arg-gen map-items ;
    i gen-arg-gen  
  item% %size +loop ;  
   
 : output-gen ( -- )  : output-gen ( -- )
     \ generate C code for generating VM instructions      \ generate C code for generating VM instructions

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help