--- gforth/cross.fs	2001/09/04 13:06:06	1.103
+++ gforth/cross.fs	2003/09/14 21:16:48	1.142
@@ -1,7 +1,7 @@
 \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)
 
-\ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
+\ Copyright (C) 1995,1996,1997,1998,1999,2000,2003 Free Software Foundation, Inc.
 
 \ This file is part of Gforth.
 
@@ -23,14 +23,15 @@
 [IF]
 
 ToDo:
-Crossdoc destination ./doc/crossdoc.fd makes no sense when
-cross.fs is uses seperately. jaw
-Do we need this char translation with >address and in branchoffset? 
-(>body also affected) jaw
-Clean up mark> and >resolve stuff jaw
+- Crossdoc destination ./doc/crossdoc.fd makes no sense when
+  cross.fs is used seperately. jaw
+- Do we need this char translation with >address and in branchoffset? 
+  (>body also affected) jaw
 
 [THEN]
 
+s" compat/strcomp.fs" included
+
 hex
 
 \ debugging for compiling
@@ -62,6 +63,7 @@ forth definitions
 : T  previous Ghosts also Target ; immediate
 : G  Ghosts ; immediate
 
+
 : >cross  also Cross definitions previous ;
 : >target also Target definitions previous ;
 : >minimal also Minimal definitions previous ;
@@ -70,6 +72,10 @@ H
 
 >CROSS
 
+\ Test against this definitions to find out whether we are cross-compiling
+\ may be usefull for assemblers
+0 Constant gforth-cross-indicator
+
 \ find out whether we are compiling with gforth
 
 : defined? bl word find nip ;
@@ -201,6 +207,13 @@ Create bases   10 ,   2 ,   A , 100 ,
 
 [THEN]
 
+\ this provides assert( and struct stuff
+\GFORTH [IFUNDEF] assert1(
+\GFORTH also forth definitions require assert.fs previous
+\GFORTH [THEN]
+
+>CROSS
+
 hex     \ the defualt base for the cross-compiler is hex !!
 \ Warnings off
 
@@ -241,16 +254,27 @@ hex     \ the defualt base for the cross
 
 hex
 
+\ FIXME delete`
 \ 1 Constant Cross-Flag	\ to check whether assembler compiler plug-ins are
 			\ for cross-compiling
 \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
 
+\ 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> )
+\G The next word in the input is a target word.
+\G Equivalent to T <name> but without permanent
+\G switch to target dictionary. Used as prefix e.g. for @, !, here etc.
+  bl word count [ ' target >wordlist ] Literal search-wordlist
+  IF state @ IF compile, ELSE execute THEN
+  ELSE	-1 ABORT" Cross: access method not supported!"
+  THEN ; immediate
+
 \ Begin CROSS COMPILER:
 
 \ debugging
@@ -296,6 +320,18 @@ set-order previous
 	\ POSTPONE false 
   THEN ; immediate
 
+: symentry ( adr len taddr -- )
+\G Produce a symbol table (an optional symbol address
+\G map) if wanted
+    [ [IFDEF] fd-symbol-table ]
+      base @ swap hex s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
+      s" :" fd-symbol-table write-file throw
+      fd-symbol-table write-line throw
+    [ [ELSE] ]
+      2drop drop
+    [ [THEN] ] ;
+
+
 \ \ --------------------	source file
 
 decimal
@@ -440,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
@@ -457,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
@@ -477,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 -
@@ -540,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
@@ -626,16 +662,168 @@ stack-warn [IF]
 : defempty? empty? ;
 [ELSE]
 : defempty? ; immediate
+\ : defempty? .sourcepos ; 
 [THEN]
 
+\ \ --------------------        Compiler Plug Ins               01aug97jaw
+
+>CROSS
+
+\ Compiler States
+
+Variable comp-state
+0 Constant interpreting
+1 Constant compiling
+2 Constant resolving
+3 Constant assembling
+
+: compiling? comp-state @ compiling = ;
+
+: pi-undefined -1 ABORT" Plugin undefined" ;
+
+: Plugin ( -- : pluginname )
+  Create 
+  \ for normal cross-compiling only one action
+  \ exists, this fields are identical. For the instant
+  \ simulation environment we need, two actions for each plugin
+  \ the target one and the one that generates the simulation code
+  ['] pi-undefined , \ action
+  ['] pi-undefined , \ target plugin action
+  8765 ,     \ plugin magic
+  DOES> perform ;
+
+Plugin DummyPlugin
+
+: 'PI ( -- addr : pluginname )
+  ' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ;
+
+: plugin-of ( xt -- : pluginname )
+  dup 'PI 2! ;
+
+: action-of ( xt -- : plunginname )
+  'PI cell+ ! ;
+
+: TPA ( -- : plugin )
+\ target plugin action
+\ executes current target action of plugin
+  'PI cell+ POSTPONE literal POSTPONE perform ; immediate
+
+Variable ppi-temp 0 ppi-temp !
+
+: pa:
+\g define plugin action
+  ppi-temp @ ABORT" pa: definition not closed"
+  'PI ppi-temp ! :noname ;
+
+: ;pa
+\g end a definition for plugin action
+  POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate
+
+
+Plugin dlit, ( d -- )			\ compile numerical value the target
+Plugin lit, ( n -- )
+Plugin alit, ( n -- )
+
+Plugin branch, ( target-addr -- )	\ compiles a branch
+Plugin ?branch, ( target-addr -- )	\ compiles a ?branch
+Plugin branchmark, ( -- branch-addr )	\ reserves room for a branch
+Plugin ?branchmark, ( -- branch-addr )	\ reserves room for a ?branch
+Plugin ?domark, ( -- branch-addr )	\ reserves room for a ?do branch
+Plugin branchto, ( -- )			\ actual program position is target of a branch (do e.g. alignment)
+' NOOP plugin-of branchto, 
+Plugin branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
+Plugin branchtomark, ( -- target-addr )	\ marks a branch destination
+
+Plugin colon, ( tcfa -- )		\ compiles call to tcfa at current position
+Plugin prim, ( tcfa -- )		\ compiles primitive invocation
+Plugin colonmark, ( -- addr )		\ marks a colon call
+Plugin colon-resolve ( tcfa addr -- )
+
+Plugin addr-resolve ( target-addr addr -- )
+Plugin doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
+
+Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open
+Plugin if, 	( -- if-token )
+Plugin else,	( if-token -- if-token )
+Plugin then,	( if-token -- )
+Plugin ahead,
+Plugin begin,
+Plugin while,
+Plugin until,
+Plugin again,
+Plugin repeat,
+Plugin cs-swap	( x1 x2 -- x2 x1 )
+
+Plugin case,	( -- n )
+Plugin of,	( n -- x1 n )
+Plugin endof,	( x1 n -- x2 n )
+Plugin endcase,	( x1 .. xn n -- )
+
+Plugin do,	( -- do-token )
+Plugin ?do,	( -- ?do-token )
+Plugin for,	( -- for-token )
+Plugin loop,	( do-token / ?do-token -- )
+Plugin +loop,	( do-token / ?do-token -- )
+Plugin next,	( for-token )
+Plugin leave,	( -- )
+Plugin ?leave, 	( -- )
+
+Plugin ca>native  \ Convert a code address to the processors
+                  \ native address. This is used in doprim, and
+                  \ code/code: primitive definitions word to
+                  \ convert the addresses.
+                  \ The only target where we need this is the misc
+                  \ which is a 16 Bit processor with word addresses
+                  \ but the forth system we build has a normal byte
+                  \ addressed memory model    
+
+Plugin doprim,	\ compiles start of a primitive
+Plugin docol,   	\ compiles start of a colon definition
+Plugin doer,		
+Plugin fini,      \ compiles end of definition ;s
+Plugin doeshandler,
+Plugin dodoes,
+
+Plugin colon-start
+' noop plugin-of colon-start
+Plugin colon-end
+' noop plugin-of colon-end
+
+Plugin ]comp     \ starts compilation
+' noop plugin-of ]comp
+Plugin comp[     \ ends compilation
+' noop plugin-of comp[
+
+Plugin t>body             \ we need the system >body
+			\ and the target >body
+
+>TARGET
+: >body t>body ;
+
+
 \ Ghost Builder                                        06oct92py
 
+>CROSS
 hex
+\ Values for ghost magic
 4711 Constant <fwd>             4712 Constant <res>
 4713 Constant <imm>             4714 Constant <do:>
 4715 Constant <skip>
 
+\ Bitmask for ghost flags
 1 Constant <unique>
+2 Constant <primitive>
+
+\ FXIME: move this to general stuff?
+: set-flag ( addr flag -- )
+  over @ or swap ! ;
+
+: reset-flag ( addr flag -- )
+  invert over @ and swap ! ;
+
+: get-flag ( addr flag -- f )
+  swap @ and 0<> ;
+  
 
 Struct
 
@@ -649,11 +837,25 @@ Struct
   \ points to the where we have to resolve (linked-list)
   cell% field >link
 
-  \ execution symantics (while target compiling) of ghost
+  \ execution semantics (while target compiling) of ghost
   cell% field >exec
 
+  \ compilation action of this ghost; this is what is
+  \ done to compile a call (or whatever) to this definition.
+  \ E.g. >comp contains the semantic of postpone s"
+  \ whereas >exec-compile contains the semantic of s"
+  cell% field >comp
+
+  \ Compilation sematics (while parsing) of this ghost. E.g. 
+  \ "\" will skip the rest of line.
+  \ These semantics are defined by Cond: and
+  \ if a word is made immediate in instant, then the >exec2 field
+  \ gets copied to here
   cell% field >exec-compile
 
+  \ Additional execution semantics of this ghost. This is used
+  \ for code generated by instant and for the doer-xt of created
+  \ words
   cell% field >exec2
 
   cell% field >created
@@ -711,6 +913,7 @@ Variable cross-space-dp-orig
   cross-space-end u> ABORT" CROSS: cross-space overflow"
   cross-space-dp-orig @ dp ! ;
 
+\ this is just for debugging, to see this in the backtrace
 : execute-exec execute ;
 : execute-exec2 execute ;
 : execute-exec-compile execute ;
@@ -722,8 +925,11 @@ Variable cross-space-dp-orig
   ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word"
   THEN ;
 
+Defer is-forward
+
 : (ghostheader) ( -- )
-  ghost-list linked <fwd> , 0 , ['] NoExec , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
+    ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward ,
+    0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
 
 : ghostheader ( -- ) (ghostheader) 0 , ;
 
@@ -783,6 +989,9 @@ Defer search-ghosts
   REPEAT
   drop r> false ;
 
+: xt>ghost ( xt -- ghost )
+  gdiscover 0= ABORT" CROSS: ghost not found for this xt" ;
+
 : Ghost   ( "name" -- ghost )
   >in @ bl word gfind IF  nip EXIT  THEN
   drop  >in !  Make-Ghost ;
@@ -812,7 +1021,6 @@ Exists-Warnings on
 
 Variable reuse-ghosts reuse-ghosts off
 
-1 [IF] \ FIXME: define when vocs are ready
 : HeaderGhost ( "name" -- ghost )
   >in @ 
   bl word count 
@@ -829,21 +1037,28 @@ Variable reuse-ghosts reuse-ghosts off
   \ defined words, this is a workaround
   \ for the redefined \ until vocs work
   Make-Ghost ;
-[THEN] 
-
  
 : .ghost ( ghost -- ) >ghostname type ;
 
 \ ' >ghostname ALIAS @name
 
+: findghost ( "ghostname" -- ghost ) 
+  bl word gfind 0= ABORT" CROSS: Ghost don't exists" ;
+
 : [G'] ( -- ghost : name )
 \G ticks a ghost and returns its address
-\  bl word gfind 0= ABORT" CROSS: Ghost don't exists"
-  ghost state @ IF postpone literal THEN ; immediate
+  findghost
+  state @ IF postpone literal THEN ; immediate
 
-: ghost>cfa ( ghost -- cfa )
+: g>xt ( ghost -- xt )
+\G Returns the xt (cfa) of a ghost. Issues a warning if undefined.
   dup undefined? ABORT" CROSS: forward " >link @ ;
    
+: g>body ( ghost -- body )
+\G Returns the body-address (pfa) of a ghost. 
+\G Issues a warning if undefined (a forward-reference).
+  g>xt X >body ;
+
 1 Constant <label>
 
 Struct
@@ -864,32 +1079,38 @@ End-Struct addr-struct
   dup @ ?dup IF nip EXIT THEN
   addr-struct %allocerase tuck swap ! ;
 
+>cross
+
 \ Predefined ghosts                                    12dec92py
 
+Ghost - drop \ need a ghost otherwise "-" would be treated as a number
+
 Ghost 0=                                        drop
 Ghost branch    Ghost ?branch                   2drop
-Ghost (do)      Ghost (?do)                     2drop
-Ghost (for)                                     drop
-Ghost (loop)    Ghost (+loop)                   2drop
-Ghost (next)                                    drop
 Ghost unloop    Ghost ;S                        2drop
-Ghost lit       Ghost (compile) Ghost !         2drop drop
-Ghost (does>)   Ghost noop                      2drop
-Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
-Ghost '                                         drop
-Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
-Ghost :dovar					drop
+Ghost lit       Ghost !                         2drop
+Ghost noop                                      drop
 Ghost over      Ghost =         Ghost drop      2drop drop
-Ghost - drop
 Ghost 2drop drop
 Ghost 2dup drop
+Ghost call drop
+Ghost @ drop
+Ghost useraddr drop
+Ghost execute drop
+Ghost + drop
+Ghost decimal drop
+Ghost hex drop
+Ghost lit@ drop
+Ghost lit-perform drop
+Ghost lit+ drop
+Ghost does-exec drop
 
-
+Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
+Ghost :dovar					drop
 
 \ \ Parameter for target systems                         06oct92py
 
 
->cross
 \ we define it ans like...
 wordlist Constant target-environment
 
@@ -951,19 +1172,34 @@ false DefaultValue dcomps
 false DefaultValue hash
 false DefaultValue xconds
 false DefaultValue header
+false DefaultValue backtrace
+false DefaultValue new-input
+false DefaultValue peephole
+false DefaultValue abranch
+true DefaultValue f83headerstring
+true DefaultValue control-rack
 [THEN]
 
+true DefaultValue gforthcross
 true DefaultValue interpreter
 true DefaultValue ITC
 false DefaultValue rom
 true DefaultValue standardthreading
 
+\ ANSForth environment  stuff
+8 DefaultValue ADDRESS-UNIT-BITS
+255 DefaultValue MAX-CHAR
+255 DefaultValue /COUNTED-STRING
+
 >TARGET
 s" relocate" T environment? H 
 \ JAW why set NIL to this?!
 [IF]	drop \ SetValue NIL
-[ELSE]	>ENVIRON T NIL H SetValue relocate
+[ELSE]	>ENVIRON X NIL SetValue relocate
 [THEN]
+>TARGET
+
+0 Constant NIL
 
 >CROSS
 
@@ -1009,10 +1245,9 @@ tbits/char bits/byte /	Constant tbyte
 
 \ Variables                                            06oct92py
 
-Variable image
-Variable tlast    TNIL tlast !  \ Last name field
+Variable (tlast)    
+(tlast) Value tlast TNIL tlast !  \ Last name field
 Variable tlastcfa \ Last code field
-Variable bit$
 
 \ statistics						10jun97jaw
 
@@ -1022,7 +1257,7 @@ Variable user-vars 0 user-vars !
 : target>bitmask-size ( u1 -- u2 )
   1- tcell>bit rshift 1+ ;
 
-: allocatetarget ( size --- adr )
+: allocatetarget ( size -- adr )
   dup allocate ABORT" CROSS: No memory for target"
   swap over swap erase ;
 
@@ -1034,18 +1269,25 @@ Variable region-link            \ linked
 Variable mirrored-link          \ linked list for mirrored regions
 0 dup mirrored-link ! region-link !
 
-
-: >rname 7 cells + ;
-: >rbm   4 cells + ;
+: >rname 9 cells + ;
+: >rtouch 8 cells + ; \ executed when region is accessed
+: >rbm   4 cells + ; \ bitfield per cell witch indicates relocation
 : >rmem  5 cells + ;
-: >rtype 6 cells + ;
+: >rtype 6 cells + ; \ field per cell witch points to a type struct
+: >rrom 7 cells + ;  \ a -1 indicates that this region is rom
 : >rlink 3 cells + ;
 : >rdp 2 cells + ;
 : >rlen cell+ ;
 : >rstart ;
 
+: (region) ( addr len region -- )
+\G change startaddress and length of an existing region
+  >r r@ last-defined-region !
+  r@ >rlen ! dup r@ >rstart ! r> >rdp ! ;
+
+: uninitialized -1 ABORT" CROSS: Region is uninitialized" ;
 
-: region ( addr len -- )                
+: region ( addr len -- "name" )                
 \G create a new region
   \ check whether predefined region exists 
   save-input bl word find >r >r restore-input throw r> r> 0= 
@@ -1054,11 +1296,12 @@ Variable mirrored-link          \ linked
 	save-input create restore-input throw
 	here last-defined-region !
 	over ( startaddr ) , ( length ) , ( dp ) ,
-	region-link linked 0 , 0 , 0 , bl word count string,
+	region-link linked 0 , 0 , 0 , 0 , 
+        ['] uninitialized ,
+        bl word count string,
   ELSE	\ store new parameters in region
         bl word drop
-	>body >r r@ last-defined-region !
-	r@ >rlen ! dup r@ >rstart ! r> >rdp !
+	>body (region)
   THEN ;
 
 : borders ( region -- startaddr endaddr ) 
@@ -1073,11 +1316,18 @@ Variable mirrored-link          \ linked
 \G returns the total area
   dup >rstart @ swap >rlen @ ;
 
-: mirrored                              
-\G mark a region as mirrored
+: dp@ ( region -- dp )
+  >rdp @ ;
+
+: mirrored ( -- )                              
+\G mark last defined region as mirrored
   mirrored-link
   align linked last-defined-region @ , ;
 
+: writeprotected
+\G mark a region as write protected
+  -1 last-defined-region @ >rrom ! ;
+
 : .addr ( u -- )
 \G prints a 16 or 32 Bit nice hex value
   base @ >r hex
@@ -1114,6 +1364,10 @@ Variable mirrored-link          \ linked
 0 0 region address-space
 \ total memory addressed and used by the target system
 
+0 0 region user-region
+\ data for user variables goes here
+\ this has to be defined before dictionary or ram-dictionary
+
 0 0 region dictionary
 \ rom area for the compiler
 
@@ -1133,8 +1387,23 @@ T has? rom H
 
 ' dictionary ALIAS rom-dictionary
 
+: setup-region ( region -- )
+  >r
+  \ allocate mem
+  r@ >rlen @ allocatetarget
+  r@ >rmem !
+
+  r@ >rlen @
+  target>bitmask-size allocatetarget
+  r@ >rbm !
+
+  r@ >rlen @
+  tcell / 1+ cells allocatetarget r@ >rtype !
 
-: setup-target ( -- )   \G initialize targets memory space
+  ['] noop r@ >rtouch !
+  rdrop ;
+
+: setup-target ( -- )   \G initialize target's memory space
   s" rom" T $has? H
   IF  \ check for ram and rom...
       \ address-space area nip 0<>
@@ -1158,26 +1427,16 @@ T has? rom H
   WHILE dup
         0 >rlink - >r
         r@ >rlen @
-        IF      \ allocate mem
-                r@ >rlen @ allocatetarget dup image !
-                r@ >rmem !
-
-                r@ >rlen @
-                target>bitmask-size allocatetarget
-                dup bit$ !
-                r@ >rbm !
-
-		r@ >rlen @
-		tcell / 1+ cells allocatetarget r@ >rtype !
-
-		rdrop
-        ELSE    r> drop THEN
+        IF      r@ setup-region
+        THEN    rdrop
    REPEAT drop ;
 
-\ MakeKernal                                           		22feb99jaw
+\ MakeKernel                                           		22feb99jaw
 
-: makekernel ( targetsize -- targetsize )
-  dup dictionary >rlen ! setup-target ;
+: makekernel ( start targetsize -- )
+\G convenience word to setup the memory of the target
+\G used by main.fs of the c-engine based systems
+  dictionary (region) setup-target ;
 
 >MINIMAL
 : makekernel makekernel ;
@@ -1202,9 +1461,9 @@ variable sromdp		\ start of rom-area for
 
 [THEN]
 
-
-0 value tdp
-variable fixed		\ flag: true: no automatic switching
+0 Value current-region
+0 Value tdp
+Variable fixed		\ flag: true: no automatic switching
 			\	false: switching is done automatically
 
 \ Switch-Policy:
@@ -1219,7 +1478,7 @@ variable constflag constflag off
 
 : activate ( region -- )
 \G next code goes to this region
-  >rdp to tdp ;
+  dup to current-region >rdp to tdp ;
 
 : (switchram)
   fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
@@ -1274,25 +1533,28 @@ variable constflag constflag off
 
 bigendian
 [IF]
-   : S!  ( n addr -- )  >r s>d r> tcell bounds swap 1-
+   : DS!  ( d addr -- )  tcell bounds swap 1-
      DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
-   : S@  ( addr -- n )  >r 0 0 r> tcell bounds
-     DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
+   : DS@  ( addr -- d )  >r 0 0 r> tcell bounds
+     DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP ;
    : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-
      DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
 [ELSE]
-   : S!  ( n addr -- )  >r s>d r> tcell bounds
+   : DS!  ( d addr -- )  tcell bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
-   : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
-     DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
+   : DS@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
+     DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP ;
    : Sc!  ( n addr -- )  >r s>d r> tchar bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds swap 1-
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
 [THEN]
 
+: S! ( n addr -- ) >r s>d r> DS! ;
+: S@ ( addr -- n ) DS@ d>s ;
+
 : taddr>region ( taddr -- region | 0 )
 \G finds for a target-address the correct region
 \G returns 0 if taddr is not in range of a target memory region
@@ -1302,7 +1564,9 @@ bigendian
         0 >rlink - >r
         r@ >rlen @
         IF      dup r@ borders within
-                IF r> r> drop nip EXIT THEN
+                IF r> r> drop nip 
+                   dup >rtouch @ EXECUTE EXIT 
+                THEN
         THEN
         r> drop
         r>
@@ -1310,6 +1574,8 @@ bigendian
   2drop 0 ;
 
 : taddr>region-abort ( taddr -- region | 0 )
+\G Same as taddr>region but aborts if taddr is not
+\G a valid address in the target address space
   dup taddr>region dup 0= 
   IF    drop cr ." Wrong address: " .addr
         -1 ABORT" Address out of range!"
@@ -1325,6 +1591,18 @@ bigendian
   \ add regions real address in our memory
   r> >rmem @ + ;
 
+: (>regionramimage) ( taddr -- 'taddr )
+\G same as (>regionimage) but aborts if the region is rom
+  dup
+  \ find region we want to address
+  taddr>region-abort
+  >r
+  r@ >rrom @ ABORT" CROSS: region is write-protected!"
+  \ calculate offset in region
+  r@ >rstart @ -
+  \ add regions real address in our memory
+  r> >rmem @ + ;
+
 : (>regionbm) ( taddr -- 'taddr bitmaskbaseaddr )
   dup
   \ find region we want to address
@@ -1370,9 +1648,8 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c,
   [ [THEN] ]
   (>regionbm) swap cell/ -bit ;
 
-: (>image) ( taddr -- absaddr ) image @ + ;
-
 DEFER >image
+DEFER >ramimage
 DEFER relon
 DEFER reloff
 DEFER correcter
@@ -1382,12 +1659,23 @@ T has? relocate H
 ' (relon) IS relon
 ' (reloff) IS reloff
 ' (>regionimage) IS >image
+' (>regionimage) IS >ramimage
 [ELSE]
 ' drop IS relon
 ' drop IS reloff
 ' (>regionimage) IS >image
+' (>regionimage) IS >ramimage
 [THEN]
 
+: enforce-writeprotection ( -- )
+  ['] (>regionramimage) IS >ramimage ;
+
+: relax-writeprotection ( -- )
+  ['] (>regionimage) IS >ramimage ;
+
+: writeprotection-relaxed? ( -- )
+  ['] >ramimage >body @ ['] (>regionimage) = ;
+
 \ Target memory access                                 06oct92py
 
 : align+  ( taddr -- rest )
@@ -1405,9 +1693,9 @@ T has? relocate H
     dup cfalign+ + ;
 
 : @  ( taddr -- w )     >image S@ ;
-: !  ( w taddr -- )     >image S! ;
+: !  ( w taddr -- )     >ramimage S! ;
 : c@ ( taddr -- char )  >image Sc@ ;
-: c! ( char taddr -- )  >image Sc! ;
+: c! ( char taddr -- )  >ramimage Sc! ;
 : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
 : 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ;
 
@@ -1426,36 +1714,31 @@ T has? relocate H
 : A!                    swap >address swap dup relon T ! H ;
 : A,    ( w -- )        >address T here H relon T , H ;
 
+\ high-level ghosts
 
 >CROSS
 
-: tcmove ( source dest len -- )
-\G cmove in target memory
-  tchar * bounds
-  ?DO  dup T c@ H I T c! H 1+
-  tchar +LOOP  drop ;
-
-
-\ \ Load Assembler
-
->TARGET
-H also Forth definitions
-
-: X 	bl word count [ ' target >wordlist ] Literal search-wordlist
-	IF	state @ IF compile,
-		ELSE execute THEN
-	ELSE	-1 ABORT" Cross: access method not supported!"
-	THEN ; immediate
+Ghost (do)      Ghost (?do)                     2drop
+Ghost (for)                                     drop
+Ghost (loop)    Ghost (+loop)                   2drop
+Ghost (next)                                    drop
+Ghost (does>)   Ghost (compile)                 2drop
+Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
+Ghost (C")      Ghost c(abort") Ghost type      2drop drop
+Ghost '                                         drop
 
-[IFDEF] asm-include asm-include [THEN] hex
+\ user ghosts
 
-previous
+Ghost state drop
 
 \ \ --------------------        Host/Target copy etc.     	29aug01jaw
 
 
 >CROSS
 
+: TD! >image DS! ;
+: TD@ >image DS@ ;
+
 : th-count ( taddr -- host-addr len )
 \G returns host address of target string
   assert1( tbyte 1 = )
@@ -1470,138 +1753,46 @@ previous
 
 : 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
 
 : count dup X c@ swap X char+ swap ;
-\ FIXME -1 on 64 bit machines?!?!
-: on		T -1 swap ! H ; 
-: off   	T 0 swap ! H ;
-
-\ \ --------------------        Compiler Plug Ins               01aug97jaw
-
->CROSS
-
-\  Compiler States
-
-Variable comp-state
-0 Constant interpreting
-1 Constant compiling
-2 Constant resolving
-3 Constant assembling
-
-: compiling? comp-state @ compiling = ;
-
-: Plugin ( -- : pluginname )
-  Create 
-  ['] noop , \ action
-  ['] noop , \ target plugin action
-  8765 ,     \ plugin magic
-  DOES> perform ;
-
-Plugin DummyPlugin
-
-: 'PI ( -- addr : pluginname )
-  ' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ;
-
-: plugin-of ( xt -- : pluginname )
-  dup 'PI 2! ;
-
-: action-of ( xt -- : plunginname )
-  'PI cell+ ! ;
-
-: TPA ( -- : plugin )
-\ target plugin action
-\ executes current target action of plugin
-  'PI cell+ POSTPONE literal POSTPONE perform ; immediate
-
-Variable ppi-temp 0 ppi-temp !
-
-: pa:
-\g define plugin action
-  ppi-temp @ ABORT" pa: definition not closed"
-  'PI ppi-temp ! :noname ;
-
-: ;pa
-\g end a definition for plugin action
-  POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate
 
+: on		-1 -1 rot TD!  ; 
+: off   	T 0 swap ! H ;
 
-Plugin lit, ( n -- )
-Plugin alit, ( n -- )
-
-Plugin branch, ( target-addr -- )	\ compiles a branch
-Plugin ?branch, ( target-addr -- )	\ compiles a ?branch
-Plugin branchmark, ( -- branch-addr )	\ reserves room for a branch
-Plugin ?branchmark, ( -- branch-addr )	\ reserves room for a ?branch
-Plugin ?domark, ( -- branch-addr )	\ reserves room for a ?do branch
-Plugin branchto, ( -- )			\ actual program position is target of a branch (do e.g. alignment)
-Plugin branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
-Plugin branchtomark, ( -- target-addr )	\ marks a branch destination
-
-Plugin colon, ( tcfa -- )		\ compiles call to tcfa at current position
-Plugin colonmark, ( -- addr )		\ marks a colon call
-Plugin colon-resolve ( tcfa addr -- )
-
-Plugin addr-resolve ( target-addr addr -- )
-Plugin doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
-
-Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open
-Plugin if, 	( -- if-token )
-Plugin else,	( if-token -- if-token )
-Plugin then,	( if-token -- )
-Plugin ahead,
-Plugin begin,
-Plugin while,
-Plugin until,
-Plugin again,
-Plugin repeat,
-Plugin cs-swap	( x1 x2 -- x2 x1 )
-
-Plugin case,	( -- n )
-Plugin of,	( n -- x1 n )
-Plugin endof,	( x1 n -- x2 n )
-Plugin endcase,	( x1 .. xn n -- )
-
-Plugin do,	( -- do-token )
-Plugin ?do,	( -- ?do-token )
-Plugin for,	( -- for-token )
-Plugin loop,	( do-token / ?do-token -- )
-Plugin +loop,	( do-token / ?do-token -- )
-Plugin next,	( for-token )
-Plugin leave,	( -- )
-Plugin ?leave, 	( -- )
+: tcmove ( source dest len -- )
+\G cmove in target memory
+  tchar * bounds
+  ?DO  dup T c@ H I T c! H 1+
+  tchar +LOOP  drop ;
 
-[IFUNDEF] ca>native
-Plugin ca>native	
-[THEN]
+: td, ( d -- )
+\G Store a host value as one cell into the target
+  there tcell X allot TD! ;
 
-Plugin doprim,	\ compiles start of a primitive
-Plugin docol,   	\ compiles start of a colon definition
-Plugin doer,		
-Plugin fini,      \ compiles end of definition ;s
-Plugin doeshandler,
-Plugin dodoes,
+\ \ Load Assembler
 
-Plugin colon-start
-Plugin colon-end
+>TARGET
+H also Forth definitions
 
-Plugin ]comp     \ starts compilation
-Plugin comp[     \ ends compilation
+\ FIXME: should we include the assembler really in the forth 
+\ dictionary?!?!?!? This conflicts with the existing assembler 
+\ of the host forth system!!
+[IFDEF] asm-include asm-include [THEN] hex
 
-T 2 cells H Value xt>body
+previous
 
-Plugin t>body             \ we need the system >body
-			\ and the target >body
 
->TARGET
-: >body t>body ;
 >CROSS
 
 : (cc) T a, H ;					' (cc) plugin-of colon,
+: (prim) T a, H ;				' (prim) plugin-of prim,
 
-: (cr) >tempdp ]comp colon, comp[ tempdp> ; 	' (cr) plugin-of colon-resolve
+: (cr) >tempdp colon, tempdp> ;                 ' (cr) plugin-of colon-resolve
 : (ar) T ! H ;					' (ar) plugin-of addr-resolve
 : (dr)  ( ghost res-pnt target-addr addr )
 	>tempdp drop over 
@@ -1612,11 +1803,11 @@ Plugin t>body             \ we need the
 	tempdp> ;				' (dr) plugin-of doer-resolve
 
 : (cm) ( -- addr )
-    T here align H
-    -1 colon, ;					' (cm) plugin-of colonmark,
+    there -1 colon, ;				' (cm) plugin-of colonmark,
 
 >TARGET
-: compile, colon, ;
+: compile, ( xt -- )
+  dup xt>ghost >comp @ EXECUTE ;
 >CROSS
 
 \ resolve structure
@@ -1638,7 +1829,7 @@ Plugin t>body             \ we need the
     loadfile , 
     sourceline# , 
     space>
-  ;
+;
 
 : refered ( ghost tag -- )
 \G creates a resolve structure
@@ -1696,58 +1887,91 @@ Defer resolve-warning
   swap exists-warning
   >link ! ;
 
-Variable rdbg
+: colon-resolved   ( ghost -- )
+\ compiles a call to a colon definition,
+\ compile action for >comp field
+    >link @ colon, ; 
+
+: prim-resolved  ( ghost -- )
+\ compiles a call to a primitive
+    >link @ prim, ;
+
+: (is-forward)   ( ghost -- )
+    colonmark, 0 (refered) ; \ compile space for call
+' (is-forward) IS is-forward
 
-: resolve  ( ghost tcfa -- )
-\G resolve referencies to ghost with tcfa
-    rdbg @ IF break: THEN 
+0 Value resolved
+
+: resolve-forward-references ( ghost resolve-list -- )
+    \ loop through forward referencies
+    comp-state @ >r Resolving comp-state !
+    over >link @ resolve-loop 
+    r> comp-state !
+
+    ['] noop IS resolve-warning ;
+
+
+: (resolve) ( ghost tcfa -- ghost resolve-list )
+    \ check for a valid address, it is a primitive reference
+    \ otherwise
     dup taddr>region 0<> IF
+      \ define this address in the region address type table
       2dup (>regiontype) define-addr-struct addr-xt-ghost 
-
       \ we define new address only if empty
-      \ this is for not to overtake the alias ghost
+      \ this is for not to take over the alias ghost
+      \ (different ghost, but identical xt)
       \ but the very first that really defines it
-\ FIXME: define when HeaderGhost is ready
       dup @ 0= IF ! ELSE 2drop THEN
-\    !
     THEN
+    swap >r
+    r@ to resolved
 
+\    r@ >comp @ ['] is-forward =
+\    ABORT" >comp action not set on a resolved ghost"
+
+    \ copmile action defaults to colon-resolved
+    \ if this is not right something must be set before
+    \ calling resolve
+    r@ >comp @ ['] is-forward = IF
+       ['] colon-resolved r@ >comp !
+   THEN
+    r@ >link @ swap \ ( list tcfa R: ghost )
+    \ mark ghost as resolved
+    r@ >link ! <res> r@ >magic !
+    r> swap ;
+
+: resolve  ( ghost tcfa -- )
+\G resolve referencies to ghost with tcfa
     \ is ghost resolved?, second resolve means another 
     \ definition with the same name
     over undefined? 0= IF  exists EXIT THEN
-    \ get linked-list
-    swap >r r@ >link @ swap \ ( list tcfa R: ghost )
-    \ mark ghost as resolved
-    dup r@ >link ! <res> r@ >magic !
-    \ loop through forward referencies
-    r> -rot 
-    comp-state @ >r Resolving comp-state !
-    resolve-loop 
-    r> comp-state !
-
-    ['] noop IS resolve-warning 
-  ;
+    (resolve)
+    ( ghost resolve-list )
+    resolve-forward-references ;
+
+: resolve-noforwards ( ghost tcfa -- )
+\G Same as resolve but complain if there are any
+\G forward references on this ghost
+   \ is ghost resolved?, second resolve means another 
+   \ definition with the same name
+   over undefined? 0= IF  exists EXIT THEN
+   (resolve)
+   IF cr ." No forward references allowed on: " .ghost cr
+      -1 ABORT" Illegal forward reference"
+   THEN
+   drop ;
 
 \ gexecute ghost,                                      01nov92py
 
-: is-forward   ( ghost -- )
-  colonmark, 0 (refered) ; \ compile space for call
-
-: is-resolved   ( ghost -- )
-  >link @ colon, ; \ compile-call
-
 : (gexecute)   ( ghost -- )
-  dup >magic @ 
-  <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;
+  dup >comp @ EXECUTE ;
 
 : gexecute ( ghost -- )
-\  dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN
+  dup >magic @ <imm> = ABORT" CROSS: gexecute on immediate word"
   (gexecute) ;
 
 : addr,  ( ghost -- )
-  dup >magic @ <fwd> = IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
-
-\ !! : ghost,     ghost  gexecute ;
+  dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
 
 \ .unresolved                                          11may93jaw
 
@@ -1802,17 +2026,22 @@ variable ResolveFlag
 \ Header states                                        12dec92py
 
 \ : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
-bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+
+X has? f83headerstring bigendian or [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+
 : flag! ( w -- )   tlast @ flag+ + dup >r T c@ xor r> c! H ;
 
 VARIABLE ^imm
 
+\ !! should be target wordsize specific
+$80 constant alias-mask
+$40 constant immediate-mask
+$20 constant restrict-mask
+
 >TARGET
-: immediate     40 flag!
+: immediate     immediate-mask flag!
                 ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                 <imm> ^imm @ ! ;
-: restrict      20 flag! ;
+: restrict      restrict-mask flag! ;
 
 : isdoer	
 \G define a forth word as doer, this makes obviously only sence on
@@ -1826,7 +2055,11 @@ VARIABLE ^imm
   dup T , H bounds  ?DO  I c@ T c, H  LOOP ;
 
 >TARGET
+X has? f83headerstring [IF]
+: name,  ( "name" -- )  bl word count ht-string, X cfalign ;
+[ELSE]
 : name,  ( "name" -- )  bl word count ht-lstring, X cfalign ;
+[THEN]
 : view,   ( -- ) ( dummy ) ;
 >CROSS
 
@@ -1847,7 +2080,7 @@ Variable to-doc  to-doc on
 	s" " doc-file-id write-line throw
 	s" make-doc " doc-file-id write-file throw
 
-	tlast @ >image count 1F and doc-file-id write-file throw
+	Last-Header-Ghost @ >ghostname doc-file-id write-file throw
 	>in @
 	[char] ( parse 2drop
 	[char] ) parse doc-file-id write-file throw
@@ -1860,11 +2093,13 @@ Variable to-doc  to-doc on
 \ Target TAGS creation
 
 s" kernel.TAGS" r/w create-file throw value tag-file-id
+s" kernel.tags" r/w create-file throw value vi-tag-file-id
 \ contains the file-id of the tags file
 
-Create tag-beg 2 c,  7F c, bl c,
-Create tag-end 2 c,  bl c, 01 c,
+Create tag-beg 1 c,  7F c,
+Create tag-end 1 c,  01 c,
 Create tag-bof 1 c,  0C c,
+Create tag-tab 1 c,  09 c,
 
 2variable last-loadfilename 0 0 last-loadfilename 2!
 	    
@@ -1878,13 +2113,13 @@ Create tag-bof 1 c,  0C c,
 	s" ,0" tag-file-id write-line throw
     THEN ;
 
-: cross-tag-entry  ( -- )
+: cross-gnu-tag-entry  ( -- )
     tlast @ 0<>	\ not an anonymous (i.e. noname) header
     IF
 	put-load-file-name
 	source >in @ min tag-file-id write-file throw
 	tag-beg count tag-file-id write-file throw
-	tlast @ >image count 1F and tag-file-id write-file throw
+	Last-Header-Ghost @ >ghostname tag-file-id write-file throw
 	tag-end count tag-file-id write-file throw
 	base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
 \	>in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
@@ -1892,6 +2127,22 @@ Create tag-bof 1 c,  0C c,
 	base !
     THEN ;
 
+: cross-vi-tag-entry ( -- )
+    tlast @ 0<>	\ not an anonymous (i.e. noname) header
+    IF
+	sourcefilename vi-tag-file-id write-file throw
+	tag-tab count vi-tag-file-id write-file throw
+	Last-Header-Ghost @ >ghostname vi-tag-file-id write-file throw
+	tag-tab count vi-tag-file-id write-file throw
+	s" /^" vi-tag-file-id write-file throw
+	source vi-tag-file-id write-file throw
+	s" $/" vi-tag-file-id write-line throw
+    THEN ;
+
+: cross-tag-entry ( -- )
+    cross-gnu-tag-entry
+    cross-vi-tag-entry ;
+
 \ Check for words
 
 Defer skip? ' false IS skip?
@@ -1926,8 +2177,9 @@ Defer skip? ' false IS skip?
 	0=
     ELSE  drop true  THEN ;
 
-: doer? ( -- flag ) \ name
-    Ghost >magic @ <do:> = ;
+: doer? ( "name" -- 0 | addr ) \ name
+    Ghost dup >magic @ <do:> = 
+    IF >link @ ELSE drop 0 THEN ;
 
 : skip-defs ( -- )
     BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;
@@ -1973,14 +2225,10 @@ Defer setup-execution-semantics
 \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
     HeaderGhost
     \ output symbol table to extra file
-    [ [IFDEF] fd-symbol-table ]
-      base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
-      s" :" fd-symbol-table write-file throw
-      dup >ghostname fd-symbol-table write-line throw
-    [ [THEN] ]
+    dup >ghostname there symentry
     dup Last-Header-Ghost ! dup to lastghost
     dup >magic ^imm !     \ a pointer for immediate
-    80 flag!
+    alias-mask flag!
     cross-doc-entry cross-tag-entry 
     setup-execution-semantics
     ;
@@ -2000,6 +2248,7 @@ Variable aprim-nr -20 aprim-nr !
 : copy-execution-semantics ( ghost-from ghost-dest -- )
   >r
   dup >exec @ r@ >exec !
+  dup >comp @ r@ >comp !
   dup >exec2 @ r@ >exec2 !
   dup >exec-compile @ r@ >exec-compile !
   dup >ghost-xt @ r@ >ghost-xt !
@@ -2011,8 +2260,8 @@ Variable aprim-nr -20 aprim-nr !
 : Alias    ( cfa -- ) \ name
   >in @ skip? IF  2drop  EXIT  THEN  >in !
   (THeader ( S xt ghost )
-  2dup swap gdiscover 0= ABORT" missing" swap copy-execution-semantics
-  over resolve T A, H 80 flag! ;
+  2dup swap xt>ghost swap copy-execution-semantics
+  over resolve T A, H alias-mask flag! ;
 
 Variable last-prim-ghost
 0 last-prim-ghost !
@@ -2025,34 +2274,39 @@ Variable last-prim-ghost
 
 Defer setup-prim-semantics
 
-: aprim   ( -- ) 
+: mapprim   ( "forthname" "asmlabel" -- ) 
   THeader -1 aprim-nr +! aprim-nr @ T A, H
   asmprimname, 
   setup-prim-semantics ;
 
-: aprim:   ( -- ) 
+: mapprim:   ( "forthname" "asmlabel" -- ) 
   -1 aprim-nr +! aprim-nr @
-  Ghost tuck swap resolve <do:> swap tuck >magic !
+  Ghost tuck swap resolve-noforwards <do:> swap tuck >magic !
   asmprimname, ;
 
-: Alias:   ( cfa -- ) \ name
+: Doer:   ( cfa -- ) \ name
   >in @ skip? IF  2drop  EXIT  THEN  >in !
   dup 0< s" prims" T $has? H 0= and
   IF
       .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
   THEN
-  Ghost tuck swap resolve <do:> swap >magic ! ;
+  Ghost
+  tuck swap resolve-noforwards <do:> swap >magic ! ;
 
 Variable prim#
 : first-primitive ( n -- )  prim# ! ;
+: group 0 word drop prim# @ 1- -$200 and prim# ! ;
+: groupadd  ( n -- )  drop ;
 : Primitive  ( -- ) \ name
-  >in @ skip? IF  2drop  EXIT  THEN  >in !
-  dup 0< s" prims" T $has? H 0= and
+  >in @ skip? IF  drop  EXIT  THEN  >in !
+  s" prims" T $has? H 0=
   IF
      .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
   THEN
   prim# @ (THeader ( S xt ghost )
-  over resolve T A, H 80 flag!
+  ['] prim-resolved over >comp !
+  dup >ghost-flags <primitive> set-flag
+  over resolve-noforwards T A, H alias-mask flag!
   -1 prim# +! ;
 >CROSS
 
@@ -2089,18 +2343,17 @@ Comment (       Comment \
 \ compile                                              10may93jaw
 
 : compile  ( "name" -- ) \ name
-\  bl word gfind 0= ABORT" CROSS: Can't compile "
-  ghost
+  findghost
   dup >exec-compile @ ?dup
   IF    nip compile,
   ELSE  postpone literal postpone gexecute  THEN ;  immediate restrict
             
 >TARGET
 
-: '  ( -- cfa ) 
-\ returns the target-cfa of a ghost
+: '  ( -- xt ) 
+\G returns the target-cfa of a ghost
   bl word gfind 0= ABORT" CROSS: Ghost don't exists"
-  ghost>cfa ;
+  g>xt ;
 
 \ FIXME: this works for the current use cases, but is not
 \ in all cases correct ;-) 
@@ -2112,49 +2365,58 @@ Cond: [']  T ' H alit, ;Cond
 
 : [T']
 \ returns the target-cfa of a ghost, or compiles it as literal
-  postpone [G'] state @ IF postpone ghost>cfa ELSE ghost>cfa THEN ; immediate
+  postpone [G'] 
+  state @ IF postpone g>xt ELSE g>xt THEN ; immediate
 
 \ \ threading modell					13dec92py
 \ modularized						14jun97jaw
 
-: fillcfa   ( usedcells -- )
-  T cells H xt>body swap - 0 ?DO 0 X c, tchar +LOOP ;
+T 2 cells H Value xt>body
 
 : (>body)   ( cfa -- pfa ) 
-  xt>body + ;					' (>body) plugin-of t>body
+  xt>body + ;						' (>body) plugin-of t>body
+
+: fillcfa   ( usedcells -- )
+  T cells H xt>body swap -
+  assert1( dup 0 >= )
+  0 ?DO 0 X c, tchar +LOOP ;
 
 : (doer,)   ( ghost -- ) 
-  addr, 1 fillcfa ;   				' (doer,) plugin-of doer,
+  addr, 1 fillcfa ;   					' (doer,) plugin-of doer,
 
-: (docol,)  ( -- ) [G'] :docol (doer,) ;	' (docol,) plugin-of docol,
+: (docol,)  ( -- ) [G'] :docol (doer,) ;		' (docol,) plugin-of docol,
+
+                                                        ' NOOP plugin-of ca>native
 
 : (doprim,) ( -- )
-  there xt>body + ca>native T a, H 1 fillcfa ;	' (doprim,) plugin-of doprim,
+  there xt>body + ca>native T a, H 1 fillcfa ;		' (doprim,) plugin-of doprim,
 
 : (doeshandler,) ( -- ) 
-  T cfalign H compile :doesjump T 0 , H ; 	' (doeshandler,) plugin-of doeshandler,
+  T cfalign H [G'] :doesjump addr, T 0 , H ; 		' (doeshandler,) plugin-of doeshandler,
 
 : (dodoes,) ( does-action-ghost -- )
-  ]comp [G'] :dodoes gexecute comp[
+  ]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,
+  2 fillcfa ;						' (dodoes,) plugin-of dodoes,
+
+: (dlit,) ( n -- ) compile lit td, ;			' (dlit,) plugin-of dlit,
 
-: (lit,) ( n -- )   compile lit T  ,  H ;	' (lit,) plugin-of lit,
+: (lit,) ( n -- )  s>d dlit, ;				' (lit,) plugin-of lit,
 
 \ if we dont produce relocatable code alit, defaults to lit, jaw
 \ this is just for convenience, so we don't have to define alit,
 \ seperately for embedded systems....
 T has? relocate H
 [IF]
-: (alit,) ( n -- )  compile lit T  a, H ;	' (alit,) plugin-of alit,
+: (alit,) ( n -- )  compile lit T  a, H ;		' (alit,) plugin-of alit,
 [ELSE]
-: (alit,) ( n -- )  lit, ;			' (alit,) plugin-of alit,
+: (alit,) ( n -- )  lit, ;				' (alit,) plugin-of alit,
 [THEN]
 
-: (fini,)         compile ;s ;			' (fini,) plugin-of fini,
+: (fini,)         compile ;s ;				' (fini,) plugin-of fini,
 
 [IFUNDEF] (code) 
 Defer (code)
@@ -2164,15 +2426,24 @@ Defer (end-code)
 >TARGET
 : Code
   defempty?
-  (THeader there resolve
+  (THeader ( ghost )
+  ['] prim-resolved over >comp !
+  there resolve-noforwards
+  
   [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
   doprim, 
   [THEN]
   depth (code) ;
 
+\ FIXME : no-compile -1 ABORT" this ghost is not for compilation" ;
+
 : Code:
   defempty?
-    Ghost dup there ca>native resolve  <do:> swap >magic !
+    Ghost >r 
+    r@ >ghostname there symentry
+    r@ there ca>native resolve-noforwards
+    <do:> r@ >magic !
+    r> drop
     depth (code) ;
 
 : end-code
@@ -2188,44 +2459,48 @@ Defer (end-code)
 >TARGET
 Cond: \G  T-\G ;Cond
 
-Cond:  Literal ( n -- )   lit, ;Cond
+Cond: Literal  ( n -- )   lit, ;Cond
 Cond: ALiteral ( n -- )   alit, ;Cond
 
 : Char ( "<char>" -- )  bl word char+ c@ ;
 Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond
 
-\ JAW Cond: chars ;Cond 
+: (x#) ( adr len base -- )
+  base @ >r base ! 0 0 name >number 2drop drop r> base ! ;
 
-\ some special literals					27jan97jaw
+: d# $0a (x#) ;
+: h# $010 (x#) ;
+
+Cond: d# $0a (x#) lit, ;Cond
+Cond: h# $010 (x#) lit, ;Cond
 
-\ !! Known Bug: Special Literals and plug-ins work only correct
-\ on 16 and 32 Bit Targets and 32 Bit Hosts!
+tchar 1 = [IF]
+Cond: chars ;Cond 
+[THEN]
+
+\ some special literals					27jan97jaw
 
 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
+
 \ Target compiling loop                                12dec92py
 \ ">tib trick thrown out                               10may93jaw
 \ number? defined at the top                           11may93jaw
@@ -2246,14 +2521,29 @@ Cond: MAXI
   IF	0> IF swap lit,  THEN  lit, discard
   ELSE	2drop restore-input throw Ghost gexecute THEN  ;
 
->TARGET
 \ : ; DOES>                                            13dec92py
 \ ]                                                     9may93py/jaw
 
-: ] 
+>CROSS
+
+: compiling-state ( -- )
+\G set states to compililng
     Compiling comp-state !
     \ if we have a state in target, change it with the compile state
-    [G'] state dup undefined? 0= IF >ghost-xt @ execute X on ELSE drop THEN
+    [G'] state dup undefined? 0= 
+    IF >ghost-xt @ execute X on ELSE drop THEN ;
+
+: interpreting-state ( -- )
+\G set states to interpreting
+   \ if target has a state variable, change it according to our state
+   [G'] state dup undefined? 0= 
+   IF >ghost-xt @ execute X off ELSE drop THEN
+   Interpreting comp-state ! ;
+
+>TARGET
+
+: ] 
+    compiling-state
     BEGIN
         BEGIN save-input bl word
               dup c@ 0= WHILE drop discard refill 0=
@@ -2266,22 +2556,23 @@ Cond: MAXI
 \ by the way: defining a second interpreter (a compiler-)loop
 \             is not allowed if a system should be ans conform
 
+: (:) ( ghost -- ) 
+\ common factor of : and :noname. Prepare ;Resolve and start definition
+   ;Resolve ! there ;Resolve cell+ !
+   docol, ]comp  colon-start depth T ] H ;
+
 : : ( -- colon-sys ) \ Name
   defempty?
   constflag off \ don't let this flag work over colon defs
 		\ just to go sure nothing unwanted happens
   >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
-  (THeader ;Resolve ! there ;Resolve cell+ !
-   docol, ]comp  colon-start depth T ] H ;
+  (THeader (:) ;
 
 : :noname ( -- colon-sys )
-  X cfalign
-  \ FIXME: cleanup!!!!!!!!
-  \ idtentical to : with dummy ghost?!
-  here ghostheader dup ;Resolve ! dup last-header-ghost ! to lastghost
-  there ;Resolve cell+ !
-  there docol, ]comp 
-  colon-start depth T ] H ;
+  X cfalign there 
+  \ define a nameless ghost
+  here ghostheader dup last-header-ghost ! dup to lastghost
+  (:) ;  
 
 Cond: EXIT ( -- )   compile ;S  ;Cond
 
@@ -2296,71 +2587,77 @@ Cond: ?EXIT ( -- ) 1 abort" CROSS: using
 Cond: recurse ( -- ) Last-Header-Ghost @ gexecute ;Cond
 
 Cond: ; ( -- ) 
-               depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
-                          ELSE true ABORT" CROSS: Stack empty" THEN
-               colon-end
-               fini,
-               comp[
-               ;Resolve @
-               IF ;Resolve @ ;Resolve cell+ @ resolve THEN
-    [G'] state dup undefined? 0= IF >ghost-xt @ execute X off ELSE drop THEN
-               Interpreting comp-state !
-               ;Cond
-Cond: [  
-  \ if we have a state in target, change it with the compile state
-    [G'] state dup undefined? 0= IF >ghost-xt @ execute X off ELSE drop THEN
-\  [G'] state dup undefined? 0= IF ghost>cfa X >body X off ELSE drop THEN
-  Interpreting comp-state ! ;Cond
+	depth ?dup 
+	IF   1- <> ABORT" CROSS: Stack changed"
+	ELSE true ABORT" CROSS: Stack empty" 
+	THEN
+	colon-end
+	fini,
+	comp[
+	;Resolve @ 
+	IF  ['] colon-resolved ;Resolve @ >comp !
+	    ;Resolve @ ;Resolve cell+ @ resolve 
+	THEN
+	interpreting-state
+	;Cond
+
+Cond: [ ( -- ) interpreting-state ;Cond
 
 >CROSS
 
-Create GhostDummy ghostheader
-<res> GhostDummy >magic !
+0 Value created
 
 : !does ( does-action -- )
-\ !! zusammenziehen und dodoes, machen!
     tlastcfa @ [G'] :dovar killref
-\    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
-\ !! geht so nicht, da dodoes, ghost will!
-    GhostDummy >link ! GhostDummy 
-    tlastcfa @ >tempdp dodoes, tempdp> ;
+    >space here >r ghostheader space>
+    ['] colon-resolved r@ >comp !
+    r@ created >do:ghost ! r@ swap resolve
+    r> tlastcfa @ >tempdp dodoes, tempdp> ;
 
-
-Defer instant-compile-does>-hook
 Defer instant-interpret-does>-hook
 
+T has? peephole H [IF]
+: does-resolved ( ghost -- )
+    compile does-exec g>xt T a, H ;
+[ELSE]
+: does-resolved ( ghost -- )
+    g>xt T a, H ;
+[THEN]
+
 : resolve-does>-part ( -- )
 \ resolve words made by builders
-  Last-Header-Ghost @ >do:ghost @ ?dup IF there resolve THEN ;
+  Last-Header-Ghost @ >do:ghost @ ?dup 
+  IF  there resolve  THEN ;
 
 >TARGET
 Cond: DOES>
         compile (does>) doeshandler,
         resolve-does>-part
-\        instant-compile-does>-hook
         ;Cond
 
-: DOES> switchrom doeshandler, T here H !does 
-  instant-interpret-does>-hook
-  depth T ] H ;
+: DOES>
+    ['] does-resolved created >comp !
+    switchrom doeshandler, T here H !does 
+    instant-interpret-does>-hook
+    depth T ] H ;
 
 >CROSS
-\ Creation                                             01nov92py
+\ Creation                                              01nov92py
 
 \ Builder                                               11may93jaw
 
-: Builder    ( Create-xt do:-xt "name" -- )
+0 Value built
+
+: Builder    ( Create-xt do-ghost "name" -- )
 \ builds up a builder in current vocabulary
 \ create-xt is executed when word is interpreted
-\ do:-xt is executet when the created word from builder is executed
-\ for do:-xt an additional entry after the normal ghost-enrys is used
+\ do:-xt is executed when the created word from builder is executed
+\ for do:-xt an additional entry after the normal ghost-entrys is used
 
-  Make-Ghost 		( Create-xt do:-xt ghost )
-  dup >created on
-  rot swap		( do:-xt Create-xt ghost )
-  tuck >exec ! >do:ghost ! ;
-\  rot swap >exec dup @ ['] NoExec <>
-\  IF 2drop ELSE ! THEN , ;
+  ghost to built 
+  built >created @ 0= IF
+    built >created on
+  THEN ;
 
 : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built
@@ -2379,19 +2676,29 @@ Cond: DOES>
   ;
 
 : takeover-x-semantics ( S constructor-ghost new-ghost -- )
-\g stores execution semantic in the built word
-\g if the word already has a semantic (concerns S", IS, .", DOES>)
-\g then keep it
-   swap >do:ghost @ >exec @ swap >exec2 ! ;
-\  >exec dup @ ['] NoExec = 
-\  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;
+   \g stores execution semantic and compilation semantic in the built word
+   swap >do:ghost @ 2dup swap >do:ghost !
+   \ we use the >exec2 field for the semantic of a created word,
+   \ using exec or exec2 makes no difference for normal cross-compilation
+   \ but is usefull for instant where the exec field is already
+   \ defined (e.g. Vocabularies)
+   2dup >exec @ swap >exec2 ! 
+   >comp @ swap >comp ! ;
+
+0 Value createhere
+
+: create-resolve ( -- )
+    created createhere resolve 0 ;Resolve ! ;
+: create-resolve-immediate ( -- )
+    create-resolve T immediate H ;
 
 : TCreate ( <name> -- )
   create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN
   executed-ghost @ (Theader
-  dup >created on
-  2dup takeover-x-semantics hereresolve gdoes, ;
+  dup >created on  dup to created
+  2dup takeover-x-semantics
+  there to createhere drop gdoes, ;
 
 : RTCreate ( <name> -- )
 \ creates a new word with code-field in ram
@@ -2399,14 +2706,14 @@ Cond: DOES>
   IF ['] reswarn-forward IS resolve-warning THEN
   \ make Alias
   executed-ghost @ (THeader 
-  dup >created on
+  dup >created on  dup to created
   2dup takeover-x-semantics
-  there 0 T a, H 80 flag!
+  there 0 T a, H alias-mask flag!
   \ store poiter to code-field
   switchram T cfalign H
   there swap T ! H
   there tlastcfa ! 
-  hereresolve gdoes, ;
+  there to createhere drop gdoes, ;
 
 : Build:  ( -- [xt] [colon-sys] )
   :noname postpone TCreate ;
@@ -2419,166 +2726,260 @@ Cond: DOES>
   postpone TCreate 
   [ [THEN] ] ;
 
+: ;Build
+  postpone create-resolve postpone ; built >exec ! ; immediate
+
+: ;Build-immediate
+    postpone create-resolve-immediate
+    postpone ; built >exec ! ; immediate
+
 : gdoes>  ( ghost -- addr flag )
-  executed-ghost @
-\  compiling? ABORT" CROSS: Executing gdoes> while compiling"
-\ ?! compiling? IF  gexecute true EXIT  THEN
-  >link @ X >body ( false ) ;
+  executed-ghost @ g>body ;
 
 \ DO: ;DO                                               11may93jaw
-\ changed to ?EXIT                                      10may93jaw
 
-: DO:     ( -- addr [xt] [colon-sys] )
-  here ghostheader
-  :noname postpone gdoes> ( postpone ?EXIT ) ;
+: do:ghost! ( ghost -- ) built >do:ghost ! ;
+: doexec! ( xt -- ) built >do:ghost @ >exec ! ;
 
-: by:     ( -- addr [xt] [colon-sys] ) \ name
-  Ghost
-  :noname postpone gdoes> ( postpone ?EXIT ) ;
+: DO:     ( -- [xt] [colon-sys] )
+  here ghostheader do:ghost!
+  :noname postpone gdoes> ;
+
+: by:     ( -- [xt] [colon-sys] ) \ name
+  Ghost do:ghost!
+  :noname postpone gdoes> ;
+
+: ;DO ( [xt] [colon-sys] -- )
+  postpone ; doexec! ; immediate
+
+: by      ( -- ) \ Name
+  Ghost >do:ghost @ do:ghost! ;
+
+: compile: ( --[xt] [colon-sys] )
+\G defines a compile time action for created words
+\G by this builder
+  :noname ;
 
-: ;DO ( addr [xt] [colon-sys] -- addr )
-  postpone ;    ( S addr xt )
-  over >exec ! ; immediate
+: ;compile ( [xt] [colon-sys] -- )
+  postpone ; built >do:ghost @ >comp ! ; immediate
 
-: by      ( -- addr ) \ Name
-  Ghost >do:ghost @ ;
-
->TARGET
 \ Variables and Constants                              05dec92py
 
-Build:  ( n -- ) ;
-by: :docon ( target-body-addr -- n ) T @ H ;DO
 Builder (Constant)
+Build:  ( n -- ) ;Build
+by: :docon ( target-body-addr -- n ) T @ H ;DO
 
-Build:  ( n -- ) T , H ;
-by (Constant)
 Builder Constant
-
-Build:  ( n -- ) T A, H ;
+Build:  ( n -- ) T , H ;Build
 by (Constant)
+
 Builder AConstant
+Build:  ( n -- ) T A, H ;Build
+by (Constant)
 
-Build:  ( d -- ) T , , H ;
-DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
 Builder 2Constant
+Build:  ( d -- ) T , , H ;Build
+DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
 
-BuildSmart: ;
-by: :dovar ( target-body-addr -- addr ) ;DO
 Builder Create
+BuildSmart: ;Build
+by: :dovar ( target-body-addr -- addr ) ;DO
 
+Builder Variable
 T has? rom H [IF]
-Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;
+Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;Build
 by (Constant)
-Builder Variable
 [ELSE]
-Build: T 0 , H ;
+Build: T 0 , H ;Build
 by Create
-Builder Variable
 [THEN]
 
+Builder 2Variable
 T has? rom H [IF]
-Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;
+Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;Build
 by (Constant)
-Builder 2Variable
 [ELSE]
-Build: T 0 , 0 , H ;
+Build: T 0 , 0 , H ;Build
 by Create
-Builder 2Variable
 [THEN]
 
+Builder AVariable
 T has? rom H [IF]
-Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;
+Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;Build
 by (Constant)
-Builder AVariable
 [ELSE]
-Build: T 0 A, H ;
+Build: T 0 A, H ;Build
 by Create
-Builder AVariable
 [THEN]
 
 \ User variables                                       04may94py
 
->CROSS
+: tup@ user-region >rstart @ ;
 
-Variable tup  0 tup !
-Variable tudp 0 tudp !
+\ Variable tup  0 tup !
+\ Variable tudp 0 tudp !
 
 : u,  ( n -- udp )
-  tup @ tudp @ + T  ! H
-  tudp @ dup T cell+ H tudp ! ;
+  current-region >r user-region activate
+  X here swap X , tup@ - 
+  r> activate ;
 
 : au, ( n -- udp )
-  tup @ tudp @ + T A! H
-  tudp @ dup T cell+ H tudp ! ;
+  current-region >r user-region activate
+  X here swap X a, tup@ - 
+  r> activate ;
 
->TARGET
+T has? no-userspace H [IF]
+
+: buildby
+  ghost >exec @ built >exec ! ;
 
-Build: 0 u, X , ;
-by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
 Builder User
+buildby Variable
+by Variable
 
-Build: 0 u, X , 0 u, drop ;
-by User
 Builder 2User
+buildby 2Variable
+by 2Variable
+
+Builder AUser
+buildby AVariable
+by AVariable
 
-Build: 0 au, X , ;
+[ELSE]
+
+Builder User
+Build: 0 u, X , ;Build
+by: :douser ( ghost -- up-addr )  X @ tup@ + ;DO
+
+Builder 2User
+Build: 0 u, X , 0 u, drop ;Build
 by User
+
 Builder AUser
+Build: 0 au, X , ;Build
+by User
+
+[THEN]
+
+Builder (Value)
+Build:  ( n -- ) ;Build
+by: :docon ( target-body-addr -- n ) T @ H ;DO
 
-BuildSmart: T , H ;
-by (Constant)
 Builder Value
+BuildSmart: T , H ;Build
+by (Value)
 
-BuildSmart: T A, H ;
-by (Constant)
 Builder AValue
+BuildSmart: T A, H ;Build
+by (Value)
 
 Defer texecute
 
-BuildSmart:  ( -- ) [T'] noop T A, H ;
-by: :dodefer ( ghost -- ) X @ texecute ;DO
 Builder Defer
+BuildSmart:  ( -- ) [T'] noop T A, H ;Build
+by: :dodefer ( ghost -- ) X @ texecute ;DO
 
-Build: ( inter comp -- ) swap T immediate A, A, H ;
-DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 Builder interpret/compile:
+Build: ( inter comp -- ) swap T A, A, H ;Build-immediate
+DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 
 \ Sturctures                                           23feb95py
 
->CROSS
 : nalign ( addr1 n -- addr2 )
 \ addr2 is the aligned version of addr1 wrt the alignment size n
  1- tuck +  swap invert and ;
->TARGET
 
-Build: ;
-by: :dofield T @ H + ;DO
+
 Builder (Field)
+Build: ;Build
+by: :dofield T @ H + ;DO
 
+Builder Field
 Build: ( align1 offset1 align size "name" --  align2 offset2 )
     rot dup T , H ( align1 align size offset1 )
-    + >r nalign r> ;
+    + >r nalign r> ;Build
 by (Field)
-Builder Field
 
+>TARGET
 : struct  T 1 chars 0 H ;
 : end-struct  T 2Constant H ;
 
 : cell% ( n -- size align )
     T 1 cells H dup ;
+>CROSS
 
+\ Input-Methods                                            01py
 
-
-Build: ( m v -- m' v )  dup T , cell+ H ;
-DO:  abort" Not in cross mode" ;DO
 Builder input-method
-
-Build: ( m v size -- m v' )  over T , H + ;
+Build: ( m v -- m' v )  dup T , cell+ H ;Build
 DO:  abort" Not in cross mode" ;DO
+
 Builder input-var
+Build: ( m v size -- m v' )  over T , H + ;Build
+DO:  abort" Not in cross mode" ;DO
+
+\ Peephole optimization					05sep01jaw
+
+\ this section defines different compilation
+\ actions for created words
+\ this will help the peephole optimizer
+\ I (jaw) took this from bernds latest cross-compiler
+\ changes but seperated it from the original
+\ Builder words. The final plan is to put this
+\ into a seperate file, together with the peephole
+\ optimizer for cross
+
+
+T has? peephole H [IF]
+
+\ .( loading peephole optimization) cr
+
+>CROSS
 
+: (callc) compile call T >body a, H ;		' (callc) plugin-of colon,
+: (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
+: (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,
 
+\ if we want this, we have to spilt aconstant
+\ and constant!!
+\ Builder (Constant)
+\ compile: g>body X @ lit, ;compile
 
+Builder (Constant)
+compile: g>body compile lit@ T a, H ;compile
+
+Builder (Value)
+compile: g>body compile lit@ T a, H ;compile
+
+\ this changes also Variable, AVariable and 2Variable
+Builder Create
+compile: g>body alit, ;compile
+
+Builder User
+compile: g>body compile useraddr T @ , H ;compile
+
+Builder Defer
+compile: g>body compile lit-perform T A, H ;compile
+
+Builder (Field)
+compile: g>body T @ H compile lit+ T , H ;compile
+
+Builder interpret/compile:
+compile: does-resolved ;compile
+
+Builder input-method
+compile: does-resolved ;compile
+
+Builder input-var
+compile: does-resolved ;compile
+
+[THEN]
 
 \ structural conditionals                              17dec92py
 
@@ -2596,23 +2997,23 @@ Builder input-var
 
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
 
-: branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
-
-: >resolve    ( sys -- )        
-	X here ( dup ." >" hex. ) over branchoffset swap X ! ;
-
-: <resolve    ( sys -- )
-	X here ( dup ." <" hex. ) branchoffset X , ;
+X has? abranch [IF]
+    : branchoffset ( src dest -- )  drop ;
+    : offset, ( n -- )  X A, ;
+[ELSE]
+    : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
+    : offset, ( n -- )  X , ;
+[THEN]
 
-:noname compile branch X here branchoffset X , ;
+:noname compile branch X here branchoffset offset, ;
   IS branch, ( target-addr -- )
-:noname compile ?branch X here branchoffset X , ;
+:noname compile ?branch X here branchoffset offset, ;
   IS ?branch, ( target-addr -- )
-:noname compile branch T here 0 , H ;
+:noname compile branch T here 0 H offset, ;
   IS branchmark, ( -- branchtoken )
-:noname compile ?branch T here 0 , H ;
+:noname compile ?branch T here 0 H offset, ;
   IS ?branchmark, ( -- branchtoken )
-:noname T here 0 , H ;
+:noname T here 0 H offset, ;
   IS ?domark, ( -- branchtoken )
 :noname dup X @ ?struc X here over branchoffset swap X ! ;
   IS branchtoresolve, ( branchtoken -- )
@@ -2630,7 +3031,10 @@ Builder input-var
 
 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
@@ -2680,7 +3084,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 offset, 
+  tcell - (done) ;
 
 : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
 
@@ -2788,10 +3195,21 @@ Cond: NEXT	1 ncontrols? next, ;Cond
 
 : ,"            [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 ;
@@ -2836,7 +3254,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
@@ -2852,7 +3270,7 @@ magic 7 + c!
 : save-cross ( "image-name" "binary-name" -- )
   bl parse ." Saving to " 2dup type cr
   w/o bin create-file throw >r
-  TNIL IF
+  s" header" X $has? IF
       s" #! "           r@ write-file throw
       bl parse          r@ write-file throw
       s"  --image-file" r@ write-file throw
@@ -2866,10 +3284,10 @@ magic 7 + c!
   ELSE
       bl parse 2drop
   THEN
-  image @ there 
+  dictionary >rmem @ there
   r@ write-file throw \ write image
-  TNIL IF
-      bit$  @ there 1- tcell>bit rshift 1+
+  s" relocate" X $has? IF
+      dictionary >rbm @ there 1- tcell>bit rshift 1+
                 r@ write-file throw \ write tags
   THEN
   r> close-file throw ;
@@ -2879,7 +3297,7 @@ magic 7 + c!
   swap >image swap r@ write-file throw
   r> close-file throw ;
 
-1 [IF]
+\ save-asm-region                         		29aug01jaw
 
 Variable name-ptr
 Create name-buf 200 chars allot
@@ -2933,6 +3351,7 @@ Create name-buf 200 chars allot
   THEN
   @nb ;
 
+\ FIXME why disabled?!
 : label-from-ghostnameXX ( ghost -- addr len )
 \ same as (label-from-ghostname) but caches generated names
   dup >asm-name @ ?dup IF nip count EXIT THEN
@@ -3024,7 +3443,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
@@ -3086,8 +3505,6 @@ Variable outfile-fd
 : save-asm-region ( region adr len -- )
   create-outfile (save-asm-region) close-outfile ;
 
-[THEN]
-
 \ \ minimal definitions
 	   
 >MINIMAL also minimal
@@ -3099,8 +3516,8 @@ Variable outfile-fd
 \ \ [IF] [ELSE] [THEN] ...				14sep97jaw
 
 \ it is useful to define our own structures and not to rely
-\ on the words in the compiler
-\ The words in the compiler might be defined with vocabularies
+\ on the words in the host system
+\ The words in the host system might be defined with vocabularies
 \ this doesn't work with our self-made compile-loop
 
 Create parsed 20 chars allot	\ store word we parsed
@@ -3113,17 +3530,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
@@ -3171,7 +3588,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
@@ -3179,18 +3596,26 @@ Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
 
 : d? d? ;
 
+: \D ( -- "debugswitch" ) 
 \G doesn't skip line when debug switch is on
-: \D D? 0= IF postpone \ THEN ;
+    D? 0= IF postpone \ THEN ;
 
+: \- ( -- "wordname" )
 \G interprets the line if word is not defined
-: \- tdefined? IF postpone \ THEN ;
+   tdefined? IF postpone \ THEN ;
 
+: \+ ( -- "wordname" )
 \G interprets the line if word is defined
-: \+ tdefined? 0= IF postpone \ THEN ;
+   tdefined? 0= IF postpone \ THEN ;
+
+: \? ( -- "envorinstring" )
+\G Skip line if environmental variable evaluates to false
+   X has? 0= IF postpone \ THEN ;
 
 Cond: \- \- ;Cond
 Cond: \+ \+ ;Cond
 Cond: \D \D ;Cond
+Cond: \? \? ;Cond
 
 : ?? bl word find IF execute ELSE drop 0 THEN ;
 
@@ -3254,14 +3679,19 @@ previous
 : * * ;
 : / / ;
 : dup dup ;
+: ?dup ?dup ;
 : over over ;
 : swap swap ;
 : rot rot ;
 : drop drop ;
+: 2drop 2drop ;
 : =   = ;
+: <>  <> ;
 : 0=   0= ;
 : lshift lshift ;
 : 2/ 2/ ;
+: hex. base @ $10 base ! swap . base ! ;
+: invert invert ;
 \ : . . ;
 
 : all-words    ['] forced?    IS skip? ;
@@ -3277,6 +3707,11 @@ previous
 : require require ;
 : needs require ;
 : .( [char] ) parse type ;
+: ERROR" [char] " parse 
+  rot 
+  IF cr ." *** " type ."  ***" -1 ABORT" CROSS: Target error, see text above" 
+  ELSE 2drop 
+  THEN ;
 : ." [char] " parse type ;
 : cr cr ;
 
@@ -3296,12 +3731,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]
@@ -3312,11 +3747,11 @@ previous
 : hwords        words ;
 \ : words 	also ghosts 
 \                words previous ;
-\ : .s            .s ;
+: .s            .s ;
+: depth         depth ;
 : bye           bye ;
 
 \ dummy
-: group 0 word drop ;
 
 \ turnkey direction
 : H forth ; immediate
@@ -3356,6 +3791,3 @@ UNLOCK >CROSS
 [IFDEF] extend-cross extend-cross [THEN]
 
 LOCK
-
-
-