--- gforth/prims2x.fs	2001/01/23 10:05:36	1.72
+++ gforth/prims2x.fs	2001/02/06 16:53:06	1.77
@@ -50,6 +50,7 @@ warnings off
 include ./search.fs			
 include ./extend.fs
 [THEN]
+include ./stuff.fs
 
 [IFUNDEF] environment?
 include ./environ.fs
@@ -125,7 +126,7 @@ variable output-combined \ xt ( -- ) of
 struct%
     cell%    field stack-number \ the number of this stack
     cell% 2* field stack-pointer \ stackpointer name
-    cell% 2* field stack-typename \ name for default type of stack items
+    cell%    field stack-type \ name for default type of stack items
     cell% 2* field stack-cast \ cast string for assignments to stack elements
     cell%    field stack-in-index-xt \ ( in-size item -- in-index )
 end-struct stack%
@@ -155,22 +156,15 @@ create stacks max-stacks cells allot \ a
 : inst-in-index ( in-size item -- in-index )
     nip dup item-offset @ swap item-type @ type-size @ + 1- ;
 
-: make-stack ( addr-ptr u1 addr-stack u2 addr-cast u3 "stack-name" -- )
+: make-stack ( addr-ptr u1 type addr-cast u2 "stack-name" -- )
     create stack% %allot >r
     r@ stacks next-stack-number @ th !
     next-stack-number @ r@ stack-number !  1 next-stack-number +!
     save-mem r@ stack-cast 2!
-    save-mem r@ stack-typename 2!
+    r@ stack-type !
     save-mem r@ stack-pointer 2! 
     ['] stack-in-index r> stack-in-index-xt ! ;
 
-s" sp" save-mem s" Cell"  save-mem s" (Cell)" make-stack data-stack 
-s" fp" save-mem s" Float" save-mem s" "       make-stack fp-stack
-s" rp" save-mem s" Cell"  save-mem s" (Cell)" make-stack return-stack
-s" IP" save-mem s" Cell"  save-mem s" error don't use # on results" make-stack inst-stream
-' inst-in-index inst-stream stack-in-index-xt !
-\ !! initialize stack-in and stack-out
-
 \ stack items
 
 : init-item ( addr u addr1 -- )
@@ -185,6 +179,11 @@ s" IP" save-mem s" Cell"  save-mem s" er
 	i xt execute
     item% %size +loop ;
 
+\ types
+
+: print-type-prefix ( type -- )
+    body> >head name>string type ;
+
 \ various variables for storing stuff of one primitive
 
 struct%
@@ -195,6 +194,7 @@ struct%
     cell% 2* field prim-c-code
     cell% 2* field prim-forth-code
     cell% 2* field prim-stack-string
+    cell%    field prim-items-wordlist \ unique items
     item% max-effect * field prim-effect-in
     item% max-effect * field prim-effect-out
     cell%    field prim-effect-in-end
@@ -234,11 +234,6 @@ variable name-line
 2variable last-name-filename
 Variable function-number 0 function-number !
 
-\ for several reasons stack items of a word are stored in a wordlist
-\ since neither forget nor marker are implemented yet, we make a new
-\ wordlist for every word and store it in the variable items
-variable items
-
 \ a few more set ops
 
 : bit-equivalent ( w1 w2 -- w3 )
@@ -268,10 +263,10 @@ variable items
  \ fetch a single stack item from its stack
  >r
  r@ item-name 2@ type
- ."  = (" 
- r@ item-type @ type-c-name 2@ type ." ) "
+ ."  = vm_" r@ item-stack @ stack-type @ type-c-name 2@ type
+ ." 2" r@ item-type @ print-type-prefix ." ("
  r@ item-in-index r@ item-stack @ stack-access
- ." ;" cr
+ ." );" cr
  rdrop ; 
 
 : fetch-double ( item -- )
@@ -287,8 +282,10 @@ variable items
 : same-as-in? ( item -- f )
  \ f is true iff the offset and stack of item is the same as on input
  >r
- r@ item-name 2@ items @ search-wordlist 0=
- abort" bug"
+ r@ item-first @ if
+     rdrop false exit
+ endif
+ r@ item-name 2@ prim prim-items-wordlist @ search-wordlist 0= abort" bug"
  execute @
  dup r@ =
  if \ item first appeared in output
@@ -305,9 +302,10 @@ variable items
 
 : really-store-single ( item -- )
  >r
- r@ item-out-index r@ item-stack @ stack-access ."  = "
- r@ item-stack @ stack-cast 2@ type
- r@ item-name 2@ type ." ;"
+ r@ item-out-index r@ item-stack @ stack-access ."  = vm_"
+ r@ item-type @ print-type-prefix ." 2"
+ r@ item-stack @ stack-type @ type-c-name 2@ type ." ("
+ r@ item-name 2@ type ." );"
  rdrop ;
 
 : store-single ( item -- )
@@ -375,7 +373,7 @@ does> ( item -- )
     { item typ }
     typ item item-type !
     typ type-stack @ item item-stack !default
-    item item-name 2@ items @ search-wordlist 0= if \ new name
+    item item-name 2@ prim prim-items-wordlist @ search-wordlist 0= if
 	item item-name 2@ nextname item declare
 	item item-first on
 	\ typ type-c-name 2@ type space type  ." ;" cr
@@ -404,7 +402,7 @@ does> ( item -- )
     ['] declaration map-items ;
 
 : declarations ( -- )
- wordlist dup items ! set-current
+ wordlist dup prim prim-items-wordlist ! set-current
  prim prim-effect-in prim prim-effect-in-end @ declaration-list
  prim prim-effect-out prim prim-effect-out-end @ declaration-list ;
 
@@ -426,6 +424,17 @@ does> ( item -- )
     stack item item-stack !
     item declaration ;
 
+\ types pointed to by stacks for use in combined prims
+s" Cell"  single 0 create-type cell-type
+s" Float" single 0 create-type float-type
+
+s" sp" save-mem cell-type  s" (Cell)" make-stack data-stack 
+s" fp" save-mem float-type s" "       make-stack fp-stack
+s" rp" save-mem cell-type  s" (Cell)" make-stack return-stack
+s" IP" save-mem cell-type  s" error don't use # on results" make-stack inst-stream
+' inst-in-index inst-stream stack-in-index-xt !
+\ !! initialize stack-in and stack-out
+
 \ offset computation
 \ the leftmost (i.e. deepest) item has offset 0
 \ the rightmost item has the highest offset
@@ -528,9 +537,6 @@ does> ( item -- )
     repeat
     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
@@ -820,7 +826,7 @@ create min-depth     max-stacks cells al
 	i 0 <# #s stack stack-pointer 2@ holds [char] _ hold #> save-mem
 	item item-name 2!
 	stack item item-stack !
-	0 item item-type !
+	stack stack-type @ item item-type !
 	i item item-offset !
 	item item-first on
 	item% %size effect-endp +!
@@ -842,7 +848,7 @@ create min-depth     max-stacks cells al
 
 : print-item { n stack -- }
     \ print nth stack item name
-    ." _" stack stack-typename 2@ type space
+    ." _" stack stack-type @ type-c-name 2@ type space
     stack stack-pointer 2@ type n 0 .r ;
 
 : print-declarations-combined ( -- )
@@ -852,16 +858,29 @@ create min-depth     max-stacks cells al
 	loop
     loop ;
     
+: output-parts ( -- )
+    prim >r
+    num-combined @ 0 +do
+	combined-prims i th @ to prim
+	output-c
+    loop
+    r> to prim ;
+
 : output-c-combined ( -- )
     print-entry cr
-    \ debugging messages just in constituents
+    \ debugging messages just in parts
     ." {" cr
     ." DEF_CA" cr
     print-declarations-combined
     ." NEXT_P0;" cr
     flush-tos
     fetches
-    ;
+    \ print-debug-args
+    stack-pointer-updates
+    output-parts
+    output-c-tail
+    ." }" cr
+    cr ;
 
 : output-forth-combined ( -- )
     ;