--- gforth/cross.fs	2006/03/04 22:45:07	1.157
+++ gforth/cross.fs	2011/11/11 18:29:09	1.177
@@ -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,2010 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
@@ -764,6 +765,7 @@ Plugin ?do,	( -- ?do-token )
 Plugin for,	( -- for-token )
 Plugin loop,	( do-token / ?do-token -- )
 Plugin +loop,	( do-token / ?do-token -- )
+Plugin -loop,	( do-token / ?do-token -- )
 Plugin next,	( for-token )
 Plugin leave,	( -- )
 Plugin ?leave, 	( -- )
@@ -1175,6 +1177,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 +1187,7 @@ true DefaultValue gforthcross
 true DefaultValue interpreter
 true DefaultValue ITC
 false DefaultValue rom
+false DefaultValue flash
 true DefaultValue standardthreading
 
 \ ANSForth environment  stuff
@@ -1242,6 +1246,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
 
@@ -1720,9 +1727,9 @@ T has? relocate H
 
 Ghost (do)      Ghost (?do)                     2drop
 Ghost (for)                                     drop
-Ghost (loop)    Ghost (+loop)                   2drop
+Ghost (loop)    Ghost (+loop)   Ghost (-loop)   2drop drop
 Ghost (next)                                    drop
-Ghost (does>)   Ghost (does>1)  Ghost (does>2)  2drop drop
+Ghost !does                                     drop
 Ghost compile,                                  drop
 Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
 Ghost (C")      Ghost c(abort") Ghost type      2drop drop
@@ -2314,7 +2321,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
 
@@ -2400,14 +2413,11 @@ T 2 cells H Value xt>body
   there xt>body + ca>native T a, H 1 fillcfa ;		' (doprim,) plugin-of doprim,
 
 : (doeshandler,) ( -- ) 
-  T cfalign H [G'] :doesjump addr, T 0 , H ; 		' (doeshandler,) plugin-of doeshandler,
+    T H ; 					' (doeshandler,) plugin-of doeshandler,
 
 : (dodoes,) ( does-action-ghost -- )
   ]comp [G'] :dodoes addr, comp[
   addr,
-  \ the relocator in the c engine, does not like the
-  \ does-address to marked for relocation
-  [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]
   2 fillcfa ;						' (dodoes,) plugin-of dodoes,
 
 : (dlit,) ( n -- ) compile lit td, ;			' (dlit,) plugin-of dlit,
@@ -2525,7 +2535,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  ;
 
@@ -2624,7 +2634,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]
@@ -2639,7 +2649,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 compile ;s
         doeshandler, resolve-does>-part
         ;Cond
 
@@ -2936,6 +2947,15 @@ by (Field)
     T 1 cells H dup ;
 >CROSS
 
+\ ABI-CODE support
+Builder (ABI-CODE)
+Build: ;Build
+by: :doabicode noop ;DO
+
+BUILDER (;abi-code)
+Build: ;Build
+by: :do;abicode noop ;DO
+
 \ Input-Methods                                            01py
 
 Builder input-method
@@ -2946,6 +2966,24 @@ Builder input-var
 Build: ( m v size -- m v' )  over T , H + ;Build
 DO:  abort" Not in cross mode" ;DO
 
+\ Mini-OOF
+
+\ Builder method
+\ Build: ( m v -- m' v )  over T , swap cell+ swap H ;Build
+\ DO:  abort" Not in cross mode" ;DO
+
+\ Builder var
+\ Build: ( m v size -- m v+size )  over T , H + ;Build
+\ DO: ( o -- addr ) T @ H + ;DO
+
+\ Builder end-class
+\ Build: ( addr m v -- )
+\   T here >r , dup , 2 cells H ?DO T ['] noop , 1 cells H +LOOP
+\   T cell+ dup cell+ r> rot @ 2 cells /string move H ;Build
+\ by: Variable
+
+\ : defines ( xt class -- )  T ' >body @ + ! H ;
+
 \ Peephole optimization					05sep01jaw
 
 \ this section defines different compilation
@@ -2958,7 +2996,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
 
@@ -2968,10 +3006,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!!
@@ -2995,7 +3040,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
@@ -3207,6 +3252,10 @@ Cond: ENDCASE   endcase, ;Cond
   1to compile (+loop)  loop] 
   compile unloop skiploop] ;			' (+loop,) plugin-of +loop,
 
+: (-loop,) ( target-addr -- )
+  1to compile (-loop)  loop] 
+  compile unloop skiploop] ;			' (-loop,) plugin-of -loop,
+
 : (next,) 
   compile (next)  loop] compile unloop ;	' (next,) plugin-of next,
 
@@ -3216,6 +3265,7 @@ Cond: FOR	for, ;Cond
 
 Cond: LOOP	1 ncontrols? loop, ;Cond
 Cond: +LOOP	1 ncontrols? +loop, ;Cond
+Cond: -LOOP	1 ncontrols? -loop, ;Cond
 Cond: NEXT	1 ncontrols? next, ;Cond
 
 \ String words                                         23feb93py
@@ -3243,6 +3293,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 ;
@@ -3288,7 +3340,7 @@ Cond: postpone ( -- ) \ name
 hex
 
 >CROSS
-Create magic  s" Gforth3x" here over allot swap move
+Create magic  s" Gforth4x" here over allot swap move
 
 bigendian 1+ \ strangely, in magic big=0, little=1
 tcell 1 = 0 and or
@@ -3728,6 +3780,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? ;