--- gforth/cross.fs	2006/03/05 14:10:51	1.158
+++ gforth/cross.fs	2007/12/31 18:40:23	1.166
@@ -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 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]
@@ -1175,6 +1174,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
@@ -1243,6 +1243,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
 
@@ -2315,7 +2318,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
 
@@ -2625,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]
@@ -2640,7 +2649,7 @@ T has? peephole H [IF]
 
 >TARGET
 Cond: DOES>
-        T here H [ T has? peephole H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells
+        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
@@ -2960,7 +2969,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
 
@@ -2970,10 +2979,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!!
@@ -2997,7 +3013,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
@@ -3245,6 +3261,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 ;
@@ -3730,6 +3748,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? ;