--- gforth/cross.fs	2003/11/10 16:57:05	1.144
+++ gforth/cross.fs	2009/03/24 08:55:29	1.167
@@ -1,13 +1,13 @@
 \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)
 
-\ Copyright (C) 1995,1996,1997,1998,1999,2000,2003 Free Software Foundation, Inc.
+\ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006,2007 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,
@@ -16,8 +16,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/.
 
 0 
 [IF]
@@ -192,7 +191,7 @@ Create bases   10 ,   2 ,   A , 100 ,
 	1+
     THEN ;
 
-: number? ( string -- string 0 / n -1 / d 0> )
+: (number?) ( string -- string 0 / n -1 / d 0> )
     dup >r count snumber? dup if
 	rdrop
     else
@@ -200,13 +199,15 @@ Create bases   10 ,   2 ,   A , 100 ,
     then ;
 
 : number ( string -- d )
-    number? ?dup 0= abort" ?"  0<
+    (number?) ?dup 0= abort" ?"  0<
     IF
 	s>d
     THEN ;
 
 [THEN]
 
+[IFUNDEF] (number?) : (number?) number? ; [THEN]
+
 \ this provides assert( and struct stuff
 \GFORTH [IFUNDEF] assert1(
 \GFORTH also forth definitions require assert.fs previous
@@ -447,7 +448,7 @@ sourcepath value fpath
     \G Make a complete new Forth search path; the path separator is |.
     fpath path= ;
 
-: path>counted  cell+ dup cell+ swap @ ;
+: path>string  cell+ dup cell+ swap @ ;
 
 : next-path ( adr len -- adr2 len2 )
   2dup 0 scan
@@ -456,12 +457,12 @@ sourcepath value fpath
   r> - ;
 
 : previous-path ( path^ -- )
-  dup path>counted
+  dup path>string
   BEGIN tuck dup WHILE repeat ;
 
 : .path ( path-addr -- ) \ gforth
     \G Display the contents of the search path @var{path-addr}.
-    path>counted
+    path>string
     BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ;
 
 : .fpath ( -- ) \ gforth
@@ -546,7 +547,7 @@ Create tfile 0 c, 255 chars allot
   IF    rdrop
         ofile place open-ofile
 	dup 0= IF >r ofile count r> THEN EXIT
-  ELSE  r> path>counted
+  ELSE  r> path>string
         BEGIN  next-path dup
         WHILE  5 pick 5 pick check-path
         0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN
@@ -1175,6 +1176,7 @@ false DefaultValue header
 false DefaultValue backtrace
 false DefaultValue new-input
 false DefaultValue peephole
+false DefaultValue primcentric
 false DefaultValue abranch
 true DefaultValue f83headerstring
 true DefaultValue control-rack
@@ -1184,6 +1186,7 @@ true DefaultValue gforthcross
 true DefaultValue interpreter
 true DefaultValue ITC
 false DefaultValue rom
+false DefaultValue flash
 true DefaultValue standardthreading
 
 \ ANSForth environment  stuff
@@ -1242,6 +1245,9 @@ bits/byte		Constant tbits/byte
 H
 tbits/char bits/byte /	Constant tbyte
 
+: >signed ( u -- n )
+    1 tbits/char tcell * 1- lshift 2dup and
+    IF  negate or  ELSE  drop  THEN ;
 
 \ Variables                                            06oct92py
 
@@ -1722,7 +1728,8 @@ Ghost (do)      Ghost (?do)
 Ghost (for)                                     drop
 Ghost (loop)    Ghost (+loop)                   2drop
 Ghost (next)                                    drop
-Ghost (does>)   Ghost (does>1)  Ghost compile,  2drop drop
+Ghost (does>)   Ghost (does>1)  Ghost (does>2)  2drop drop
+Ghost compile,                                  drop
 Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
 Ghost (C")      Ghost c(abort") Ghost type      2drop drop
 Ghost '                                         drop
@@ -1750,7 +1757,11 @@ Ghost state drop
   swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ;
 
 2Variable last-string
+X has? rom [IF] $60 [ELSE] $00 [THEN] Constant header-masks
 
+: ht-header,  ( addr count -- )
+  dup there swap last-string 2!
+    dup header-masks or T c, H bounds  ?DO  I c@ T c, H  LOOP ;
 : ht-string,  ( addr count -- )
   dup there swap last-string 2!
     dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;
@@ -1761,7 +1772,7 @@ Ghost state drop
 
 : count dup X c@ swap X char+ swap ;
 
-: on		-1 -1 rot TD!  ; 
+: on		>r -1 -1 r> TD!  ; 
 : off   	T 0 swap ! H ;
 
 : tcmove ( source dest len -- )
@@ -1770,6 +1781,9 @@ Ghost state drop
   ?DO  dup T c@ H I T c! H 1+
   tchar +LOOP  drop ;
 
+: tcallot ( char size -- )
+    0 ?DO  dup T c, H  tchar +LOOP  drop ;
+
 : td, ( d -- )
 \G Store a host value as one cell into the target
   there tcell X allot TD! ;
@@ -2056,7 +2070,7 @@ $20 constant restrict-mask
 
 >TARGET
 X has? f83headerstring [IF]
-: name,  ( "name" -- )  bl word count ht-string, X cfalign ;
+: name,  ( "name" -- )  bl word count ht-header, X cfalign ;
 [ELSE]
 : name,  ( "name" -- )  bl word count ht-lstring, X cfalign ;
 [THEN]
@@ -2204,7 +2218,7 @@ NoHeaderFlag off
 	ENDCASE
     LOOP ;
 
-Defer setup-execution-semantics
+Defer setup-execution-semantics  ' noop IS setup-execution-semantics
 0 Value lastghost
 
 : (THeader ( "name" -- ghost )
@@ -2306,7 +2320,13 @@ Variable prim#
   prim# @ (THeader ( S xt ghost )
   ['] prim-resolved over >comp !
   dup >ghost-flags <primitive> set-flag
-  over resolve-noforwards T A, H alias-mask flag!
+  s" EC" T $has? H 0=
+  IF
+      over resolve-noforwards T A, H
+      alias-mask flag!
+  ELSE
+      T here H resolve-noforwards T A, H
+  THEN
   -1 prim# +! ;
 >CROSS
 
@@ -2517,7 +2537,7 @@ Cond: MAXI
         IF   nip execute-exec-compile ELSE gexecute  THEN 
 	EXIT 
   THEN
-  number? dup  
+  (number?) dup  
   IF	0> IF swap lit,  THEN  lit, discard
   ELSE	2drop restore-input throw Ghost gexecute THEN  ;
 
@@ -2569,7 +2589,7 @@ Cond: MAXI
   (THeader (:) ;
 
 : :noname ( -- colon-sys )
-  X cfalign there 
+  switchrom X cfalign there 
   \ define a nameless ghost
   here ghostheader dup last-header-ghost ! dup to lastghost
   (:) ;  
@@ -2614,9 +2634,9 @@ Cond: [ ( -- ) interpreting-state ;Cond
     r@ created >do:ghost ! r@ swap resolve
     r> tlastcfa @ >tempdp dodoes, tempdp> ;
 
-Defer instant-interpret-does>-hook
+Defer instant-interpret-does>-hook  ' noop IS instant-interpret-does>-hook
 
-T has? peephole H [IF]
+T has? primcentric H [IF]
 : does-resolved ( ghost -- )
     compile does-exec g>xt T a, H ;
 [ELSE]
@@ -2631,7 +2651,8 @@ T has? peephole H [IF]
 
 >TARGET
 Cond: DOES>
-        T here 4 cells H + alit, compile (does>1)
+        T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells
+        H + alit, compile (does>2) compile ;s
         doeshandler, resolve-does>-part
         ;Cond
 
@@ -2821,7 +2842,7 @@ by Create
 
 : u,  ( n -- udp )
   current-region >r user-region activate
-  X here swap X , tup@ - 
+  X here swap X , tup@ -
   r> activate ;
 
 : au, ( n -- udp )
@@ -2862,9 +2883,22 @@ by User
 
 [THEN]
 
+T has? rom H [IF]
 Builder (Value)
 Build:  ( n -- ) ;Build
-by: :docon ( target-body-addr -- n ) T @ H ;DO
+by: :dovalue ( target-body-addr -- n ) T @ @ H ;DO
+
+Builder Value
+Build: T here 0 A, H switchram T align here swap ! , H ;Build
+by (Value)
+
+Builder AValue
+Build: T here 0 A, H switchram T align here swap ! A, H ;Build
+by (Value)
+[ELSE]
+Builder (Value)
+Build:  ( n -- ) ;Build
+by: :dovalue ( target-body-addr -- n ) T @ H ;DO
 
 Builder Value
 BuildSmart: T , H ;Build
@@ -2873,12 +2907,18 @@ by (Value)
 Builder AValue
 BuildSmart: T A, H ;Build
 by (Value)
+[THEN]
 
 Defer texecute
 
 Builder Defer
-BuildSmart:  ( -- ) [T'] noop T A, H ;Build
-by: :dodefer ( ghost -- ) X @ texecute ;DO
+T has? rom H [IF]
+    Build: ( -- )  T here 0 A, H switchram T align here swap ! H [T'] noop T A, H ( switchrom ) ;Build
+    by: :dodefer ( ghost -- ) X @ X @ texecute ;DO
+[ELSE]
+    BuildSmart:  ( -- ) [T'] noop T A, H ;Build
+    by: :dodefer ( ghost -- ) X @ texecute ;DO
+[THEN]
 
 Builder interpret/compile:
 Build: ( inter comp -- ) swap T A, A, H ;Build-immediate
@@ -2931,7 +2971,7 @@ DO:  abort" Not in cross mode" ;DO
 \ optimizer for cross
 
 
-T has? peephole H [IF]
+T has? primcentric H [IF]
 
 \ .( loading peephole optimization) cr
 
@@ -2941,10 +2981,17 @@ T has? peephole H [IF]
 : (callcm) T here 0 a, 0 a, H ;                 ' (callcm) plugin-of colonmark,
 : (call-res) >tempdp resolved gexecute tempdp> drop ;
                                                 ' (call-res) plugin-of colon-resolve
+T has? ec H [IF]
+: (pprim) T @ H >signed dup 0< IF  $4000 -  ELSE
+    cr ." wrong usage of (prim) "
+    dup gdiscover IF  .ghost  ELSE  .  THEN  cr -1 throw  THEN
+    T a, H ;					' (pprim) plugin-of prim,
+[ELSE]
 : (pprim) dup 0< IF  $4000 -  ELSE
     cr ." wrong usage of (prim) "
     dup gdiscover IF  .ghost  ELSE  .  THEN  cr -1 throw  THEN
     T a, H ;					' (pprim) plugin-of prim,
+[THEN]
 
 \ if we want this, we have to spilt aconstant
 \ and constant!!
@@ -2968,7 +3015,7 @@ Builder Defer
 compile: g>body compile lit-perform T A, H ;compile
 
 Builder (Field)
-compile: g>body T @ H compile lit+ T , H ;compile
+compile: g>body T @ H compile lit+ T here H reloff T , H ;compile
 
 Builder interpret/compile:
 compile: does-resolved ;compile
@@ -3211,10 +3258,19 @@ Cond: ABORT"    if, ahead, there [char]
                 >r then, r> compile ALiteral compile c(abort") then, ;Cond
 [THEN]
 
+X has? rom [IF]
+Cond: IS        T ' >body @ H compile ALiteral compile ! ;Cond
+: IS            T >address ' >body @ ! H ;
+Cond: TO        T ' >body @ H compile ALiteral compile ! ;Cond
+: TO            T ' >body @ ! H ;
+Cond: CTO       T ' >body H compile ALiteral compile ! ;Cond
+: CTO           T ' >body ! H ;
+[ELSE]
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T >address ' >body ! H ;
 Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
 : TO            T ' >body ! H ;
+[THEN]
 
 Cond: defers	T ' >body @ compile, H ;Cond
 
@@ -3268,6 +3324,7 @@ tchar 8 = 78 and or
 magic 7 + c!
 
 : save-cross ( "image-name" "binary-name" -- )
+  .regions \  s" ec" X $has? IF  .regions  THEN
   bl parse ." Saving to " 2dup type cr
   w/o bin create-file throw >r
   s" header" X $has? IF
@@ -3284,7 +3341,8 @@ magic 7 + c!
   ELSE
       bl parse 2drop
   THEN
-  dictionary >rmem @ there
+  >rom dictionary >rmem @ there
+  s" rom" X $has? IF  dictionary >rstart @ -  THEN
   r@ write-file throw \ write image
   s" relocate" X $has? IF
       dictionary >rbm @ there 1- tcell>bit rshift 1+
@@ -3692,6 +3750,8 @@ previous
 : 2/ 2/ ;
 : hex. base @ $10 base ! swap . base ! ;
 : invert invert ;
+: linkstring ( addr u n addr -- )
+    X here over X @ X , swap X ! X , ht-string, X align ;
 \ : . . ;
 
 : all-words    ['] forced?    IS skip? ;