Diff for /gforth/prims2x.fs between versions 1.105 and 1.109

version 1.105, 2002/06/02 10:31:28 version 1.109, 2002/08/19 07:38:15
Line 312  defer inst-stream-f ( -- stack ) Line 312  defer inst-stream-f ( -- stack )
     item-stack @ stack-type @ type-c-name 2@ ;      item-stack @ stack-type @ type-c-name 2@ ;
   
 : fetch-single ( item -- )  : fetch-single ( item -- )
  \ fetch a single stack item from its stack      \ fetch a single stack item from its stack
  >r      >r
  r@ item-name 2@ type      ." vm_" r@ item-stack-type-name type
  ."  = vm_" r@ item-stack-type-name type      ." 2" r@ item-type @ print-type-prefix ." ("
  ." 2" r@ item-type @ print-type-prefix ." ("      r@ item-in-index r@ item-stack @ stack-access ." ,"
  r@ item-in-index r@ item-stack @ stack-access      r@ item-name 2@ type
  ." );" cr      ." );" cr
  rdrop ;       rdrop ; 
   
 : fetch-double ( item -- )  : fetch-double ( item -- )
  \ fetch a double stack item from its stack      \ fetch a double stack item from its stack
  >r      >r
  ." vm_two"      ." vm_two"
  r@ item-stack-type-name type ." 2"      r@ item-stack-type-name type ." 2"
  r@ item-type @ print-type-prefix ." ("      r@ item-type @ print-type-prefix ." ("
  r@ item-name 2@ type ." , "      r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access
  r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access      ." , "                      -1 under+ ." (Cell)" stack-access
  ." , "                      -1 under+ ." (Cell)" stack-access      ." , " r@ item-name 2@ type
  ." );" cr      ." )" cr
  rdrop ;      rdrop ;
   
 : same-as-in? ( item -- f )  : same-as-in? ( item -- f )
  \ f is true iff the offset and stack of item is the same as on input   \ f is true iff the offset and stack of item is the same as on input
Line 355  defer inst-stream-f ( -- stack ) Line 355  defer inst-stream-f ( -- stack )
     >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ;      >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ;
   
 : really-store-single ( item -- )  : really-store-single ( item -- )
  >r      >r
  r@ item-out-index r@ item-stack @ stack-access ."  = vm_"      ." vm_"
  r@ item-type @ print-type-prefix ." 2"      r@ item-type @ print-type-prefix ." 2"
  r@ item-stack-type-name type ." ("      r@ item-stack-type-name type ." ("
  r@ item-name 2@ type ." );"      r@ item-name 2@ type ." ,"
  rdrop ;      r@ item-out-index r@ item-stack @ stack-access ." );"
       rdrop ;
   
 : store-single ( item -- )  : store-single ( item -- )
  >r   >r
Line 385  defer inst-stream-f ( -- stack ) Line 386  defer inst-stream-f ( -- stack )
  r@ item-name 2@ type ." , "   r@ item-name 2@ type ." , "
  r@ item-out-index r@ item-stack @ 2dup stack-access   r@ item-out-index r@ item-stack @ 2dup stack-access
  ." , "                       -1 under+ stack-access   ." , "                       -1 under+ stack-access
  ." );" cr   ." )" cr
  rdrop ;   rdrop ;
   
 : single ( -- xt1 xt2 n )  : single ( -- xt1 xt2 n )
Line 624  stack inst-stream IP Cell Line 625  stack inst-stream IP Cell
     endif      endif
     2drop ;      2drop ;
   
 : output-c-tail ( -- )  : output-c-tail1 ( -- )
     \ the final part of the generated C code      \ the final part of the generated C code except LABEL2 and NEXT_P2
     output-super-end      output-super-end
     print-debug-results      print-debug-results
     ." NEXT_P1;" cr      ." NEXT_P1;" cr
     stores      stores
     fill-tos      fill-tos ;
   
   : output-c-tail ( -- )
       \ the final part of the generated C code, without LABEL2
       output-c-tail1
     ." NEXT_P2;" ;      ." NEXT_P2;" ;
   
   : output-c-tail2 ( -- )
       \ the final part of the generated C code, including LABEL2
       output-c-tail1
       ." LABEL2(" prim prim-c-name 2@ type ." )" cr
       ." NEXT_P2;" cr ;
   
 : type-c-code ( c-addr u xt -- )  : type-c-code ( c-addr u xt -- )
     \ like TYPE, but replaces "TAIL;" with tail code produced by xt      \ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt
     { xt }      { xt }
     begin ( c-addr1 u1 )      begin ( c-addr1 u1 )
         2dup s" TAIL;" search          2dup s" INST_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
         xt execute          xt execute
         2r> 5 /string          2r> 10 /string
         \ !! resync #line missing          \ !! resync #line missing
     repeat      repeat
     2drop type ;      2drop type ;
   
 : print-entry ( -- )  : print-entry ( -- )
     ." LABEL(" prim prim-c-name 2@ type ." ):" ;      ." LABEL(" prim prim-c-name 2@ type ." )" ;
           
 : output-c ( -- )   : output-c ( -- ) 
  print-entry ."  /* " prim prim-name 2@ type ."  ( " prim prim-stack-string 2@ type ." ) */" cr   print-entry ."  /* " prim prim-name 2@ type ."  ( " prim prim-stack-string 2@ type ." ) */" cr
Line 665  stack inst-stream IP Cell Line 676  stack inst-stream IP Cell
  ." #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@ ['] output-c-tail type-c-code   prim prim-c-code 2@ ['] output-c-tail type-c-code
  ." }" cr   ." }" cr
  output-c-tail   output-c-tail2
  ." }" cr   ." }" cr
  cr   cr
 ;  ;
   
 : disasm-arg { item -- }  : disasm-arg { item -- }
     item item-stack @ inst-stream = if      item item-stack @ inst-stream = if
         ."   fputc(' ', vm_out); "          ." {" cr
         ." printarg_" item item-type @ print-type-prefix          item print-declaration
         ." ((" item item-type @ type-c-name 2@ type ." )"          item fetch
         ." ip[" item item-offset @ 1+ 0 .r ." ]);" cr          item print-debug-arg
           ." }" cr
     endif ;      endif ;
   
 : disasm-args ( -- )  : disasm-args ( -- )
Line 683  stack inst-stream IP Cell Line 695  stack inst-stream IP Cell
   
 : 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 (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
     ."   fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr      ."   fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr
     disasm-args      disasm-args
     ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr      ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
Line 897  stack inst-stream IP Cell Line 909  stack inst-stream IP Cell
 \  #line 516 "./prim"  \  #line 516 "./prim"
 \  n = n1+n2;  \  n = n1+n2;
 \  }  \  }
 \  NEXT_P1;  
 \  _x_sp0 = (Cell)n;  \  _x_sp0 = (Cell)n;
 \  NEXT_P2;  
 \  }  \  }
 \  NEXT_P1;  \  NEXT_P1;
 \  spTOS = (Cell)_x_sp0;  \  spTOS = (Cell)_x_sp0;
Line 1044  stack inst-stream IP Cell Line 1054  stack inst-stream IP Cell
     \ print-debug-args      \ print-debug-args
     stack-pointer-updates      stack-pointer-updates
     output-parts      output-parts
     output-c-tail      output-c-tail2
     ." }" cr      ." }" cr
     cr ;      cr ;
   

Removed from v.1.105  
changed lines
  Added in v.1.109


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