--- gforth/cross.fs	2006/02/18 22:58:04	1.155
+++ gforth/cross.fs	2009/12/31 15:32:35	1.168
@@ -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,2004,2005 Free Software Foundation, Inc.
+\ Copyright (C) 1995,1996,1997,1998,1999,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,
@@ -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
@@ -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
 
@@ -1751,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 ;
@@ -2060,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]
@@ -2310,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
 
@@ -2521,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  ;
 
@@ -2620,7 +2636,7 @@ Cond: [ ( -- ) interpreting-state ;Cond
 
 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]
@@ -2635,7 +2651,8 @@ T has? peephole H [IF]
 
 >TARGET
 Cond: DOES>
-        T here 5 cells H + alit, compile (does>2) compile ;s
+        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
 
@@ -2881,7 +2898,7 @@ by (Value)
 [ELSE]
 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
 BuildSmart: T , H ;Build
@@ -2954,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
 
@@ -2964,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!!
@@ -2991,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
@@ -3239,6 +3263,8 @@ Cond: IS        T ' >body @ H compile AL
 : 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 ;
@@ -3724,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? ;