--- gforth/prims2x.fs	2003/10/16 18:48:03	1.146
+++ gforth/prims2x.fs	2005/01/26 21:24:15	1.155
@@ -1,6 +1,6 @@
 \ 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.
 
@@ -535,8 +535,8 @@ defer inst-stream-f ( -- stack )
 : store-single { item -- }
     item item-stack @ { stack }
     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-out-index stack state-out stack-reg 0= and \ out in memory?
+    item item-in-index  stack state-in  stack-reg       \  in reg/mem
+    item item-out-index stack state-out stack-reg = and \ out reg/mem
     0= if
 	item really-store-single cr
     endif ;
@@ -716,6 +716,9 @@ stack inst-stream IP Cell
 	default-ss s state-sss i th !
     loop ;
 
+: .state ( state -- )
+    0 >body - >name .name ;
+
 : set-ss ( ss stack state -- )
     state-sss swap stack-number @ th ! ;
 
@@ -910,7 +913,9 @@ variable tail-nextp2 \ xt to execute for
 
 : output-label2 ( -- )
     ." 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 -- }
     \ the final part of the generated C code, with xt printing LABEL2 or not.
@@ -921,6 +926,16 @@ variable tail-nextp2 \ xt to execute for
     fill-state 
     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 -- }
     \ the final part of the generated C code for combinations
     output-super-end
@@ -932,7 +947,11 @@ variable tail-nextp2 \ xt to execute for
     tail-nextp2 @ output-c-tail1 ;
 
 : 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 ( -- )
     tail-nextp2 @ output-c-tail1-no-stores ;
@@ -959,9 +978,17 @@ variable tail-nextp2 \ xt to execute for
 
 : print-entry ( -- )
     ." 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 ( -- ) 
-    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
     ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
     ." {" cr
@@ -1039,7 +1066,7 @@ variable tail-nextp2 \ xt to execute for
     prim prim-branch?
     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
-    negate 0 .r ." , /* " prim prim-name 2@ type ."  */" cr ;
+    negate 0 .r ." , /* " prim prim-name 2@ prim-type ."  */" cr ;
 
 : gen-arg-parm { item -- }
     item item-stack @ inst-stream = if
@@ -1110,8 +1137,11 @@ variable tail-nextp2 \ xt to execute for
 : output-alias ( -- ) 
     ( 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 ;
+is output-c-prim-num
 
 : output-forth ( -- )  
     prim prim-forth-code @ 0=
@@ -1442,7 +1472,7 @@ variable reprocessed-num 0 reprocessed-n
 
 : output-part ( p -- )
     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
     ." {" cr
     print-declarations
@@ -1550,7 +1580,7 @@ variable reprocessed-num 0 reprocessed-n
     \ prim-num @ 4 .r ." ," ;
 
 : 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
 
@@ -1559,7 +1589,9 @@ variable offset-super2  0 offset-super2
     rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , "
     prim prim-branch? negate . ." ,"
     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-prefix
@@ -1575,14 +1607,15 @@ variable offset-super2  0 offset-super2
     output-name-comment
     cr ;
 
-: output-costs ( -- )
-    \ description of superinstructions and simple instructions
-    ." {" prim compute-costs
-    rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ,"
-    offset-super2 @ 5 .r ." ,"
-    super2-length dup 2 .r ." }," offset-super2 +!
-    output-name-comment
-    cr ;
+\  : output-costs ( -- )
+\      \ description of superinstructions and simple instructions
+\      ." {" prim compute-costs
+\      rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ,"
+\      offset-super2 @ 5 .r ." ,"
+\      super2-length dup 2 .r ." ," offset-super2 +!
+\      inst-stream stack-in @ 1 .r ." },"
+\      output-name-comment
+\      cr ;
 
 : output-super2-simple ( -- )
     prim prim-c-name 2@ prim prim-c-name-orig 2@ d= if