Diff for /gforth/prims2x.fs between versions 1.60 and 1.65

version 1.60, 2000/12/30 15:22:52 version 1.65, 2001/01/18 14:57:37
Line 68  variable rawinput \ pointer to next char Line 68  variable rawinput \ pointer to next char
 variable endrawinput \ pointer to the end of the input (the char after the last)  variable endrawinput \ pointer to the end of the input (the char after the last)
 variable cookedinput \ pointer to the next char to be parsed  variable cookedinput \ pointer to the next char to be parsed
 variable line \ line number of char pointed to by input  variable line \ line number of char pointed to by input
 1 line !  variable line-start \ pointer to start of current line (for error messages)
   0 line !
 2variable filename \ filename of original input file  2variable filename \ filename of original input file
 0 0 filename 2!  0 0 filename 2!
 2variable f-comment  2variable f-comment
Line 82  skipsynclines on Line 83  skipsynclines on
 : end ( addr -- addr u )  : end ( addr -- addr u )
  cookedinput @ over - ;   cookedinput @ over - ;
   
   : quote ( -- )
       [char] " emit ;
   
 variable output \ xt ( -- ) of output word  variable output \ xt ( -- ) of output word
   
 : printprim ( -- )  : printprim ( -- )
Line 125  end-struct type% Line 129  end-struct type%
 s" sp" save-mem s" (Cell)" make-stack data-stack   s" sp" save-mem s" (Cell)" make-stack data-stack 
 s" fp" save-mem s" "       make-stack fp-stack  s" fp" save-mem s" "       make-stack fp-stack
 s" rp" save-mem s" (Cell)" make-stack return-stack  s" rp" save-mem s" (Cell)" make-stack return-stack
 s" ip" save-mem s" error don't use # on results" make-stack inst-stream  s" IP" save-mem 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 !
 \ !! initialize stack-in and stack-out  \ !! initialize stack-in and stack-out
   
Line 137  s" ip" save-mem s" error don't use # on Line 141  s" ip" save-mem s" error don't use # on
     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 216  print-token ! Line 226  print-token !
     endif      endif
     drop ;      drop ;
   
   : print-error-line ( -- )
       \ print the current line and position
       line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end )
       over - type cr
       line-start @ rawinput @ over - typewhite ." ^" cr ;
       
 : ?nextchar ( f -- )  : ?nextchar ( f -- )
     ?not? if      ?not? if
         filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:"          outfile-id >r try
         getinput . cr              stderr to outfile-id
         rawinput @ endrawinput @ over - 100 min type cr              filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:"
               getinput . cr
               print-error-line
               0
           recover endtry
           r> to outfile-id throw
         abort          abort
     endif      endif
     rawinput @ endrawinput @ <> if      rawinput @ endrawinput @ <> if
Line 229  print-token ! Line 250  print-token !
         1 chars cookedinput +!          1 chars cookedinput +!
         nl-char = if          nl-char = if
             checksyncline              checksyncline
               rawinput @ line-start !
         endif          endif
         rawinput @ c@ cookedinput @ c!          rawinput @ c@ cookedinput @ c!
     endif ;      endif ;
Line 340  warnings @ [IF] Line 362  warnings @ [IF]
 : primfilter ( file-id xt -- )  : primfilter ( file-id xt -- )
 \ fileid is for the input file, xt ( -- ) is for the output word  \ fileid is for the input file, xt ( -- ) is for the output word
  output !   output !
  here dup rawinput ! cookedinput !   here dup rawinput ! dup line-start ! cookedinput !
  here unused rot read-file throw   here unused rot read-file throw
  dup here + endrawinput !   dup here + endrawinput !
  allot   allot
Line 383  warnings @ [IF] Line 405  warnings @ [IF]
  >r   >r
  ." FETCH_DCELL("   ." FETCH_DCELL("
  r@ item-name 2@ type ." , "   r@ item-name 2@ type ." , "
  r@ item-in-index r@ item-stack @ 2dup stack-access   r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access
  ." , "                      -1 under+ stack-access   ." , "                      -1 under+ ." (Cell)" stack-access
  ." );" cr   ." );" cr
  rdrop ;   rdrop ;
   
Line 502  does> ( item -- ) Line 524  does> ( item -- )
 : 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 509  does> ( item -- ) Line 539  does> ( item -- )
     item item-name 2@ prefix-length /string item item-name 2!      item item-name 2@ prefix-length /string item item-name 2!
     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
Line 530  does> ( item -- ) Line 550  does> ( item -- )
     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 542  does> ( item -- ) Line 562  does> ( item -- )
 : 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 575  does> ( item -- ) Line 595  does> ( item -- )
  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 603  does> ( item -- ) Line 621  does> ( item -- )
  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 626  does> ( item -- ) Line 642  does> ( item -- )
     repeat      repeat
     2drop type ;      2drop type ;
   
   : print-type-prefix ( type -- )
       body> >head .name ;
   
   : print-debug-arg { item -- }
       ." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); "
       ." printarg_" item item-type @ print-type-prefix
       ." (" item item-name 2@ type ." );" cr ;
       
   : print-debug-args ( -- )
       ." #ifdef VM_DEBUG" cr
       ." if (vm_debug) {" cr
       effect-in effect-in-end @ ['] print-debug-arg map-items
       ." fputc('\n', vm_out);" cr
       ." }" cr
       ." #endif" cr ;
       
 : output-c ( -- )   : output-c ( -- ) 
  ." I_" c-name 2@ type ." :     /* " forth-name 2@ type ."  ( " stack-string 2@ type ." ) */" cr   ." I_" c-name 2@ type ." :     /* " forth-name 2@ type ."  ( " stack-string 2@ type ." ) */" cr
  ." /* " doc 2@ type ."  */" cr   ." /* " doc 2@ type ."  */" cr
  ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging   ." NAME(" quote forth-name 2@ type quote ." )" cr \ debugging
  ." {" cr   ." {" cr
  ." DEF_CA" cr   ." DEF_CA" cr
  declarations   declarations
Line 637  does> ( item -- ) Line 669  does> ( item -- )
  ." NEXT_P0;" cr   ." NEXT_P0;" cr
  flush-tos   flush-tos
  fetches   fetches
    print-debug-args
  stack-pointer-updates   stack-pointer-updates
  ." {" cr   ." {" cr
  ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr   ." #line " c-line @ . quote c-filename 2@ type quote cr
  c-code 2@ type-c   c-code 2@ type-c
  ." }" cr   ." }" cr
  output-c-tail   output-c-tail
Line 647  does> ( item -- ) Line 680  does> ( item -- )
  cr   cr
 ;  ;
   
 : print-type-prefix ( type -- )  
     body> >head .name ;  
   
 : disasm-arg { item -- }  : disasm-arg { item -- }
     item item-stack @ inst-stream = if      item item-stack @ inst-stream = if
         ."   printarg_" item item-type @ print-type-prefix          ."   fputc(' ', vm_out); "
         ." (ip[" item item-offset @ 1+ 0 .r ." ]);" cr          ." printarg_" item item-type @ print-type-prefix
           ." ((" item item-type @ type-c-name 2@ type ." )"
           ." ip[" item item-offset @ 1+ 0 .r ." ]);" cr
     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
     ." if (ip[0] == prim[" function-number @ 0 .r ." ]) {" cr      ." if (ip[0] == prim[" function-number @ 0 .r ." ]) {" cr
     ."   fputs(" [char] " emit forth-name 2@ type [char] " emit ." ,stdout);" cr      ."   fputs(" quote forth-name 2@ type quote ." , vm_out);" cr
     ." /* " declarations ." */" cr      ." /* " declarations ." */" cr
     compute-offsets      compute-offsets
     disasm-args      disasm-args
Line 672  does> ( item -- ) Line 702  does> ( item -- )
     ." } else "      ." } else "
     1 function-number +! ;      1 function-number +! ;
   
   
   
   
 : gen-arg-parm { item -- }  : gen-arg-parm { item -- }
     item item-stack @ inst-stream = if      item item-stack @ inst-stream = if
         ." , " item item-type @ type-c-name 2@ type space          ." , " item item-type @ type-c-name 2@ type space
Line 682  does> ( item -- ) Line 709  does> ( item -- )
     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 693  does> ( item -- ) Line 718  does> ( item -- )
     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
Line 725  does> ( item -- ) Line 748  does> ( item -- )
     ." Cell * I_" c-name 2@ type ." (Cell *SP, Cell **FP)      /* " forth-name 2@ type      ." Cell * I_" c-name 2@ type ." (Cell *SP, Cell **FP)      /* " forth-name 2@ type
     ."  ( " stack-string 2@ type ."  ) */" cr      ."  ( " stack-string 2@ type ."  ) */" cr
     ." /* " doc 2@ type ."  */" cr      ." /* " doc 2@ type ."  */" cr
     ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr      ." NAME(" quote forth-name 2@ type quote ." )" cr
     \ debugging      \ debugging
     ." {" cr      ." {" cr
     declarations      declarations
Line 739  does> ( item -- ) Line 762  does> ( item -- )
     stack-pointer-updates      stack-pointer-updates
     fp-stack   stack-used? IF ." *FP=fp;" cr THEN      fp-stack   stack-used? IF ." *FP=fp;" cr THEN
     ." {" cr      ." {" cr
     ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr      ." #line " c-line @ . quote c-filename 2@ type quote cr
     c-code 2@ type      c-code 2@ type
     ." }" cr      ." }" cr
     stores      stores
Line 798  does> ( item -- ) Line 821  does> ( item -- )
   
 : process-file ( addr u xt -- )  : process-file ( addr u xt -- )
     >r      >r
     2dup filename 2!      save-mem 2dup filename 2!
     0 function-number !      0 function-number !
     r/o open-file abort" cannot open file"      r/o open-file abort" cannot open file"
     warnings @ if      warnings @ if

Removed from v.1.60  
changed lines
  Added in v.1.65


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