--- gforth/cross.fs	2002/03/21 17:11:10	1.124
+++ gforth/cross.fs	2002/12/27 17:19:33	1.131
@@ -27,10 +27,11 @@ ToDo:
   cross.fs is used seperately. jaw
 - Do we need this char translation with >address and in branchoffset? 
   (>body also affected) jaw
-- MAXU etc. can be done with dlit,
 
 [THEN]
 
+s" compat/strcomp.fs" included
+
 hex
 
 \ debugging for compiling
@@ -260,9 +261,9 @@ hex
 
 \ FIXME move down
 : comment? ( c-addr u -- c-addr u )
-        2dup s" (" compare 0=
+        2dup s" (" str=
         IF    postpone (
-        ELSE  2dup s" \" compare 0= IF postpone \ THEN
+        ELSE  2dup s" \" str= IF postpone \ THEN
         THEN ;
 
 : X ( -- <name> )
@@ -475,8 +476,8 @@ sourcepath value fpath
     2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
     over c@ [char] / = >r
     over c@ [char] ~ = >r
-    \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic
-    2 min S" ./" compare 0=
+    \ 2dup S" ../" string-prefix? r> or >r \ not catered for in expandtopic
+    S" ./" string-prefix?
     r> r> r> or or or ;
 
 Create ofile 0 c, 255 chars allot
@@ -492,14 +493,14 @@ Create tfile 0 c, 255 chars allot
   REPEAT ;
 
 : remove~+ ( -- )
-    ofile count 3 min s" ~+/" compare 0=
+    ofile count s" ~+/" string-prefix?
     IF
 	ofile count 3 /string ofile place
     THEN ;
 
 : expandtopic ( -- ) \ stack effect correct? - anton
     \ expands "./" into an absolute name
-    ofile count 2 min s" ./" compare 0=
+    ofile count s" ./" string-prefix?
     IF
 	ofile count 1 /string tfile place
 	0 ofile c! sourcefilename extractpath ofile place
@@ -512,7 +513,7 @@ Create tfile 0 c, 255 chars allot
     \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
     over swap
     BEGIN  dup  WHILE
-        dup >r '/ scan 2dup 4 min s" /../" compare 0=
+        dup >r '/ scan 2dup s" /../" string-prefix?
         IF
             dup r> - >r 4 /string over r> + 4 -
             swap 2dup + >r move dup r> over -
@@ -575,7 +576,7 @@ fpath= ~+
 : included? ( c-addr u -- f )
   file-list
   BEGIN	@ dup
-  WHILE	>r 2dup r@ >fl-name count compare 0=
+  WHILE	>r 2dup r@ >fl-name count str=
 	IF rdrop 2drop true EXIT THEN
 	r>
   REPEAT
@@ -1173,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
@@ -1701,7 +1704,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
@@ -1730,7 +1733,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
 
@@ -2439,35 +2444,24 @@ Cond: chars ;Cond
 
 \ some special literals					27jan97jaw
 
-\ !! Known Bug: Special Literals and plug-ins work only correct
-\ on 16 and 32 Bit Targets and 32 Bit Hosts!
-
-\ This section could be done with dlit, now. But first I need
-\ some test code JAW
-
 Cond: MAXU
-  tcell 1 cells u> 
-  IF	compile lit tcell 0 ?DO FF T c, H LOOP 
-  ELSE	ffffffff lit, THEN
+  -1 s>d dlit,
   ;Cond
 
+tcell 2 = tcell 4 = or tcell 8 = or 0=
+[IF]
+.( Warning: MINI and MAXI may not work with this host) cr
+[THEN]
+
 Cond: MINI
-  tcell 1 cells u>
-  IF	compile lit bigendian 
-  	IF	80 T c, H tcell 1 ?DO 0 T c, H LOOP 
-  	ELSE  	tcell 1 ?DO 0 T c, H LOOP 80 T c, H
-  	THEN
-  ELSE	tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN
+  tcell 2 = IF $8000 ELSE $80000000 THEN 0
+  tcell 8 = IF swap THEN dlit,
   ;Cond
  
 Cond: MAXI
- tcell 1 cells u>
- IF	compile lit bigendian 
-	IF 	7F T c, H tcell 1 ?DO FF T c, H LOOP
-	ELSE 	tcell 1 ?DO FF T c, H LOOP 7F T c, H
- 	THEN
- ELSE	tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN
- ;Cond
+  tcell 2 = IF $7fff ELSE $7fffffff THEN 0
+  tcell 8 = IF drop -1 swap THEN dlit,
+  ;Cond
 
 >CROSS
 
@@ -2937,12 +2931,6 @@ compile: does-resolved ;compile
 
 : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
 
-: >resolve    ( sys -- )        
-	X here ( dup ." >" hex. ) over branchoffset swap X ! ;
-
-: <resolve    ( sys -- )
-	X here ( dup ." <" hex. ) branchoffset X , ;
-
 :noname compile branch X here branchoffset X , ;
   IS branch, ( target-addr -- )
 :noname compile ?branch X here branchoffset X , ;
@@ -2969,7 +2957,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
@@ -3019,7 +3010,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 X , 
+  tcell - (done) ;
 
 : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
 
@@ -3123,14 +3117,74 @@ Cond: LOOP	1 ncontrols? loop, ;Cond
 Cond: +LOOP	1 ncontrols? +loop, ;Cond
 Cond: NEXT	1 ncontrols? next, ;Cond
 
+\ Absoulte branches                                     26sep02jaw
+
+\ This section defined different semantics for
+\ conditionals, using and compiling absolute branches
+
+X has? abranch [IF]
+
+Ghost abranch drop
+Ghost a?branch drop
+Ghost a(?do) drop
+Ghost a(do) drop
+Ghost a(next) drop
+Ghost a(+loop) drop
+Ghost a(loop) drop
+
+:noname compile abranch X a, ;             plugin-of branch,
+
+:noname compile a?branch X a, ;            plugin-of ?branch,
+
+:noname compile abranch T here 0  a, H ;   plugin-of branchmark,
+
+:noname compile a?branch T here 0 a, H ;   plugin-of ?branchmark,
+
+:noname 
+  dup X @ ABORT" CROSS: branch already resolved"
+  X here swap X a! ;                       plugin-of branchtoresolve,
+
+:noname 
+  0 compile a(?do) ?domark, (leave)
+  branchtomark, 2 to1 ;                    plugin-of ?do,
+
+: aloop] ( target-addr -- )
+  branchto, 
+  dup X a, 
+  tcell - (done) ;
+
+:noname 
+  1to compile a(loop) aloop] 
+  compile unloop skiploop] ;               plugin-of loop,
+
+:noname 
+  1to compile a(+loop) aloop]
+  compile unloop skiploop] ;               plugin-of +loop,
+
+:noname
+  compile a(next) aloop] compile unloop ;   plugin-of next,
+
+[THEN]
+
 \ String words                                         23feb93py
 
 : ,"            [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 ;
@@ -3175,7 +3229,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
@@ -3364,7 +3418,7 @@ Variable outfile-fd
   dup @ dup IF addr-refs @ THEN
   swap >r
   over align+ tuck tcell swap - rshift swap 0
-  DO dup 1 and 
+  ?DO dup 1 and 
      IF drop rdrop snl-calc UNLOOP EXIT THEN 
      2/ swap 1+ swap 
   LOOP
@@ -3451,17 +3505,17 @@ Create parsed 20 chars allot	\ store wor
     1 BEGIN
 	BEGIN bl word count dup WHILE
 	    comment? 20 umin parsed place upcase parsed count
-	    2dup s" [IF]" compare 0= >r 
-	    2dup s" [IFUNDEF]" compare 0= >r
-	    2dup s" [IFDEF]" compare 0= r> or r> or
+	    2dup s" [IF]" str= >r 
+	    2dup s" [IFUNDEF]" str= >r
+	    2dup s" [IFDEF]" str= r> or r> or
 	    IF   2drop 1+
-	    ELSE 2dup s" [ELSE]" compare 0=
+	    ELSE 2dup s" [ELSE]" str=
 		IF   2drop 1- dup
 		    IF 1+
 		    THEN
 		ELSE
-		    2dup s" [ENDIF]" compare 0= >r
-		    s" [THEN]" compare 0= r> or
+		    2dup s" [ENDIF]" str= >r
+		    s" [THEN]" str= r> or
 		    IF 1- THEN
 		THEN
 	    THEN
@@ -3509,7 +3563,7 @@ Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
      IF    >in ! X :
      ELSE drop
         BEGIN bl word dup c@
-              IF   count comment? s" ;" compare 0= ?EXIT
+              IF   count comment? s" ;" str= ?EXIT
               ELSE refill 0= ABORT" CROSS: Out of Input while C:"
               THEN
         AGAIN
@@ -3643,12 +3697,12 @@ previous
 : doc-on        true  to-doc ! ;
 
 : declareunique ( "name" -- )
-\G Sets the unique flag for a ghost. The assembler output
-\G generates labels with the ghostname concatenated with the address
-\G while cross-compiling. The address is concatenated
-\G because we have double occurences of the same name.
-\G If we want to reference the labels from the assembler or C
-\G code we declare them unique, so the address is skipped.
+\ Sets the unique flag for a ghost. The assembler output
+\ generates labels with the ghostname concatenated with the address
+\ while cross-compiling. The address is concatenated
+\ because we have double occurences of the same name.
+\ If we want to reference the labels from the assembler or C
+\ code we declare them unique, so the address is skipped.
   Ghost >ghost-flags dup @ <unique> or swap ! ;
 
 \ [IFDEF] dbg : dbg dbg ; [THEN]