--- gforth/prims2x.fs	2005/12/31 15:46:10	1.160
+++ gforth/prims2x.fs	2007/12/31 17:34:58	1.168
@@ -1,6 +1,6 @@
 \ converts primitives to, e.g., C code 
 
-\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005 Free Software Foundation, Inc.
+\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007 Free Software Foundation, Inc.
 
 \ This file is part of Gforth.
 
@@ -55,6 +55,12 @@
 \ 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
@@ -138,15 +144,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 ;
 
@@ -205,6 +209,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%
@@ -366,7 +371,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 ( -- )
@@ -504,8 +509,8 @@ 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 ;
@@ -680,7 +685,7 @@ get-current prefixes set-current
 set-current
 
 create ...-item ( -- addr ) \ just used for letting stack-prefixes work on it
-item% %allot                \ stores the stack temporarily until used by ...
+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
@@ -755,11 +760,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 ;
 
@@ -1462,6 +1474,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 ;
@@ -1842,15 +1855,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
@@ -1859,9 +1875,10 @@ 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
@@ -1879,7 +1896,7 @@ Variable c-flag
 (( {{ 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 }}