--- gforth/cross.fs	2002/09/14 08:20:18	1.128
+++ gforth/cross.fs	2003/03/01 11:57:42	1.137
@@ -1174,6 +1174,8 @@ false DefaultValue header
 false DefaultValue backtrace
 false DefaultValue new-input
 false DefaultValue peephole
+false DefaultValue abranch
+true  DefaultValue control-rack
 [THEN]
 
 true DefaultValue interpreter
@@ -1410,11 +1412,10 @@ T has? rom H
 
 \ MakeKernel                                           		22feb99jaw
 
-: makekernel ( targetsize -- )
+: makekernel ( start targetsize -- )
 \G convenience word to setup the memory of the target
 \G used by main.fs of the c-engine based systems
-  100 swap dictionary (region)
-  setup-target ;
+  dictionary (region) setup-target ;
 
 >MINIMAL
 : makekernel makekernel ;
@@ -1702,7 +1703,7 @@ Ghost (loop)    Ghost (+loop)
 Ghost (next)                                    drop
 Ghost (does>)   Ghost (compile)                 2drop
 Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
-Ghost (C")                                      drop
+Ghost (C")      Ghost c(abort") Ghost type      2drop drop
 Ghost '                                         drop
 
 \ user ghosts
@@ -1731,7 +1732,9 @@ Ghost state drop
 
 : ht-string,  ( addr count -- )
   dup there swap last-string 2!
-  dup T c, H bounds  ?DO  I c@ T c, H  LOOP ; 
+    dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;
+: ht-mem, ( addr count )
+    bounds ?DO  I c@  T c, H  LOOP ;
 
 >TARGET
 
@@ -2068,8 +2071,8 @@ s" kernel.TAGS" r/w create-file throw va
 s" kernel.tags" r/w create-file throw value vi-tag-file-id
 \ contains the file-id of the tags file
 
-Create tag-beg 2 c,  7F c, bl c,
-Create tag-end 2 c,  bl c, 01 c,
+Create tag-beg 1 c,  7F c,
+Create tag-end 1 c,  01 c,
 Create tag-bof 1 c,  0C c,
 Create tag-tab 1 c,  09 c,
 
@@ -2266,6 +2269,7 @@ Defer setup-prim-semantics
 
 Variable prim#
 : first-primitive ( n -- )  prim# ! ;
+: group 0 word drop prim# @ 1- -$200 and prim# ! ;
 : Primitive  ( -- ) \ name
   >in @ skip? IF  drop  EXIT  THEN  >in !
   s" prims" T $has? H 0=
@@ -2576,8 +2580,13 @@ Cond: [ ( -- ) interpreting-state ;Cond
 
 Defer instant-interpret-does>-hook
 
+T has? peephole H [IF]
 : does-resolved ( ghost -- )
     compile does-exec g>xt T a, H ;
+[ELSE]
+: does-resolved ( ghost -- )
+    g>xt T a, H ;
+[THEN]
 
 : resolve-does>-part ( -- )
 \ resolve words made by builders
@@ -2925,23 +2934,23 @@ compile: does-resolved ;compile
 
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
 
-: branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
-
-: >resolve    ( sys -- )        
-	X here ( dup ." >" hex. ) over branchoffset swap X ! ;
-
-: <resolve    ( sys -- )
-	X here ( dup ." <" hex. ) branchoffset X , ;
+X has? abranch [IF]
+    : branchoffset ( src dest -- )  drop ;
+    : offset, ( n -- )  X A, ;
+[ELSE]
+    : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
+    : offset, ( n -- )  X , ;
+[THEN]
 
-:noname compile branch X here branchoffset X , ;
+:noname compile branch X here branchoffset offset, ;
   IS branch, ( target-addr -- )
-:noname compile ?branch X here branchoffset X , ;
+:noname compile ?branch X here branchoffset offset, ;
   IS ?branch, ( target-addr -- )
-:noname compile branch T here 0 , H ;
+:noname compile branch T here 0 H offset, ;
   IS branchmark, ( -- branchtoken )
-:noname compile ?branch T here 0 , H ;
+:noname compile ?branch T here 0 H offset, ;
   IS ?branchmark, ( -- branchtoken )
-:noname T here 0 , H ;
+:noname T here 0 H offset, ;
   IS ?domark, ( -- branchtoken )
 :noname dup X @ ?struc X here over branchoffset swap X ! ;
   IS branchtoresolve, ( branchtoken -- )
@@ -2959,7 +2968,10 @@ compile: does-resolved ;compile
 
 Variable tleavings 0 tleavings !
 
-: (done) ( addr -- )
+: (done) ( do-addr -- )
+\G resolve branches of leave and ?leave and ?do
+\G do-addr is the address of the beginning of our
+\G loop so we can take care of nested loops
     tleavings @
     BEGIN  dup
     WHILE
@@ -3009,7 +3021,10 @@ Cond: ?LEAVE    ?leave, ;Cond
     0 DO  dup @ swap 1 cells -  LOOP
     free throw ;
 
-: loop]     branchto, dup <resolve tcell - (done) ;
+: loop] ( target-addr -- )
+  branchto, 
+  dup 	X here branchoffset offset, 
+  tcell - (done) ;
 
 : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
 
@@ -3117,10 +3132,21 @@ Cond: NEXT	1 ncontrols? next, ;Cond
 
 : ,"            [char] " parse ht-string, X align ;
 
+X has? control-rack [IF]
 Cond: ."        compile (.")     T ," H ;Cond
 Cond: S"        compile (S")     T ," H ;Cond
 Cond: C"        compile (C")     T ," H ;Cond
 Cond: ABORT"    compile (ABORT") T ," H ;Cond
+[ELSE]
+Cond: ."        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
+                >r then, r> compile ALiteral compile Literal compile type ;Cond
+Cond: S"        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
+                >r then, r> compile ALiteral compile Literal ;Cond
+Cond: C"        ahead, there [char] " parse ht-string, X align
+                >r then, r> compile ALiteral ;Cond
+Cond: ABORT"    if, ahead, there [char] " parse ht-string, X align
+                >r then, r> compile ALiteral compile c(abort") then, ;Cond
+[THEN]
 
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T >address ' >body ! H ;
@@ -3165,7 +3191,7 @@ Cond: postpone ( -- ) \ name
 hex
 
 >CROSS
-Create magic  s" Gforth2x" here over allot swap move
+Create magic  s" Gforth3x" here over allot swap move
 
 bigendian 1+ \ strangely, in magic big=0, little=1
 tcell 1 = 0 and or
@@ -3654,7 +3680,6 @@ previous
 : bye           bye ;
 
 \ dummy
-: group 0 word drop ;
 
 \ turnkey direction
 : H forth ; immediate