--- gforth/prims2x.fs	2004/08/26 15:29:57	1.151
+++ gforth/prims2x.fs	2009/12/31 15:32:35	1.171
@@ -1,12 +1,12 @@
 \ 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,2005,2006,2007,2009 Free Software Foundation, Inc.
 
 \ This file is part of Gforth.
 
 \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License
-\ as published by the Free Software Foundation; either version 2
+\ as published by the Free Software Foundation, either version 3
 \ of the License, or (at your option) any later version.
 
 \ This program is distributed in the hope that it will be useful,
@@ -15,8 +15,7 @@
 \ GNU General Public License for more details.
 
 \ You should have received a copy of the GNU General Public License
-\ along with this program; if not, write to the Free Software
-\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+\ along with this program. If not, see http://www.gnu.org/licenses/.
 
 
 \ This is not very nice (hard limits, no checking, assumes 1 chars = 1).
@@ -51,9 +50,16 @@
 \ (stack-in-index-xt and a test for stack==instruction-stream); there
 \ should be only one.
 
+
 \ for backwards compatibility, jaw
 require compat/strcomp.fs
 
+[undefined] outfile-execute [if]
+    : outfile-execute ( ... xt file-id -- ... )
+	\ unsafe replacement
+	outfile-id >r to outfile-id execute r> to outfile-id ;
+[then]
+
 warnings off
 
 \ redefinitions of kernel words not present in gforth-0.6.1
@@ -102,6 +108,9 @@ variable include-skipped-insts
 \ inline arguments (false)
 include-skipped-insts off
 
+2variable threaded-code-pointer-type \ type used for geninst etc.
+s" Inst **" threaded-code-pointer-type 2!
+
 variable immarg \ values for immediate arguments (to be used in IMM_ARG macros)
 $12340000 immarg !
 
@@ -134,15 +143,13 @@ $12340000 immarg !
     over - type cr
     line-start @ rawinput @ over - typewhite ." ^" cr ;
 
+: print-error { addr u -- }
+    filename 2@ type ." :" line @ 0 .r ." : " addr u type cr
+    print-error-line ;
+
 : ?print-error { f addr u -- }
     f ?not? if
-	outfile-id >r try
-	    stderr to outfile-id
-	    filename 2@ type ." :" line @ 0 .r ." : " addr u type cr
-	    print-error-line
-	    0
-	recover endtry
-	r> to outfile-id throw
+	addr u ['] print-error stderr outfile-execute
 	1 (bye) \ abort
     endif ;
 
@@ -201,6 +208,7 @@ struct%
 end-struct ss% \ stack-state
 
 struct%
+    cell%              field state-enabled
     cell%              field state-number
     cell% max-stacks * field state-sss
 end-struct state%
@@ -231,13 +239,13 @@ variable next-state-number 0 next-state-
     rdrop ;
 
 : map-stacks { xt -- }
-    \ perform xt for all stacks
+    \ perform xt ( stack -- ) for all stacks
     next-stack-number @ 0 +do
 	stacks i th @ xt execute
     loop ;
 
 : map-stacks1 { xt -- }
-    \ perform xt for all stacks except inst-stream
+    \ perform xt ( stack -- ) for all stacks except inst-stream
     next-stack-number @ 1 +do
 	stacks i th @ xt execute
     loop ;
@@ -246,7 +254,7 @@ variable next-state-number 0 next-state-
 
 : init-item ( addr u addr1 -- )
     \ initialize item at addr1 with name addr u
-    \ !! remove stack prefix
+    \ the stack prefix is removed by the stack-prefix
     dup item% %size erase
     item-name 2! ;
 
@@ -280,6 +288,7 @@ struct%
     cell%    field prim-effect-out-end
     cell% max-stacks * field prim-stacks-in  \ number of in items per stack
     cell% max-stacks * field prim-stacks-out \ number of out items per stack
+    cell% max-stacks * field prim-stacks-sync \ sync flag per stack
 end-struct prim%
 
 : make-prim ( -- prim )
@@ -350,6 +359,9 @@ wordlist constant primitives
     \ address of number of stack items in effect out
     stack-number @ cells prim prim-stacks-out + ;
 
+: stack-prim-stacks-sync ( stack -- addr )
+    prim prim-stacks-sync swap stack-number @ th ;
+
 \ global vars
 variable c-line
 2variable c-filename
@@ -358,7 +370,7 @@ variable name-line
 2variable last-name-filename
 Variable function-number 0 function-number !
 Variable function-old 0 function-old !
-: function-diff ( n -- )
+: function-diff ( -- )
     ." GROUPADD(" function-number @ function-old @ - 0 .r ." )" cr
     function-number @ function-old ! ;
 : forth-fdiff ( -- )
@@ -496,28 +508,31 @@ defer inst-stream-f ( -- stack )
     ." vm_two"
     r@ item-stack-type-name type ." 2"
     r@ item-type @ print-type-prefix ." ("
-    r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-read
-    ." , "                      -1 under+ ." (Cell)" stack-read
+    r@ item-in-index r@ item-stack @ 2dup stack-read
+    ." , "                      -1 under+ stack-read
     ." , " r@ item-name 2@ type
     ." )" cr
     rdrop ;
 
 : same-as-in? ( item -- f )
- \ f is true iff the offset and stack of item is the same as on input
- >r
- 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
-   drop false
- else
-   dup  item-stack  @ r@ item-stack  @ = 
-   swap item-offset @ r@ item-offset @ = and
- endif
- rdrop ;
+    \ f is true iff the offset and stack of item is the same as on input
+    >r
+    r@ item-stack @ stack-prim-stacks-sync @ if
+	rdrop false exit
+    endif
+    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
+	drop false
+    else
+	dup  item-stack  @ r@ item-stack  @ = 
+	swap item-offset @ r@ item-offset @ = and
+    endif
+    rdrop ;
 
 : item-out-index ( item -- n )
     \ n is the index of item (in the out-effect)
@@ -615,7 +630,8 @@ does> ( item -- )
 	    UNLOOP EXIT
 	endif
 	-1 s+loop
-    \ we did not find a type, abort
+	\ we did not find a type, abort
+	abort
     false s" unknown prefix" ?print-error ;
 
 : declaration ( item -- )
@@ -649,6 +665,38 @@ does> ( item -- )
     stack item item-stack !
     item declaration ;
 
+: set-prim-stacks-sync ( stack -- )
+    stack-prim-stacks-sync on ;
+
+: clear-prim-stacks-sync ( stack -- )
+    stack-prim-stacks-sync off ;
+
+
+get-current prefixes set-current
+: ... ( item -- )
+    \ this "prefix" ensures that the appropriate stack is synced with memory
+    dup item-name 2@ s" ..." str= 0= abort" '...' must end the item name"
+    item-stack @ dup if
+	set-prim-stacks-sync
+    else \ prefixless "..." syncs all stacks
+	drop ['] set-prim-stacks-sync map-stacks1
+    endif ;
+set-current
+
+create ...-item ( -- addr ) \ just used for letting stack-prefixes work on it
+item% %allot drop           \ stores the stack temporarily until used by ...
+
+: init-item1 ( addr1 addr u -- addr2 )
+    \ initialize item at addr1 with name addr u, next item is at addr2
+    \ !! make sure that any mention of "..." is only stack-prefixed
+    2dup s" ..." search nip nip if ( addr1 addr u )
+	0 ...-item item-stack ! \ initialize to prefixless
+	2dup ...-item item-name 2!
+	...-item rot rot execute-prefix ( addr1 )
+    else
+	2 pick init-item item% %size +
+    endif ;
+
 \ types pointed to by stacks for use in combined prims
 \ !! output-c-combined shouldn't use these names!
 : stack-type-name ( addr u "name" -- )
@@ -711,11 +759,18 @@ stack inst-stream IP Cell
 : state ( "name" -- )
     \ create a state initialized with default-sss
     create state% %allot { s }
+    s state-enabled on
     next-state-number @ s state-number ! 1 next-state-number +!
     max-stacks 0 ?do
 	default-ss s state-sss i th !
     loop ;
 
+: state-disable ( state -- )
+    state-enabled off ;
+
+: state-enabled? ( state -- f )
+    state-enabled @ ;
+
 : .state ( state -- )
     0 >body - >name .name ;
 
@@ -745,6 +800,10 @@ stack inst-stream IP Cell
     prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items
     inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
 
+: init-simple { prim -- }
+    \ much of the initialization is elsewhere
+    ['] clear-prim-stacks-sync map-stacks ;
+
 : process-simple ( -- )
     prim prim { W^ key } key cell
     combinations ['] constant insert-wordlist
@@ -760,11 +819,19 @@ stack inst-stream IP Cell
     stack state-in  stack-state-items stack stack-in  @ - 0 max
     stack state-out stack-state-items stack stack-out @ - 0 max ;
 
+: spill-stack-items { stack -- u }
+    \ there are u items to spill in stack
+    stack unused-stack-items
+    stack stack-prim-stacks-sync @ if
+	drop 0
+    endif
+    swap - ;
+
 : spill-stack { stack -- }
     \ spill regs of state-in that are not used by prim and are not in state-out
     stack state-in stack-offset { offset }
     stack state-in stack-state-items ( items )
-    dup stack unused-stack-items - - +do
+    dup stack spill-stack-items + +do
 	\ loop through the bottom items
 	stack stack-pointer 2@ type
 	i offset - stack normal-stack-access0 ."  = "
@@ -774,10 +841,18 @@ stack inst-stream IP Cell
 : spill-state ( -- )
     ['] spill-stack map-stacks1 ;
 
+: fill-stack-items { stack -- u }
+    \ there are u items to fill in stack
+    stack unused-stack-items
+    stack stack-prim-stacks-sync @ if
+	swap drop 0 swap
+    endif
+    - ;
+
 : fill-stack { stack -- }
     stack state-out stack-offset { offset }
     stack state-out stack-state-items ( items )
-    dup stack unused-stack-items - + +do
+    dup stack fill-stack-items + +do
 	\ loop through the bottom items
 	i stack state-out normal-stack-access1 ."  = "
 	stack stack-pointer 2@ type
@@ -833,25 +908,45 @@ stack inst-stream IP Cell
     stack-access-transform @ dup >r execute
     0 r> execute - ;
 
-: stack-pointer-update { stack -- }
-    \ and moves
-    \ stacks grow downwards
-    stack stack-diff ( in-out )
-    stack state-in  stack-offset -
-    stack state-out stack-offset + ( [in-in_offset]-[out-out_offset] )
-    ?dup-if \ this check is not necessary, gcc would do this for us
+: update-stack-pointer { stack n -- }
+    n if \ this check is not necessary, gcc would do this for us
 	stack inst-stream = if
-	    ." INC_IP(" 0 .r ." );" cr
+	    ." INC_IP(" n 0 .r ." );" cr
 	else
 	    stack stack-pointer 2@ type ."  += "
-	    stack stack-update-transform 0 .r ." ;" cr
+	    n stack stack-update-transform 0 .r ." ;" cr
 	endif
-    endif
-    stack stack-moves ;
+    endif ;
+
+: stack-pointer-update { stack -- }
+    \ and moves
+    \ stacks grow downwards
+    stack stack-prim-stacks-sync @ if
+	stack stack-in @
+	stack state-in  stack-offset -
+	stack swap update-stack-pointer
+    else
+	stack stack-diff ( in-out )
+	stack state-in  stack-offset -
+	stack state-out stack-offset + ( [in-in_offset]-[out-out_offset] )
+	stack swap update-stack-pointer
+	stack stack-moves
+    endif ;
 
 : stack-pointer-updates ( -- )
     ['] stack-pointer-update map-stacks ;
 
+: stack-pointer-update2 { stack -- }
+    stack stack-prim-stacks-sync @ if
+	stack state-out stack-offset
+	stack stack-out @ -
+	stack swap update-stack-pointer
+    endif ;
+
+: stack-pointer-updates2 ( -- )
+    \ update stack pointers after C code, where necessary
+    ['] stack-pointer-update2 map-stacks ;
+
 : store ( item -- )
 \ f is true if the item should be stored
 \ f is false if the store is probably not necessary
@@ -913,17 +1008,30 @@ 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.
     output-super-end
     print-debug-results
     output-nextp1
+    stack-pointer-updates2
     stores
     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
@@ -935,7 +1043,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 ;
@@ -962,9 +1074,15 @@ variable tail-nextp2 \ xt to execute for
 
 : print-entry ( -- )
     ." LABEL(" prim prim-c-name 2@ type ." )" ;
-    
-: output-c ( -- ) 
-    print-entry ."  /* " prim prim-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@ prim-type
     ."  ( " prim prim-stack-string 2@ type ." ) "
     state-in .state ." -- " state-out .state ."  */" cr
     ." /* " prim prim-doc 2@ type ."  */" cr
@@ -1044,7 +1162,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
@@ -1066,9 +1184,10 @@ variable tail-nextp2 \ xt to execute for
 
 : output-gen ( -- )
     \ generate C code for generating VM instructions
-    ." void gen_" prim prim-c-name 2@ type ." (Inst **ctp" gen-args-parm ." )" cr
+    ." void gen_" prim prim-c-name 2@ type ." ("
+    threaded-code-pointer-type 2@ type ." ctp" gen-args-parm ." )" cr
     ." {" cr
-    ."   gen_inst(ctp, vm_prim[" function-number @ 0 .r ." ]);" cr
+    ."   gen_inst(ctp, " function-number @ 0 .r ." );" cr
     gen-args-gen
     ." }" cr ;
 
@@ -1354,6 +1473,7 @@ variable reprocessed-num 0 reprocessed-n
 
 : state-prim1 { in-state out-state prim -- }
     in-state out-state state-default dup d= ?EXIT
+    in-state state-enabled? out-state state-enabled? and 0= ?EXIT
     in-state  to state-in
     out-state to state-out
     prim reprocess-simple ;
@@ -1372,6 +1492,9 @@ variable reprocessed-num 0 reprocessed-n
 : compute-default-state-out ( n-in -- n-out )
     \ for the current prim
     cache-stack stack-in @ - 0 max
+    cache-stack stack-prim-stacks-sync @ if
+	drop 0
+    endif
     cache-stack stack-out @ + cache-states 2@ nip 1- min ;
 
 : gen-prim-states ( prim -- )
@@ -1432,8 +1555,8 @@ variable reprocessed-num 0 reprocessed-n
     stores ;
 
 : output-combined-tail ( -- )
-    part-output-c-tail
     in-part @ >r in-part off
+    part-output-c-tail
     combined ['] output-c-tail-no-stores prim-context
     r> in-part ! ;
 
@@ -1450,7 +1573,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
@@ -1558,7 +1681,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
 
@@ -1698,7 +1821,11 @@ nl-char singleton eof-char over add-memb
 (( letter (( letter || digit )) **
 )) <- c-ident ( -- )
 
-(( ` # ?? (( letter || digit || ` : )) ++
+(( ` . ` . ` .
+)) <- sync-stack ( -- )
+
+(( ` # ?? (( letter || digit || ` : )) ++ sync-stack ??
+|| sync-stack
 )) <- stack-ident ( -- )
 
 (( nowhitebq nowhite ** ))
@@ -1727,15 +1854,18 @@ Variable c-flag
 )) <- else-comment
 
 (( ` + {{ start }} nonl ** {{ end
-	dup
-	IF	c-flag @
-	    IF
-		function-diff
-		." #ifdef HAS_" bounds ?DO  I c@ toupper emit  LOOP cr
-		THEN
-		forth-flag @
-		IF  forth-fdiff  ." has? " type ."  [IF]"  cr THEN
-	ELSE	2drop
+        dup
+        IF
+            c-flag @ IF
+                function-diff
+                ." #ifdef HAS_" 2dup bounds ?DO  I c@ toupper emit  LOOP cr
+            THEN
+            forth-flag @ IF
+                forth-fdiff  ." has? " 2dup type ."  [IF]"  cr
+            THEN
+            2drop
+        ELSE
+            2drop
 	    c-flag @      IF
 		function-diff  ." #endif" cr THEN
 	    forth-flag @  IF  forth-fdiff  ." [THEN]"  cr THEN
@@ -1744,27 +1874,28 @@ Variable c-flag
 
 (( (( ` g || ` G )) {{ start }} nonl **
    {{ end
-      forth-flag @ IF  forth-fdiff  ." group " type cr  THEN
+      forth-flag @ IF  forth-fdiff  ." group " 2dup type cr  THEN
       c-flag @     IF  function-diff
-	  ." GROUP(" type ." , " function-number @ 0 .r ." )" cr  THEN }}
+          ." GROUP(" 2dup type ." , " function-number @ 0 .r ." )" cr  THEN
+      2drop }}
 )) <- group-comment
 
 (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body
 
 (( ` \ comment-body nleof )) <- comment ( -- )
 
-(( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) **
-<- stack-items
+(( {{ start }} stack-ident {{ end init-item1 }} white ** )) **
+<- stack-items ( addr1 -- addr2 )
 
 (( {{ prim prim-effect-in }}  stack-items {{ prim prim-effect-in-end ! }}
    ` - ` - white **
    {{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }}
 )) <- stack-effect ( -- )
 
-(( {{ prim create-prim }}
+(( {{ prim create-prim prim init-simple }}
    ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white **
    (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white **
-      (( {{ start }}  c-ident {{ end 2dup prim-c-name-2! }} )) ??
+      (( {{ start }}  c-ident {{ end prim-c-name-2! }} )) ??
    )) ??  nleof
    (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ??
    {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }}