--- gforth/cross.fs	2000/05/04 09:31:16	1.84
+++ gforth/cross.fs	2002/03/19 11:13:08	1.120
@@ -1,7 +1,7 @@
 \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)
 
-\ Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
+\ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
 
 \ This file is part of Gforth.
 
@@ -17,17 +17,17 @@
 
 \ 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 
 0 
 [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
+- MAXU etc. can be done with dlit,
 
 [THEN]
 
@@ -62,6 +62,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 ;
@@ -201,6 +202,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 +249,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=
         IF    postpone (
         ELSE  2dup s" \" compare 0= 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
@@ -474,27 +493,17 @@ Create tfile 0 c, 255 chars allot
     THEN ;
 
 : compact.. ( adr len -- adr2 len2 )
-\ deletes phrases like "xy/.." out of our directory name 2dec97jaw
-  over >r -1 >r
-  BEGIN dup WHILE
-	over c@ pathsep? 
-	IF 	r@ -1 =
-		IF	r> drop dup >r
-		ELSE	2dup 1 /string 
-			3 min s" ../" compare
-			0=
-			IF	r@ over - ( diff )
-				2 pick swap - ( dest-adr )
-				>r 3 /string r> swap 2dup >r >r
-				move r> r>
-			ELSE	r> drop dup >r
-			THEN
-		THEN
-	THEN
-	1 /string
-  REPEAT 
-  r> drop 
-  drop r> tuck - ;
+    \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
+    over swap
+    BEGIN  dup  WHILE
+        dup >r '/ scan 2dup 4 min s" /../" compare 0=
+        IF
+            dup r> - >r 4 /string over r> + 4 -
+            swap 2dup + >r move dup r> over -
+        ELSE
+            rdrop dup 1 min /string
+        THEN
+    REPEAT  drop over - ;
 
 : reworkdir ( -- )
   remove~+
@@ -638,100 +647,344 @@ stack-warn [IF]
 : defempty? ; immediate
 [THEN]
 
-\ \ GhostNames Ghosts                                  9may93jaw
+\ \ --------------------        Compiler Plug Ins               01aug97jaw
 
-\ second name source to search trough list
+>CROSS
 
-VARIABLE GhostNames
-0 GhostNames !
+\ Compiler States
 
-: GhostName ( -- addr )
-    align here GhostNames @ , GhostNames ! here 0 ,
-    bl word count
-    \ 2dup type space
-    string, \ !! cfalign ?
-    align ;
+Variable comp-state
+0 Constant interpreting
+1 Constant compiling
+2 Constant resolving
+3 Constant assembling
 
-\ Ghost Builder                                        06oct92py
+: 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 xt, ( tcfa -- )			\ compiles xt
+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, 	( -- )
+
+[IFUNDEF] ca>native
+Plugin ca>native	
+[THEN]
+
+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
 
-\ <T T> new version with temp variable                 10may93jaw
+>TARGET
+: >body t>body ;
 
-VARIABLE VocTemp
 
-: <T  get-current VocTemp ! also Ghosts definitions ;
-: T>  previous VocTemp @ set-current ;
+\ Ghost Builder                                        06oct92py
 
+>CROSS
 hex
+\ Values for ghost magic
 4711 Constant <fwd>             4712 Constant <res>
 4713 Constant <imm>             4714 Constant <do:>
 4715 Constant <skip>
 
-\ iForth makes only immediate directly after create
-\ make atonce trick! ?
+\ 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
+
+  \ link to next ghost (always the first element)
+  cell% field >next-ghost
 
-Variable atonce atonce off
+  \ type of ghost
+  cell% field >magic
+		
+  \ pointer where ghost is in target, or if unresolved
+  \ points to the where we have to resolve (linked-list)
+  cell% field >link
+
+  \ 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
+
+  \ the xt of the created ghost word itself
+  cell% field >ghost-xt
+
+  \ pointer to the counted string of the assiciated
+  \ assembler label
+  cell% field >asm-name
+
+  \ mapped primitives have a special address, so
+  \ we are able to detect them
+  cell% field >asm-dummyaddr
+			
+  \ for builder (create, variable...) words
+  \ the execution symantics of words built are placed here
+  \ this is a doer ghost or a dummy ghost
+  cell% field >do:ghost
 
-: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;
+  cell% field >ghost-flags
 
-: GhostHeader <fwd> , 0 , ['] NoExec , ;
+  cell% field >ghost-name
 
-: >magic ;		\ type of ghost
-: >link cell+ ;		\ pointer where ghost is in target, or if unresolved
-			\ points to the where we have to resolve (linked-list)
-: >exec cell+ cell+ ;	\ execution symantics (while target compiling) of ghost
-: >end 3 cells + ;	\ room for additional tags
-			\ for builder (create, variable...) words the
-			\ execution symantics of words built are placed here
+End-Struct ghost-struct
+
+Variable ghost-list
+0 ghost-list !
 
 Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>
-Variable last-ghost	\ last ghost that is created
+\ Variable last-ghost	\ last ghost that is created
 Variable last-header-ghost \ last ghost definitions with header
 
+\ space for ghosts resolve structure
+\ we create ghosts in a sepearte space
+\ and not to the current host dp, because this
+\ gives trouble with instant while compiling and creating
+\ a ghost for a forward reference
+\ BTW: we cannot allocate another memory region
+\ because allot will check the overflow!!
+Variable cross-space-dp
+Create cross-space 250000 allot here 100 allot align 
+Constant cross-space-end
+cross-space cross-space-dp !
+Variable cross-space-dp-orig
+
+: cross-space-used cross-space-dp @ cross-space - ;
+
+: >space ( -- )
+  dp @ cross-space-dp-orig !
+  cross-space-dp @ dp ! ;
+
+: space> ( -- )
+  dp @ dup cross-space-dp !
+  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 ;
+
+: NoExec
+  executed-ghost @ >exec2 @
+  ?dup 
+  IF   execute-exec2
+  ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word"
+  THEN ;
+
+Defer is-forward
+Defer do-refered
+
+: prim-forward   ( ghost -- )
+\  ." PF" .sourcepos
+  colonmark, 0 do-refered ; \ compile space for call
+: doer-forward   ( ghost -- )
+\  ." DF" .sourcepos
+  colonmark, 2 do-refered ; \ compile space for doer
+' prim-forward IS is-forward
+
+: (ghostheader) ( -- )
+    ghost-list linked <fwd> , 0 , ['] NoExec , what's is-forward ,
+    0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
+
+: ghostheader ( -- ) (ghostheader) 0 , ;
+
+' Ghosts >wordlist Constant ghosts-wordlist
+
+\ the current wordlist for ghost definitions in the host
+ghosts-wordlist Value current-ghosts
+
 : Make-Ghost ( "name" -- ghost )
-  >in @ GhostName swap >in !
-  <T Create atonce @ IF immediate atonce off THEN
-  here tuck swap ! ghostheader T>
-  dup last-ghost !
-  DOES> dup executed-ghost ! >exec @ execute ;
+  >space
+  \ save current and create in ghost vocabulary
+  get-current >r current-ghosts set-current
+  >in @ Create >in !
+  \ some forth systems like iForth need the immediate directly
+  \ after the word is created
+  \ restore current
+  r> set-current
+  here (ghostheader)
+  bl word count string, align
+  space>
+  \ set ghost-xt field by doing a search
+  dup >ghost-name count 
+  current-ghosts search-wordlist
+  0= ABORT" CROSS: Just created, must be there!"
+  over >ghost-xt !
+  DOES> 
+      dup executed-ghost !
+      >exec @ execute-exec ;
 
 \ ghost words                                          14oct92py
 \                                          changed:    10may93py/jaw
 
-: gfind   ( string -- ghost true/1 / string false )
+Defer search-ghosts
+
+: (search-ghosts) ( adr len -- cfa true | 0 )
+  current-ghosts search-wordlist ; 
+
+  ' (search-ghosts) IS search-ghosts
+
+: gsearch ( addr len -- ghost true | 0 )
+  search-ghosts
+  dup IF swap >body swap THEN ;
+
+: gfind   ( string -- ghost true / string false )
 \ searches for string in word-list ghosts
-  dup count [ ' ghosts >wordlist ] Literal search-wordlist
-  dup IF >r >body nip r>  THEN ;
+  \ dup count type space
+  dup >r count gsearch
+  dup IF rdrop ELSE r> swap THEN ;
 
 : gdiscover ( xt -- ghost true | xt false )
-  GhostNames
+  >r ghost-list
   BEGIN @ dup
-  WHILE 2dup
-        cell+ @ dup >magic @ <fwd> <>
-        >r >link @ = r> and
-        IF cell+ @ nip true EXIT THEN
+  WHILE dup >magic @ <fwd> <>
+        IF dup >link @ r@ =
+           IF rdrop true EXIT THEN
+        THEN
   REPEAT
-  drop false ;
+  drop r> false ;
 
-VARIABLE Already
+: xt>ghost ( xt -- ghost )
+  gdiscover 0= ABORT" CROSS: ghost not found for this xt" ;
 
-: ghost   ( "name" -- ghost )
-  Already off
-  >in @  bl word gfind   IF  atonce off Already on nip EXIT  THEN
+: Ghost   ( "name" -- ghost )
+  >in @ bl word gfind IF  nip EXIT  THEN
   drop  >in !  Make-Ghost ;
 
 : >ghostname ( ghost -- adr len )
-  GhostNames
-  BEGIN @ dup
-  WHILE 2dup cell+ @ =
-  UNTIL nip 2 cells + count
-  ELSE  2drop 
-	\ true abort" CROSS: Ghostnames inconsistent"
-	s" ?!?!?!"
-  THEN ;
-
-: .ghost ( ghost -- ) >ghostname type ;
-
-\ ' >ghostname ALIAS @name
+  >ghost-name count ;
 
 : forward? ( ghost -- flag )
   >magic @ <fwd> = ;
@@ -739,51 +992,150 @@ VARIABLE Already
 : undefined? ( ghost -- flag )
   >magic @ dup <fwd> = swap <skip> = or ;
 
+: immediate? ( ghost -- flag )
+  >magic @ <imm> = ;
+
+Variable TWarnings
+TWarnings on
+Variable Exists-Warnings
+Exists-Warnings on
+
+: exists-warning ( ghost -- ghost )
+  TWarnings @ Exists-Warnings @ and
+  IF dup >ghostname warnhead type ."  exists " THEN ;
+
+\ : HeaderGhost Ghost ;
+
+Variable reuse-ghosts reuse-ghosts off
+
+: HeaderGhost ( "name" -- ghost )
+  >in @ 
+  bl word count 
+\  2dup type space
+  current-ghosts search-wordlist
+  IF  >body dup undefined? reuse-ghosts @ or
+      IF   nip EXIT
+      ELSE exists-warning 
+      THEN
+      drop >in ! 
+  ELSE >in ! 
+  THEN 
+  \ we keep the execution semantics of the prviously
+  \ defined words, this is a workaround
+  \ for the redefined \ until vocs work
+  Make-Ghost ;
+ 
+: .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
+  findghost
+  state @ IF postpone literal THEN ; immediate
+
+: 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
+  \ bitmask of address type (not used for now)
+  cell% field addr-type
+  \ if this address is an xt, this field points to the ghost
+  cell% field addr-xt-ghost
+  \ a bit mask that tells as what part of the cell
+  \ is refenced from an address pointer, used for assembler generation
+  cell% field addr-refs
+End-Struct addr-struct
+
+: %allocerase ( align size -- addr )
+  dup >r %alloc dup r> erase ;
+
+\ returns the addr struct, define it if 0 reference
+: define-addr-struct ( addr -- struct-addr )
+  dup @ ?dup IF nip EXIT THEN
+  addr-struct %allocerase tuck swap ! ;
+
+>cross
+
 \ Predefined ghosts                                    12dec92py
 
-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 over      ghost =         ghost drop      2drop drop
-ghost - drop
-ghost 2drop drop
-ghost 2dup drop
+Ghost - drop \ need a ghost otherwise "-" would be treated as a number
+
+Ghost 0=                                        drop
+Ghost branch    Ghost ?branch                   2drop
+Ghost unloop    Ghost ;S                        2drop
+Ghost lit       Ghost !                         2drop
+Ghost noop                                      drop
+Ghost over      Ghost =         Ghost drop      2drop 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
+
+' doer-forward IS is-forward
+
+Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
+Ghost :dovar					drop
+
+
+' prim-forward IS is-forward
 
 \ \ Parameter for target systems                         06oct92py
 
+
 \ we define it ans like...
 wordlist Constant target-environment
 
-VARIABLE env-current \ save information of current dictionary to restore with environ>
+\ save information of current dictionary to restore with environ>
+Variable env-current 
 
 : >ENVIRON get-current env-current ! target-environment set-current ;
 : ENVIRON> env-current @ set-current ; 
 
 >TARGET
 
-: environment? ( adr len -- [ x ] true | false )
-  target-environment search-wordlist 
-  IF execute true ELSE false THEN ;
-
-: e? bl word count T environment? H 0= ABORT" environment variable not defined!" ;
-
-: has? 	bl word count T environment? H 
-	IF 	\ environment variable is present, return its value
-	ELSE	\ environment variable is not present, return false
-		false \ debug true ABORT" arg" 
-	THEN ;
+: environment? ( addr len -- [ x ] true | false )
+\G returns the content of environment variable and true or
+\G false if not present
+   target-environment search-wordlist 
+   IF EXECUTE true ELSE false THEN ;
+
+: $has? ( addr len -- x | false )
+\G returns the content of environment variable 
+\G or false if not present
+   T environment? H dup IF drop THEN ;
+
+: e? ( "name" -- x )
+\G returns the content of environment variable. 
+\G The variable is expected to exist. If not, issue an error.
+   bl word count T environment? H 
+   0= ABORT" environment variable not defined!" ;
+
+: has? ( "name" --- x | false )
+\G returns the content of environment variable 
+\G or false if not present
+   bl word count T $has? H ;
 
-: $has? T environment? H IF ELSE false THEN ;
 
 >ENVIRON get-order get-current swap 1+ set-order
 true SetValue compiler
@@ -792,9 +1144,9 @@ true SetValue standard-threading
 >TARGET previous
 
 0
-[IFDEF] mach-file mach-file count 1 [THEN]
-[IFDEF] machine-file machine-file 1 [THEN]
-[IF] 	included hex drop
+[IFDEF] mach-file drop mach-file count 1 [THEN]
+[IFDEF] machine-file drop machine-file 1 [THEN]
+[IF] 	included hex
 [ELSE]  cr ." No machine description!" ABORT 
 [THEN]
 
@@ -812,6 +1164,9 @@ false DefaultValue dcomps
 false DefaultValue hash
 false DefaultValue xconds
 false DefaultValue header
+false DefaultValue backtrace
+false DefaultValue new-input
+false DefaultValue peephole
 [THEN]
 
 true DefaultValue interpreter
@@ -821,9 +1176,13 @@ true DefaultValue standardthreading
 
 >TARGET
 s" relocate" T environment? H 
-[IF]	SetValue NIL
-[ELSE]	>ENVIRON T NIL H SetValue relocate
+\ JAW why set NIL to this?!
+[IF]	drop \ SetValue NIL
+[ELSE]	>ENVIRON X NIL SetValue relocate
 [THEN]
+>TARGET
+
+0 Constant NIL
 
 >CROSS
 
@@ -872,7 +1231,6 @@ tbits/char bits/byte /	Constant tbyte
 Variable image
 Variable tlast    TNIL tlast !  \ Last name field
 Variable tlastcfa \ Last code field
-Variable tdoes    \ Resolve does> calls
 Variable bit$
 
 \ statistics						10jun97jaw
@@ -883,7 +1241,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 ;
 
@@ -896,16 +1254,22 @@ Variable mirrored-link          \ linked
 0 dup mirrored-link ! region-link !
 
 
-: >rname 6 cells + ;
-: >rbm   5 cells + ;
-: >rmem  4 cells + ;
+: >rname 7 cells + ;
+: >rbm   4 cells + ;
+: >rmem  5 cells + ;
+: >rtype 6 cells + ;
 : >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 ! ;
 
-: region ( addr len -- )                \G create a new region
+: region ( addr len -- )                
+\G create a new region
   \ check whether predefined region exists 
   save-input bl word find >r >r restore-input throw r> r> 0= 
   IF	\ make region
@@ -913,23 +1277,26 @@ Variable mirrored-link          \ linked
 	save-input create restore-input throw
 	here last-defined-region !
 	over ( startaddr ) , ( length ) , ( dp ) ,
-	region-link linked 0 , 0 , bl word count string,
+	region-link linked 0 , 0 , 0 , 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 ) \G returns lower and upper region border
+: borders ( region -- startaddr endaddr ) 
+\G returns lower and upper region border
   dup >rstart @ swap >rlen @ over + ;
 
-: extent  ( region -- startaddr len )   \G returns the really used area
+: extent  ( region -- startaddr len )   
+\G returns the really used area
   dup >rstart @ swap >rdp @ over - ;
 
-: area ( region -- startaddr totallen ) \G returns the total area
+: area ( region -- startaddr totallen ) 
+\G returns the total area
   dup >rstart @ swap >rlen @ ;
 
-: mirrored                              \G mark a region as mirrored
+: mirrored                              
+\G mark a region as mirrored
   mirrored-link
   align linked last-defined-region @ , ;
 
@@ -939,7 +1306,7 @@ Variable mirrored-link          \ linked
   tcell 2 u>
   IF s>d <# # # # # [char] . hold # # # # #> type
   ELSE s>d <# # # # # # #> type
-  THEN r> base ! ;
+  THEN r> base ! space ;
 
 : .regions                      \G display region statistic
 
@@ -989,7 +1356,7 @@ T has? rom H
 ' dictionary ALIAS rom-dictionary
 
 
-: setup-target ( -- )   \G initialize targets memory space
+: setup-target ( -- )   \G initialize target's memory space
   s" rom" T $has? H
   IF  \ check for ram and rom...
       \ address-space area nip 0<>
@@ -1014,22 +1381,28 @@ T has? rom H
         0 >rlink - >r
         r@ >rlen @
         IF      \ allocate mem
-                r@ >rlen @ dup
-
-                allocatetarget dup image !
+                r@ >rlen @ allocatetarget dup image !
                 r@ >rmem !
 
+                r@ >rlen @
                 target>bitmask-size allocatetarget
                 dup bit$ !
-                r> >rbm !
+                r@ >rbm !
+
+		r@ >rlen @
+		tcell / 1+ cells allocatetarget r@ >rtype !
 
+		rdrop
         ELSE    r> drop THEN
    REPEAT drop ;
 
-\ MakeKernal                                           		22feb99jaw
+\ MakeKernel                                           		22feb99jaw
 
-: makekernel ( targetsize -- targetsize )
-  dup dictionary >rlen ! setup-target ;
+: makekernel ( targetsize -- )
+\G convenience word to setup the memory of the target
+\G used by main.fs of the c-engine based systems
+  100 swap dictionary (region)
+  setup-target ;
 
 >MINIMAL
 : makekernel makekernel ;
@@ -1126,25 +1499,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
@@ -1161,16 +1537,42 @@ bigendian
   REPEAT
   2drop 0 ;
 
+: taddr>region-abort ( taddr -- region | 0 )
+  dup taddr>region dup 0= 
+  IF    drop cr ." Wrong address: " .addr
+        -1 ABORT" Address out of range!"
+  THEN nip ;
+
 : (>regionimage) ( taddr -- 'taddr )
   dup
   \ find region we want to address
-  taddr>region dup 0= ABORT" Address out of range!"
+  taddr>region-abort
   >r
   \ 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
+  taddr>region-abort
+  >r
+  \ calculate offset in region
+  r@ >rstart @ -
+  \ add regions real address in our memory
+  r> >rbm @ ;
+
+: (>regiontype) ( taddr -- 'taddr )
+  dup
+  \ find region we want to address
+  taddr>region-abort
+  >r
+  \ calculate offset in region
+  r@ >rstart @ - tcell / cells
+  \ add regions real address in our memory
+  r> >rtype @ + ;
+  
 \ Bit string manipulation                               06oct92py
 \                                                       9may93jaw
 CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
@@ -1180,19 +1582,21 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : +bit ( addr n -- )  >bit over c@ or swap c! ;
 : -bit ( addr n -- )  >bit invert over c@ and swap c! ;
 
+: @relbit ( taddr -- f ) (>regionbm) swap cell/ >bit swap c@ and ;
+
 : (relon) ( taddr -- )  
   [ [IFDEF] fd-relocation-table ]
   s" +" fd-relocation-table write-file throw
   dup s>d <# #s #> fd-relocation-table write-line throw
   [ [THEN] ]
-  bit$ @ swap cell/ +bit ;
+  (>regionbm) swap cell/ +bit ;
 
 : (reloff) ( taddr -- ) 
   [ [IFDEF] fd-relocation-table ]
   s" -" fd-relocation-table write-file throw
   dup s>d <# #s #> fd-relocation-table write-line throw
   [ [THEN] ]
-  bit$ @ swap cell/ -bit ;
+  (>regionbm) swap cell/ -bit ;
 
 : (>image) ( taddr -- absaddr ) image @ + ;
 
@@ -1205,7 +1609,7 @@ T has? relocate H
 [IF]
 ' (relon) IS relon
 ' (reloff) IS reloff
-' (>image) IS >image
+' (>regionimage) IS >image
 [ELSE]
 ' drop IS relon
 ' drop IS reloff
@@ -1250,104 +1654,107 @@ 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
 
+: call-forward ( ghost -- )
+\    ." CF" .sourcepos
+    there 0 colon, 0 do-refered ;
+' call-forward IS is-forward
+
+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")                                      drop
+Ghost '                                         drop
+
+\ ' prim-forward IS is-forward
+
+\ user ghosts
+
+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 = )
+  dup X c@ swap X char+ >image swap ;
+
+: ht-move ( haddr taddr len -- )
+\G moves data from host-addr to destination in target-addr
+\G character by character
+  swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ;
+
+2Variable last-string
+
+: ht-string,  ( addr count -- )
+  dup there swap last-string 2!
+  dup T c, H bounds  ?DO  I c@ T c, H  LOOP ; 
+
+>TARGET
+
+: count dup X c@ swap X char+ swap ;
+
+: on		-1 -1 rot TD!  ; 
+: off   	T 0 swap ! H ;
+
 : tcmove ( source dest len -- )
 \G cmove in target memory
   tchar * bounds
   ?DO  dup T c@ H I T c! H 1+
   tchar +LOOP  drop ;
 
+: td, ( d -- )
+\G Store a host value as one cell into the target
+  there tcell X allot TD! ;
+
 \ \ 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
-
+\ 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
 
 previous
->CROSS H
-
-\ \ --------------------        Compiler Plug Ins               01aug97jaw
 
-\  Compiler States
-
-Variable comp-state
-0 Constant interpreting
-1 Constant compiling
-2 Constant resolving
-3 Constant assembling
-
-Defer lit, ( n -- )
-Defer alit, ( n -- )
-
-Defer branch, ( target-addr -- )	\ compiles a branch
-Defer ?branch, ( target-addr -- )	\ compiles a ?branch
-Defer branchmark, ( -- branch-addr )	\ reserves room for a branch
-Defer ?branchmark, ( -- branch-addr )	\ reserves room for a ?branch
-Defer ?domark, ( -- branch-addr )	\ reserves room for a ?do branch
-Defer branchto, ( -- )			\ actual program position is target of a branch (do e.g. alignment)
-Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
-Defer branchfrom, ( -- )		\ ?!
-Defer branchtomark, ( -- target-addr )	\ marks a branch destination
-
-Defer colon, ( tcfa -- )		\ compiles call to tcfa at current position
-Defer colonmark, ( -- addr )		\ marks a colon call
-Defer colon-resolve ( tcfa addr -- )
-
-Defer addr-resolve ( target-addr addr -- )
-Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
-
-Defer do,	( -- do-token )
-Defer ?do,	( -- ?do-token )
-Defer for,	( -- for-token )
-Defer loop,	( do-token / ?do-token -- )
-Defer +loop,	( do-token / ?do-token -- )
-Defer next,	( for-token )
-
-[IFUNDEF] ca>native
-defer ca>native	
-[THEN]
 
->TARGET
-DEFER >body             \ we need the system >body
-			\ and the target >body
 >CROSS
-T 2 cells H VALUE xt>body
-DEFER doprim,	\ compiles start of a primitive
-DEFER docol,   	\ compiles start of a colon definition
-DEFER doer,		
-DEFER fini,      \ compiles end of definition ;s
-DEFER doeshandler,
-DEFER dodoes,
-
-DEFER ]comp     \ starts compilation
-DEFER comp[     \ ends compilation
 
-: (cc) T a, H ;					' (cc) IS colon,
+: (cc) T a, H ;					' (cc) plugin-of colon,
+: (xt) T a, H ;					' (xt) plugin-of xt,
+: (prim) T a, H ;				' (prim) plugin-of prim,
 
-: (cr) >tempdp ]comp colon, comp[ tempdp> ; 	' (cr) IS colon-resolve
-: (ar) T ! H ;					' (ar) IS addr-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 
 	dup >magic @ <do:> =
 	IF 	doer,
 	ELSE	dodoes,
 	THEN 
-	tempdp> ;				' (dr) IS doer-resolve
+	tempdp> ;				' (dr) plugin-of doer-resolve
 
 : (cm) ( -- addr )
     T here align H
-    -1 colon, ;					' (cm) IS colonmark,
+    -1 xt, ;					' (cm) plugin-of colonmark,
 
 >TARGET
-: compile, colon, ;
+: compile, ( xt -- )
+  dup xt>ghost >comp @ EXECUTE ;
 >CROSS
 
 \ resolve structure
@@ -1361,13 +1768,17 @@ DEFER comp[     \ ends compilation
 
 : (refered) ( ghost addr tag -- )
 \G creates a reference to ghost at address taddr
-    rot >r here r@ >link @ , r> >link ! 
+    >space
+    rot >link linked
     ( taddr tag ) ,
     ( taddr ) , 
     last-header-ghost @ , 
     loadfile , 
     sourceline# , 
-  ;
+    space>
+;
+
+' (refered) IS do-refered
 
 : refered ( ghost tag -- )
 \G creates a resolve structure
@@ -1420,33 +1831,43 @@ Defer resolve-warning
 
 \ exists                                                9may93jaw
 
-Variable TWarnings
-TWarnings on
-Variable Exists-Warnings
-Exists-Warnings on
-
 : exists ( ghost tcfa -- )
-  over GhostNames
-  BEGIN @ dup
-  WHILE 2dup cell+ @ =
-  UNTIL
-        2 cells + count
-        TWarnings @ Exists-Warnings @ and
-        IF warnhead type ."  exists"
-        ELSE 2drop THEN
-        drop swap >link !
-  ELSE  true abort" CROSS: Ghostnames inconsistent "
-  THEN ;
+\G print warning and set new target link in ghost
+  swap exists-warning
+  >link ! ;
+
+: colon-resolved   ( ghost -- )
+    >link @ colon, ; \ compile-call
+
+: prim-resolved  ( ghost -- )
+    >link @ prim, ;
+
+0 Value resolved
 
 : resolve  ( ghost tcfa -- )
 \G resolve referencies to ghost with tcfa
-    \ is ghost resolved?, second resolve means another definition with the
-    \ same name
+    dup taddr>region 0<> IF
+      2dup (>regiontype) define-addr-struct addr-xt-ghost 
+
+      \ we define new address only if empty
+      \ this is for not to take over the alias ghost
+      \ (different ghost, but identical xt)
+      \ but the very first that really defines it
+      dup @ 0= IF ! ELSE 2drop THEN
+    THEN
+
+    \ 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 !
+    r@ to resolved
+    r@ >comp @ ['] prim-forward = IF
+	['] prim-resolved  r@ >comp !  THEN
+    r@ >comp @ what's is-forward = IF
+	['] prim-resolved  r@ >comp !  THEN
     \ loop through forward referencies
     r> -rot 
     comp-state @ >r Resolving comp-state !
@@ -1458,19 +1879,15 @@ Exists-Warnings on
 
 \ gexecute ghost,                                      01nov92py
 
-: is-forward   ( ghost -- )
-  colonmark, 0 (refered) ; \ compile space for call
+: (gexecute)   ( ghost -- )
+  dup >comp @ EXECUTE ;
 
-: is-resolved   ( ghost -- )
-  >link @ colon, ; \ compile-call
-
-: gexecute   ( ghost -- )
-  dup @ <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;
+: gexecute ( ghost -- )
+  dup >magic @ <imm> = ABORT" CROSS: gexecute on immediate word"
+  (gexecute) ;
 
 : addr,  ( ghost -- )
-  dup @ <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
 
@@ -1482,27 +1899,26 @@ variable ResolveFlag
                                0 <> and ;
 
 : .forwarddefs ( ghost -- )
-	."  appeared in:"
-	>link
-	BEGIN	@ dup
-	WHILE	cr 5 spaces
-		dup >ghost @ .ghost
-		."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
-		."  line " dup >line @ .dec
-	REPEAT 
-	drop ;
-
-: ?resolved  ( ghostname -- )
-  dup cell+ @ ?touched
-  IF  	dup 
-	cell+ cell+ count cr type ResolveFlag on 
-	cell+ @ .forwarddefs
+  ."  appeared in:"
+  >link
+  BEGIN	@ dup
+  WHILE	cr 5 spaces
+	dup >ghost @ .ghost
+	."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
+	."  line " dup >line @ .dec
+  REPEAT 
+  drop ;
+
+: ?resolved  ( ghost -- )
+  dup ?touched
+  IF  	ResolveFlag on 
+	dup cr .ghost .forwarddefs
   ELSE 	drop 
   THEN ;
 
 : .unresolved  ( -- )
   ResolveFlag off cr ." Unresolved: "
-  Ghostnames
+  ghost-list
   BEGIN @ dup
   WHILE dup ?resolved
   REPEAT drop ResolveFlag @
@@ -1525,16 +1941,23 @@ variable ResolveFlag
 >CROSS
 \ Header states                                        12dec92py
 
-: flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
+\ : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
+bigendian [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
@@ -1544,10 +1967,11 @@ VARIABLE ^imm
 
 \ Target Header Creation                               01nov92py
 
+: ht-lstring, ( addr count -- )
+  dup T , H bounds  ?DO  I c@ T c, H  LOOP ;
+
 >TARGET
-: string,  ( addr count -- )
-  dup T c, H bounds  ?DO  I c@ T c, H  LOOP ; 
-: name,  ( "name" -- )  bl word count T string, cfalign H ;
+: name,  ( "name" -- )  bl word count ht-lstring, X cfalign ;
 : view,   ( -- ) ( dummy ) ;
 >CROSS
 
@@ -1568,7 +1992,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
@@ -1581,11 +2005,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-bof 1 c,  0C c,
+Create tag-tab 1 c,  09 c,
 
 2variable last-loadfilename 0 0 last-loadfilename 2!
 	    
@@ -1599,13 +2025,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
@@ -1613,28 +2039,44 @@ 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?
 
-: skipdef ( <name> -- )
+: skipdef ( "name" -- )
 \G skip definition of an undefined word in undef-words and
 \G all-words mode
-    ghost dup forward?
+    Ghost dup forward?
     IF  >magic <skip> swap !
     ELSE drop THEN ;
 
-: tdefined? ( -- flag ) \ name
-    ghost undefined? 0= ;
+: tdefined? ( "name" -- flag ) 
+    Ghost undefined? 0= ;
 
-: defined2? ( -- flag ) \ name
+: defined2? ( "name" -- flag ) 
 \G return true for anything else than forward, even for <skip>
 \G that's what we want
-    ghost forward? 0= ;
+    Ghost forward? 0= ;
 
-: forced? ( -- flag ) \ name
+: forced? ( "name" -- flag )
 \G return ture if it is a foreced skip with defskip
-    ghost >magic @ <skip> = ;
+    Ghost >magic @ <skip> = ;
 
 : needed? ( -- flag ) \ name
 \G returns a false flag when
@@ -1648,7 +2090,7 @@ Defer skip? ' false IS skip?
     ELSE  drop true  THEN ;
 
 : doer? ( -- flag ) \ name
-    ghost >magic @ <do:> = ;
+    Ghost >magic @ <do:> = ;
 
 : skip-defs ( -- )
     BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;
@@ -1673,7 +2115,10 @@ NoHeaderFlag off
 	ENDCASE
     LOOP ;
 
-: (Theader ( "name" -- ghost )
+Defer setup-execution-semantics
+0 Value lastghost
+
+: (THeader ( "name" -- ghost )
     \  >in @ bl word count type 2 spaces >in !
     \ wordheaders will always be compiled to rom
     switchrom
@@ -1689,98 +2134,142 @@ NoHeaderFlag off
     T cfalign here H tlastcfa !
     \ Old Symbol table sed-script
 \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
-    ghost
+    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 Last-Header-Ghost !
+    dup Last-Header-Ghost ! dup to lastghost
     dup >magic ^imm !     \ a pointer for immediate
-    Already @
-    IF  dup >end tdoes !
-    ELSE 0 tdoes !
-    THEN
-    80 flag!
-    cross-doc-entry cross-tag-entry ;
+    alias-mask flag!
+    cross-doc-entry cross-tag-entry 
+    setup-execution-semantics
+    ;
 
-VARIABLE ;Resolve 1 cells allot
 \ this is the resolver information from ":"
 \ resolving is done by ";"
+Variable ;Resolve 1 cells allot
+
+: hereresolve ( ghost -- )
+  there resolve 0 ;Resolve ! ;
 
 : Theader  ( "name" -- ghost )
-  (THeader dup there resolve 0 ;Resolve ! ;
+  (THeader dup hereresolve ;
+
+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 !
+  dup >created @ r@ >created !
+  rdrop drop ;
 
 >TARGET
+
 : Alias    ( cfa -- ) \ name
-    >in @ skip? IF  2drop  EXIT  THEN  >in !
-    dup 0< s" prims" T $has? H 0= and
-    IF
-	.sourcepos ." needs prim: " >in @ bl word count type >in ! cr
-    THEN
-    (THeader over resolve T A, H 80 flag! ;
-: Alias:   ( 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 ! ;
+  >in @ skip? IF  2drop  EXIT  THEN  >in !
+  (THeader ( S xt ghost )
+  2dup swap xt>ghost swap copy-execution-semantics
+  over resolve T A, H alias-mask flag! ;
+
+Variable last-prim-ghost
+0 last-prim-ghost !
+
+: asmprimname, ( ghost -- : name ) 
+  dup last-prim-ghost !
+  >r
+  here bl word count string, r@ >asm-name !
+  aprim-nr @ r> >asm-dummyaddr ! ;
+
+Defer setup-prim-semantics
+
+: mapprim   ( "forthname" "asmlabel" -- ) 
+  THeader -1 aprim-nr +! aprim-nr @ T A, H
+  asmprimname, 
+  setup-prim-semantics ;
+
+: mapprim:   ( "forthname" "asmlabel" -- ) 
+  -1 aprim-nr +! aprim-nr @
+  Ghost tuck swap resolve <do:> swap tuck >magic !
+  asmprimname, ;
+
+: 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 ! ;
 
 Variable prim#
 : first-primitive ( n -- )  prim# ! ;
 : Primitive  ( -- ) \ name
-    prim# @ T Alias H  -1 prim# +! ;
+  >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 )
+  dup >ghost-flags <primitive> set-flag
+  over resolve T A, H alias-mask flag!
+  -1 prim# +! ;
 >CROSS
 
 \ Conditionals and Comments                            11may93jaw
 
+\G saves the existing cond action, this is used for redefining in
+\G instant
+Variable cond-xt-old
+
+: cond-target ( -- )
+\G Compiles semantic of redefined cond into new one
+  cond-xt-old @ compile, ; immediate restrict
+
 : ;Cond
   postpone ;
   swap ! ;  immediate
 
-: Cond: ( -- ) \ name {code } ;
-  atonce on
-  ghost
-  >exec
+: Cond: ( "name" -- ) 
+\g defines a conditional or another word that must
+\g be executed directly while compiling
+\g these words have no interpretative semantics by default
+  Ghost
+  >exec-compile
+  dup @ cond-xt-old !
   :NONAME ;
 
-: restrict? ( -- )
-\ aborts on interprete state - ae
-  state @ 0= ABORT" CROSS: Restricted" ;
 
 : Comment ( -- )
-  >in @ atonce on ghost swap >in ! ' swap >exec ! ;
+  >in @ Ghost swap >in ! ' swap 
+  2dup >exec-compile ! >exec ! ;
 
 Comment (       Comment \
 
 \ compile                                              10may93jaw
 
-: compile  ( -- ) \ name
-  restrict?
-  bl word gfind dup 0= ABORT" CROSS: Can't compile "
-  0> ( immediate? )
-  IF    >exec @ compile,
-  ELSE  postpone literal postpone gexecute  THEN ;
-                                        immediate
-
-: [G'] 
-\G ticks a ghost and returns its address
-  bl word gfind 0= ABORT" CROSS: Ghost don't exists"
-  state @
-  IF   postpone literal
-  THEN ; immediate
-
-: ghost>cfa
-  dup undefined? ABORT" CROSS: forward " >link @ ;
-               
+: compile  ( "name" -- ) \ name
+  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 ;-) 
+: comp' X ' 0 ;
 
 Cond: [']  T ' H alit, ;Cond
 
@@ -1788,44 +2277,56 @@ 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
 
-: (>body)   ( cfa -- pfa ) xt>body + ;		' (>body) T IS >body H
+: fillcfa   ( usedcells -- )
+  T cells H xt>body swap -
+  assert1( dup 0 >= )
+  0 ?DO 0 X c, tchar +LOOP ;
 
-: (doer,)   ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ;   ' (doer,) IS doer,
+: (doer,)   ( ghost -- ) 
+  addr, 1 fillcfa ;   					' (doer,) plugin-of doer,
 
-: (docol,)  ( -- ) [G'] :docol doer, ;		' (docol,) IS docol,
+: (docol,)  ( -- ) [G'] :docol (doer,) ;		' (docol,) plugin-of docol,
 
 : (doprim,) ( -- )
-  there xt>body + ca>native T a, H 1 fillcfa ;	' (doprim,) IS 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,) IS 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,
-  T here H tcell - reloff 2 fillcfa ;		' (dodoes,) IS dodoes,
+  \ 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,
 
-: (lit,) ( n -- )   compile lit T  ,  H ;	' (lit,) IS lit,
+: (dlit,) ( n -- ) compile lit td, ;			' (dlit,) plugin-of dlit,
+
+: (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,) IS alit,
+: (alit,) ( n -- )  compile lit T  a, H ;		' (alit,) plugin-of alit,
 [ELSE]
-: (alit,) ( n -- )  lit, ;			' (alit,) IS alit,
+: (alit,) ( n -- )  lit, ;				' (alit,) plugin-of alit,
 [THEN]
 
-: (fini,)         compile ;s ;                ' (fini,) IS fini,
+: (fini,)         compile ;s ;				' (fini,) plugin-of fini,
 
 [IFUNDEF] (code) 
 Defer (code)
@@ -1843,7 +2344,7 @@ Defer (end-code)
 
 : Code:
   defempty?
-    ghost dup there ca>native resolve  <do:> swap >magic !
+    Ghost dup there ca>native resolve  <do:> swap >magic !
     depth (code) ;
 
 : end-code
@@ -1859,26 +2360,31 @@ Defer (end-code)
 >TARGET
 Cond: \G  T-\G ;Cond
 
-Cond:  Literal ( n -- )   restrict? lit, ;Cond
-Cond: ALiteral ( n -- )   restrict? alit, ;Cond
+Cond: Literal  ( n -- )   lit, ;Cond
+Cond: ALiteral ( n -- )   alit, ;Cond
 
 : Char ( "<char>" -- )  bl word char+ c@ ;
-Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond
+Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond
+
+tchar 1 = [IF]
+Cond: chars ;Cond 
+[THEN]
 
 \ some special literals					27jan97jaw
 
 \ !! Known Bug: Special Literals and plug-ins work only correct
 \ on 16 and 32 Bit Targets and 32 Bit Hosts!
 
+\ This section could be done with dlit, now. But first I need
+\ some test code JAW
+
 Cond: MAXU
-  restrict? 
   tcell 1 cells u> 
   IF	compile lit tcell 0 ?DO FF T c, H LOOP 
   ELSE	ffffffff lit, THEN
   ;Cond
 
 Cond: MINI
-  restrict?
   tcell 1 cells u>
   IF	compile lit bigendian 
   	IF	80 T c, H tcell 1 ?DO 0 T c, H LOOP 
@@ -1888,7 +2394,6 @@ Cond: MINI
   ;Cond
  
 Cond: MAXI
- restrict?
  tcell 1 cells u>
  IF	compile lit bigendian 
 	IF 	7F T c, H tcell 1 ?DO FF T c, H LOOP
@@ -1898,6 +2403,7 @@ Cond: MAXI
  ;Cond
 
 >CROSS
+
 \ Target compiling loop                                12dec92py
 \ ">tib trick thrown out                               10may93jaw
 \ number? defined at the top                           11may93jaw
@@ -1908,47 +2414,70 @@ Cond: MAXI
 \ compiled word might leave items on stack!
 : tcom ( x1 .. xn n name -- )
 \  dup count type space
-  gfind  ?dup
-  IF    >r >r discard r> r>
-	0> IF	>exec @ execute
-	ELSE	gexecute  THEN 
+  gfind 
+  IF    >r ( discard saved input state ) discard r>
+	dup >exec-compile @ ?dup
+        IF   nip execute-exec-compile ELSE gexecute  THEN 
 	EXIT 
   THEN
   number? dup  
   IF	0> IF swap lit,  THEN  lit, discard
-  ELSE	2drop restore-input throw ghost gexecute THEN  ;
+  ELSE	2drop restore-input throw Ghost gexecute THEN  ;
 
->TARGET
 \ : ; DOES>                                            13dec92py
 \ ]                                                     9may93py/jaw
 
-: ] state on
+>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 ;
+
+: 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=
               ABORT" CROSS: End of file while target compiling"
         REPEAT
         tcom
-        state @
-        0=
+        compiling? 0=
     UNTIL ;
 
 \ 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 depth T ] H ;
+  (THeader (:) ;
 
 : :noname ( -- colon-sys )
-  T cfalign H there docol, 0 ;Resolve ! depth T ] H ;
+  X cfalign there 
+  \ define a nameless ghost
+  here ghostheader dup last-header-ghost ! dup to lastghost
+  (:) ;  
 
-Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond
+Cond: EXIT ( -- )   compile ;S  ;Cond
 
 Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
 
@@ -1958,61 +2487,78 @@ Cond: ?EXIT ( -- ) 1 abort" CROSS: using
 
 >TARGET
 
-Cond: recurse ( -- ) Last-Ghost @ gexecute ;Cond
+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  ['] colon-resolved ;Resolve @ >comp !
+	    ;Resolve @ ;Resolve cell+ @ resolve 
+	THEN
+	interpreting-state
+	;Cond
 
-Cond: ; ( -- ) restrict?
-               depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
-                          ELSE true ABORT" CROSS: Stack empty" THEN
-               fini,
-               comp[
-               state off
-               ;Resolve @
-               IF ;Resolve @ ;Resolve cell+ @ resolve THEN
-		Interpreting comp-state !
-               ;Cond
-Cond: [  restrict? state off Interpreting comp-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>
+    r@ created >do:ghost ! r@ swap resolve
+    r> tlastcfa @ >tempdp dodoes, tempdp> ;
+
+Defer instant-interpret-does>-hook
+
+: does-resolved ( ghost -- )
+    compile does-exec g>xt T a, H ;
+
+: resolve-does>-part ( -- )
+\ resolve words made by builders
+  Last-Header-Ghost @ >do:ghost @ ?dup 
+  IF  there resolve  THEN ;
 
 >TARGET
-Cond: DOES> restrict?
-        compile (does>) doeshandler, 
-	\ resolve words made by builders
-	tdoes @ ?dup IF  @ T here H resolve THEN
+Cond: DOES>
+        compile (does>) doeshandler,
+        resolve-does>-part
         ;Cond
-: DOES> switchrom doeshandler, T here H !does 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 )
-  rot swap		( do:-xt Create-xt ghost )
-  >exec ! , ;
-\  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
-  >end @ dup undefined? 0=
+  >do:ghost @ dup undefined? 0=
   IF
 	dup >magic @ <do:> =
 	IF 	 doer, 
@@ -2026,35 +2572,45 @@ Cond: DOES> restrict?
   0 fillcfa
   ;
 
+: takeover-x-semantics ( S constructor-ghost new-ghost -- )
+   \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> -- )
-  executed-ghost @
   create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN
-  Theader >r dup gdoes,
-\ stores execution semantic in the built word
-\ if the word already has a semantic (concerns S", IS, .", DOES>)
-\ then keep it
-  >end @ >exec @ r> >exec dup @ ['] NoExec =
-  IF ! ELSE 2drop THEN ;
+  executed-ghost @ (Theader
+  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
-  executed-ghost @
   create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN
   \ make Alias
-  (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost )
-  \ store  poiter to code-field
+  executed-ghost @ (THeader 
+  dup >created on  dup to created
+  2dup takeover-x-semantics
+  there 0 T a, H alias-mask flag!
+  \ store poiter to code-field
   switchram T cfalign H
   there swap T ! H
   there tlastcfa ! 
-  dup there resolve 0 ;Resolve !
-  >r dup gdoes,
-\ stores execution semantic in the built word
-\ if the word already has a semantic (concerns S", IS, .", DOES>)
-\ then keep it
-  >end @ >exec @ r> >exec dup @ ['] NoExec =
-  IF ! ELSE 2drop THEN ;
+  there to createhere drop gdoes, ;
 
 : Build:  ( -- [xt] [colon-sys] )
   :noname postpone TCreate ;
@@ -2067,86 +2623,94 @@ Cond: DOES> restrict?
   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 @
-  state @ IF  gexecute true EXIT  THEN
-  >link @ T >body H false ;
+  executed-ghost @ g>body ;
 
 \ DO: ;DO                                               11may93jaw
-\ changed to ?EXIT                                      10may93jaw
 
-: DO:     ( -- addr [xt] [colon-sys] )
-  here ghostheader
-  :noname postpone gdoes> postpone ?EXIT ;
-
-: by:     ( -- addr [xt] [colon-sys] ) \ name
-  ghost
-  :noname postpone gdoes> postpone ?EXIT ;
-
-: ;DO ( addr [xt] [colon-sys] -- addr )
-  postpone ;    ( S addr xt )
-  over >exec ! ; immediate
+: do:ghost! ( ghost -- ) built >do:ghost ! ;
+: doexec! ( xt -- ) built >do:ghost @ >exec ! ;
 
-: by      ( -- addr ) \ Name
-  ghost >end @ ;
+: 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 ;
+
+: ;compile ( [xt] [colon-sys] -- )
+  postpone ; built >do:ghost @ >comp ! ; immediate
 
->TARGET
 \ Variables and Constants                              05dec92py
 
-Build:  ( n -- ) ;
-by: :docon ( ghost -- 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 ( ghost -- addr ) ;DO
 Builder Create
+BuildSmart: ;Build
+by: :dovar ( target-body-addr -- addr ) ;DO
 
+Builder Variable
 T has? rom H [IF]
-Build: ( -- ) T here 0 , 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 , 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 , H switchram T align here swap ! 0 , 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
-
 Variable tup  0 tup !
 Variable tudp 0 tudp !
 
@@ -2158,65 +2722,148 @@ Variable tudp 0 tudp !
   tup @ tudp @ + T A! H
   tudp @ dup T cell+ H tudp ! ;
 
->TARGET
-
-Build: 0 u, X , ;
-by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
 Builder User
+Build: 0 u, X , ;Build
+by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO
 
-Build: 0 u, X , 0 u, drop ;
-by User
 Builder 2User
-
-Build: 0 au, X , ;
+Build: 0 u, X , 0 u, drop ;Build
 by User
+
 Builder AUser
+Build: 0 au, X , ;Build
+by User
+
+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 -- ) ABORT" CROSS: Don't execute" ;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
+
+Builder input-method
+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 lates 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]
+
+>CROSS
+
+: (callc) compile call T >body a, H ;		' (callc) plugin-of colon,
+: (call-res) >tempdp resolved gexecute tempdp> drop ;
+                                                ' (call-res) plugin-of colon-resolve
+: (prim) dup 0< IF  $4000 -  ELSE
+    ." wrong usage of (prim) "
+    dup gdiscover IF  .ghost  ELSE  .  THEN  cr -2 throw  THEN
+    T a, H ;					' (prim) 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
 
 >CROSS
-: ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
-: sys?        ( sys -- sys )    dup 0= ?struc ;
+: (ncontrols?) ( n -- ) 
+\g We expect n open control structures
+  depth over u<= 
+  ABORT" CROSS: unstructured, stack underflow"
+  0 ?DO I pick 0= 
+        ABORT" CROSS: unstructured" 
+  LOOP ;					' (ncontrols?) plugin-of ncontrols?
+
+\ : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
+\ : sys?        ( sys -- sys )    dup 0= ?struc ;
+
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
 
 : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
@@ -2246,8 +2893,8 @@ Builder Field
 
 \ Structural Conditionals                              12dec92py
 
-Cond: BUT       restrict? sys? swap ;Cond
-Cond: YET       restrict? sys? dup ;Cond
+\ CLEANUP Cond: BUT       sys? swap ;Cond
+\ CLEANUP Cond: YET       sys? dup ;Cond
 
 >CROSS
 
@@ -2268,7 +2915,7 @@ Variable tleavings 0 tleavings !
 
 >TARGET
 
-Cond: DONE   ( addr -- )  restrict? (done) ;Cond
+\ What for? ANS? JAW Cond: DONE   ( addr -- )  (done) ;Cond
 
 >CROSS
 : (leave) ( branchtoken -- )
@@ -2279,17 +2926,24 @@ Cond: DONE   ( addr -- )  restrict? (don
     r> tleavings ! ;
 >TARGET
 
-Cond: LEAVE     restrict? branchmark, (leave) ;Cond
-Cond: ?LEAVE    restrict? compile 0=  ?branchmark, (leave)  ;Cond
+: (leave,) ( -- ) 
+  branchmark, (leave) ; 			' (leave,) plugin-of leave,
+
+: (?leave,) ( -- )
+  compile 0= ?branchmark, (leave) ; 		' (?leave,) plugin-of ?leave,
+
+Cond: LEAVE     leave, ;Cond
+Cond: ?LEAVE    ?leave, ;Cond
 
 >CROSS
 \ !!JW ToDo : Move to general tools section
 
 : to1 ( x1 x2 xn n -- addr )
-\G packs n stack elements in a allocated memory region
+\G packs n stack elements in am allocated memory region
    dup dup 1+ cells allocate throw dup >r swap 1+
    0 DO tuck ! cell+ LOOP
    drop r> ;
+
 : 1to ( addr -- x1 x2 xn )
 \G unpacks the elements saved by to1
     dup @ swap over cells + swap
@@ -2304,65 +2958,110 @@ Cond: ?LEAVE    restrict? compile 0=  ?b
 
 \ Structural Conditionals                              12dec92py
 
+: (cs-swap) ( x1 x2 -- x2 x1 )
+  swap ;					' (cs-swap) plugin-of cs-swap
+
+: (ahead,) branchmark, ; 			' (ahead,) plugin-of ahead,
+
+: (if,) ?branchmark, ; 				' (if,) plugin-of if,
+
+: (then,) branchto, branchtoresolve, ; 		' (then,) plugin-of then,
+
+: (else,) ( ahead ) branchmark, 
+          swap 
+          ( then ) branchto, branchtoresolve, ;	' (else,) plugin-of else,
+
+: (begin,) branchtomark, ; 			' (begin,) plugin-of begin,
+
+: (while,) ( if ) ?branchmark,
+           swap ; 				' (while,) plugin-of while,
+
+: (again,) branch, ;				' (again,) plugin-of again,
+
+: (until,) ?branch, ;				' (until,) plugin-of until,
+
+: (repeat,) ( again ) branch,
+            ( then ) branchto, branchtoresolve, ; ' (repeat,) plugin-of repeat,
+
+: (case,)   ( -- n )
+  0 ;						' (case,) plugin-of case,
+
+: (of,) ( n -- x1 n )
+  1+ >r 
+  compile over compile = 
+  if, compile drop r> ;				' (of,) plugin-of of,
+
+: (endof,) ( x1 n -- x2 n )
+  >r 1 ncontrols? else, r> ;			' (endof,) plugin-of endof,
+
+: (endcase,) ( x1 .. xn n -- )
+  compile drop 0 ?DO 1 ncontrols? then, LOOP ;	' (endcase,) plugin-of endcase,
+
 >TARGET
-Cond: AHEAD     restrict? branchmark, ;Cond
-Cond: IF        restrict? ?branchmark, ;Cond
-Cond: THEN      restrict? sys? branchto, branchtoresolve, ;Cond
-Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond
-
-Cond: BEGIN     restrict? branchtomark, ;Cond
-Cond: WHILE     restrict? sys? compile IF swap ;Cond
-Cond: AGAIN     restrict? sys? branch, ;Cond
-Cond: UNTIL     restrict? sys? ?branch, ;Cond
-Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
-
-Cond: CASE      restrict? 0 ;Cond
-Cond: OF        restrict? 1+ >r compile over compile =
-                compile IF compile drop r> ;Cond
-Cond: ENDOF     restrict? >r compile ELSE r> ;Cond
-Cond: ENDCASE   restrict? compile drop 0 ?DO  compile THEN  LOOP ;Cond
+Cond: AHEAD     ahead, ;Cond
+Cond: IF        if,  ;Cond
+Cond: THEN      1 ncontrols? then, ;Cond
+Cond: ENDIF     1 ncontrols? then, ;Cond
+Cond: ELSE      1 ncontrols? else, ;Cond
+
+Cond: BEGIN     begin, ;Cond
+Cond: WHILE     1 ncontrols? while, ;Cond
+Cond: AGAIN     1 ncontrols? again, ;Cond
+Cond: UNTIL     1 ncontrols? until, ;Cond
+Cond: REPEAT    2 ncontrols? repeat, ;Cond
+
+Cond: CASE      case, ;Cond
+Cond: OF        of, ;Cond
+Cond: ENDOF     endof, ;Cond
+Cond: ENDCASE   endcase, ;Cond
 
 \ Structural Conditionals                              12dec92py
 
-:noname \ ?? i think 0 is too much! jaw
+: (do,) ( -- target-addr )
+  \ ?? i think 0 is too much! jaw
     0 compile (do)
-    branchtomark,  2 to1 ;
-  IS do, ( -- target-addr )
+    branchtomark,  2 to1 ;			' (do,) plugin-of do,
 
-\ :noname
+\ alternative for if no ?do
+\ : (do,)
 \     compile 2dup compile = compile IF
 \     compile 2drop compile ELSE
 \     compile (do) branchtomark, 2 to1 ;
-\   IS ?do,
     
-:noname
+: (?do,) ( -- target-addr )
     0 compile (?do)  ?domark, (leave)
-    branchtomark,  2 to1 ;
-  IS ?do, ( -- target-addr )
-:noname compile (for) branchtomark, ;
-  IS for, ( -- target-addr )
-:noname 1to compile (loop)  loop] compile unloop skiploop] ;
-  IS loop, ( target-addr -- )
-:noname 1to compile (+loop)  loop] compile unloop skiploop] ;
-  IS +loop, ( target-addr -- )
-:noname compile (next)  loop] compile unloop ;
-  IS next, ( target-addr -- )
-
-Cond: DO      	restrict? do, ;Cond
-Cond: ?DO     	restrict? ?do, ;Cond
-Cond: FOR	restrict? for, ;Cond
-
-Cond: LOOP	restrict? sys? loop, ;Cond
-Cond: +LOOP	restrict? sys? +loop, ;Cond
-Cond: NEXT	restrict? sys? next, ;Cond
+    branchtomark,  2 to1 ;			' (?do,) plugin-of ?do,
+
+: (for,) ( -- target-addr )
+  compile (for) branchtomark, ;			' (for,) plugin-of for,
+
+: (loop,) ( target-addr -- )
+  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,
+
+Cond: DO      	do, ;Cond
+Cond: ?DO     	?do, ;Cond
+Cond: FOR	for, ;Cond
+
+Cond: LOOP	1 ncontrols? loop, ;Cond
+Cond: +LOOP	1 ncontrols? +loop, ;Cond
+Cond: NEXT	1 ncontrols? next, ;Cond
 
 \ String words                                         23feb93py
 
-: ,"            [char] " parse T string, align H ;
+: ,"            [char] " parse ht-string, X align ;
 
-Cond: ."        restrict? compile (.")     T ," H ;Cond
-Cond: S"        restrict? compile (S")     T ," H ;Cond
-Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond
+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
 
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T >address ' >body ! H ;
@@ -2370,8 +3069,6 @@ Cond: TO        T ' >body H compile ALit
 : TO            T ' >body ! H ;
 
 Cond: defers	T ' >body @ compile, H ;Cond
-: on		T -1 swap ! H ; 
-: off   	T 0 swap ! H ;
 
 \ LINKED ERR" ENV" 2ENV"                                18may93jaw
 
@@ -2380,30 +3077,29 @@ Cond: defers	T ' >body @ compile, H ;Con
 : chained	T linked A, H ;
 
 : err"   s" ErrLink linked" evaluate T , H
-         [char] " parse T string, align H ;
+         [char] " parse ht-string, X align ;
 
 : env"  [char] " parse s" EnvLink linked" evaluate
-        T string, align , H ;
+        ht-string, X align X , ;
 
 : 2env" [char] " parse s" EnvLink linked" evaluate
-        here >r T string, align , , H
+        here >r ht-string, X align X , X ,
         r> dup T c@ H 80 and swap T c! H ;
 
 \ compile must be last                                 22feb93py
 
-Cond: compile ( -- ) restrict? \ name
-      bl word gfind dup 0= ABORT" CROSS: Can't compile"
-      0> IF    gexecute
-         ELSE  dup >magic @ <imm> =
-               IF   gexecute
-               ELSE compile (compile) addr, THEN THEN ;Cond
-
-Cond: postpone ( -- ) restrict? \ name
-      bl word gfind dup 0= ABORT" CROSS: Can't compile"
-      0> IF    gexecute
-         ELSE  dup >magic @ <imm> =
-               IF   gexecute
-	       ELSE compile (compile) addr, THEN THEN ;Cond
+Cond: [compile] ( -- ) \ name
+\g For immediate words, works even if forward reference
+      bl word gfind 0= ABORT" CROSS: Can't compile"
+      (gexecute) ;Cond
+	   
+Cond: postpone ( -- ) \ name
+      bl word gfind 0= ABORT" CROSS: Can't compile"
+      dup >magic @ <fwd> =
+      ABORT" CROSS: Can't postpone on forward declaration"
+      dup >magic @ <imm> =
+      IF   (gexecute)
+      ELSE compile (compile) addr, THEN ;Cond
 	   
 \ save-cross                                           17mar93py
 
@@ -2426,7 +3122,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
@@ -2442,7 +3138,7 @@ magic 7 + c!
   THEN
   image @ there 
   r@ write-file throw \ write image
-  TNIL IF
+  s" relocate" X $has? IF
       bit$  @ there 1- tcell>bit rshift 1+
                 r@ write-file throw \ write tags
   THEN
@@ -2453,6 +3149,214 @@ magic 7 + c!
   swap >image swap r@ write-file throw
   r> close-file throw ;
 
+\ save-asm-region                         		29aug01jaw
+
+Variable name-ptr
+Create name-buf 200 chars allot
+: init-name-buf name-buf name-ptr ! ;
+: nb, name-ptr @ c! 1 chars name-ptr +! ;
+: $nb, ( adr len -- ) bounds ?DO I c@ nb, LOOP ;
+: @nb name-ptr @ name-buf tuck - ;
+
+\ stores a usefull string representation of the character
+\ in the name buffer
+: name-char, ( c -- )
+  dup 'a 'z 1+ within IF nb, EXIT THEN
+  dup 'A 'Z 1+ within IF $20 + nb, EXIT THEN
+  dup '0 '9 1+ within IF nb, EXIT THEN
+  CASE '+ OF s" _PLUS" $nb, ENDOF
+       '- OF s" _MINUS" $nb, ENDOF
+       '* OF s" _STAR" $nb, ENDOF
+       '/ OF s" _SLASH" $nb, ENDOF
+       '' OF s" _TICK" $nb, ENDOF
+       '( OF s" _OPAREN" $nb, ENDOF
+       ') OF s" _CPAREN" $nb, ENDOF
+       '[ OF s" _OBRACKET" $nb, ENDOF
+       '] OF s" _CBRACKET" $nb, ENDOF
+       '! OF s" _STORE" $nb, ENDOF
+       '@ OF s" _FETCH" $nb, ENDOF
+       '> OF s" _GREATER" $nb, ENDOF
+       '< OF s" _LESS" $nb, ENDOF
+       '= OF s" _EQUAL" $nb, ENDOF
+       '# OF s" _HASH" $nb, ENDOF
+       '? OF s" _QUEST" $nb, ENDOF
+       ': OF s" _COL" $nb, ENDOF
+       '; OF s" _SEMICOL" $nb, ENDOF
+       ', OF s" _COMMA" $nb, ENDOF
+       '. OF s" _DOT" $nb, ENDOF
+       '" OF s" _DQUOT" $nb, ENDOF
+       dup 
+       base @ >r hex s>d <# #s 'X hold '_ hold #> $nb, r> base !
+  ENDCASE ;
+ 
+: label-from-ghostname ( ghost -- addr len )
+  dup >ghostname init-name-buf 'L nb, bounds 
+  ?DO I c@ name-char, LOOP 
+  \ we add the address to a name to make in unique
+  \ because one name may appear more then once
+  \ there are names (e.g. boot) that may be reference from other
+  \ assembler source files, so we declare them as unique
+  \ and don't add the address suffix
+  dup >ghost-flags @ <unique> and 0= 
+  IF   s" __" $nb, >link @ base @ >r hex 0 <# #s 'L hold #> r> base ! $nb, 
+  ELSE drop 
+  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
+ \ dup >r (label-from-ghostname) 2dup
+  align here >r string, align
+  r> r> >asm-name ! ;
+
+: primghostdiscover ( xt -- ghost true | xt false )
+  dup 0= IF false EXIT THEN
+  >r last-prim-ghost
+  BEGIN @ dup
+  WHILE dup >asm-dummyaddr @ r@ =
+        IF rdrop true EXIT THEN
+  REPEAT
+  drop r> false ;
+
+: gdiscover2 ( xt -- ghost true | xt false ) 
+  dup taddr>region 0= IF false EXIT THEN
+  dup (>regiontype) @ dup 0= IF drop false EXIT THEN
+  addr-xt-ghost @ dup 0= IF drop false EXIT THEN
+  nip true ;
+\  dup >ghost-name @ IF nip true ELSE drop false THEN ;
+
+\ generates a label name for the target address
+: generate-label-name ( taddr -- addr len )
+  gdiscover2
+  IF dup >magic @ <do:> =
+     IF >asm-name @ count EXIT THEN
+     label-from-ghostname
+  ELSE
+     primghostdiscover
+     IF   >asm-name @ count 
+     ELSE base @ >r hex 0 <# #s 'L hold #> r> base !
+     THEN
+  THEN ;
+
+Variable outfile-fd
+
+: $out ( adr len -- ) outfile-fd @ write-file throw  ;
+: nlout newline $out ;
+: .ux ( n -- ) 
+  base @ hex swap 0 <# #S #> $out base ! ;
+
+: save-asm-region-part-aligned ( taddr len -- 'taddr 'len )
+  dup cell/ 0 
+  ?DO nlout s"    .word " $out over @relbit 
+      IF   over X @ generate-label-name $out
+      ELSE over X @ s" 0x0" $out .ux
+      THEN
+      tcell /string
+  LOOP ;
+
+: print-bytes ( taddr len n -- taddr' len' )
+  over min dup 0> 
+  IF   nlout s"    .byte " $out 0 
+       ?DO  I 0> IF s" , " $out THEN
+            over X c@ s" 0x0" $out .ux 1 /string 
+       LOOP 
+  THEN ;
+
+: save-asm-region-part ( addr len -- )
+  over dup X aligned swap - ?dup
+  IF   print-bytes THEN
+  save-asm-region-part-aligned
+  dup dup X aligned swap - ?dup
+  IF   2 pick @relbit ABORT" relocated field splitted"
+       print-bytes
+  THEN
+  2drop ;
+
+: print-label ( taddr -- )
+  nlout generate-label-name $out s" :" $out ;
+
+: snl-calc ( taddr taddr2 -- )
+  tuck over - ;
+
+: skip-nolables ( taddr -- taddr2 taddr len )
+\G skips memory region where no lables are defined
+\G starting from taddr+1
+\G Labels will be introduced for each reference mark
+\G in addr-refs.
+\G This word deals with lables at byte addresses as well.
+\G The main idea is to have an intro part which
+\G skips until the next cell boundary, the middle part
+\G which skips whole cells very efficiently and the third
+\G part which skips the bytes to the label in a cell
+  dup 1+ dup (>regiontype) 
+  ( S taddr taddr-realstart type-addr )
+  dup @ dup IF addr-refs @ THEN
+  swap >r
+  over align+ tuck tcell swap - rshift swap 0
+  DO dup 1 and 
+     IF drop rdrop snl-calc UNLOOP EXIT THEN 
+     2/ swap 1+ swap 
+  LOOP
+  drop r> cell+
+  ( S .. taddr2 type-addr ) dup
+  BEGIN dup @ dup IF addr-refs @ THEN 0= WHILE cell+ REPEAT
+  dup >r swap - 1 cells / tcell * + r>
+  ( S .. taddr2+skiplencells type-addr )
+  @ addr-refs @ 1 tcell lshift or
+  BEGIN dup 1 and 0= WHILE swap 1+ swap 2/ REPEAT drop
+  ( S .. taddr2+skiplencells+skiplenbytes )
+  snl-calc ;
+
+: insert-label ( taddr -- )
+  dup 0= IF drop EXIT THEN
+  \ ignore everything which points outside our memory regions
+  \ maybe a primitive pointer or whatever
+  dup taddr>region 0= IF drop EXIT THEN
+  dup >r (>regiontype) define-addr-struct addr-refs dup @ 
+  r> tcell 1- and 1 swap lshift or swap ! ;
+
+\ this generates a sorted list of addresses which must be labels
+\ it scans therefore a whole region
+: generate-label-list-region ( taddr len -- )
+  BEGIN over @relbit IF over X @ insert-label THEN
+        tcell /string dup 0< 
+  UNTIL 2drop ;
+
+: generate-label-list ( -- )
+  region-link
+  BEGIN @ dup WHILE 
+        dup 0 >rlink - extent 
+        ?dup IF generate-label-list-region ELSE drop THEN
+  REPEAT drop ;
+
+: create-outfile ( addr len -- )
+  w/o bin create-file throw outfile-fd ! ;
+
+: close-outfile ( -- )
+  outfile-fd @ close-file throw ;
+
+: (save-asm-region) ( region -- )
+  \ ." label list..."
+  generate-label-list
+  \ ." ok!" cr
+  extent ( S taddr len )
+  over insert-label
+  2dup + dup insert-label >r ( R end-label )
+  ( S taddr len ) drop
+  BEGIN
+     dup print-label
+     dup r@ <> WHILE
+     skip-nolables save-asm-region-part
+  REPEAT drop rdrop ;
+
+: lineout ( addr len -- )
+  outfile-fd @ write-line throw ;  
+
+: save-asm-region ( region adr len -- )
+  create-outfile (save-asm-region) close-outfile ;
+
 \ \ minimal definitions
 	   
 >MINIMAL also minimal
@@ -2464,8 +3368,8 @@ magic 7 + c!
 \ \ [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
@@ -2561,7 +3465,7 @@ Cond: \D \D ;Cond
 
 : needed:
 \G defines ghost for words that we want to be compiled
-  BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;
+  BEGIN >in @ bl word c@ WHILE >in ! Ghost drop REPEAT drop ;
 
 \ words that should be in minimal
 
@@ -2580,7 +3484,20 @@ bigendian Constant bigendian
 : >tempdp >tempdp ;
 : tempdp> tempdp> ;
 : const constflag on ;
-: warnings name 3 = 0= twarnings ! drop ;
+
+: Redefinitions-start
+\G Starts a redefinition section. Warnings are disabled and
+\G existing ghosts are reused. This is used in the kernel
+\G where ( and \ and the like are redefined
+  twarnings off warnings off reuse-ghosts on ;
+
+: Redefinitions-end
+\G Ends a redefinition section. Warnings are enabled again.
+  twarnings on warnings on reuse-ghosts off ;
+
+: warnings name 3 = 
+  IF twarnings off warnings off ELSE twarnings on warnings on THEN drop ;
+
 : | ;
 \ : | NoHeaderFlag on ; \ This is broken (damages the last word)
 
@@ -2614,7 +3531,7 @@ previous
 : 0=   0= ;
 : lshift lshift ;
 : 2/ 2/ ;
-: . . ;
+\ : . . ;
 
 : all-words    ['] forced?    IS skip? ;
 : needed-words ['] needed?  IS skip? ;
@@ -2625,7 +3542,9 @@ previous
 : \G T-\G ; immediate
 : (  postpone ( ;  immediate
 : include bl word count included ;
+: included swap >image swap included ;
 : require require ;
+: needs require ;
 : .( [char] ) parse type ;
 : ." [char] " parse type ;
 : cr cr ;
@@ -2636,8 +3555,8 @@ previous
 
 \ cross-compiler words
 
-: decimal       decimal ;
-: hex           hex ;
+: decimal       decimal [g'] decimal >exec2 @ ?dup IF EXECUTE THEN ;
+: hex           hex [g'] hex >exec2 @ ?dup IF EXECUTE THEN ;
 
 \ : tudp          X tudp ;
 \ : tup           X tup ;
@@ -2645,39 +3564,60 @@ previous
 : doc-off       false to-doc ! ;
 : doc-on        true  to-doc ! ;
 
-[IFDEF] dbg : dbg dbg ; [THEN]
+: 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.
+  Ghost >ghost-flags dup @ <unique> or swap ! ;
+
+\ [IFDEF] dbg : dbg dbg ; [THEN]
 
 \ for debugging...
-: order         order ;
-: hwords         words ;
-: words 	also ghosts words previous ;
+\ : dbg dbg ;
+: horder         order ;
+: hwords        words ;
+\ : words 	also ghosts 
+\                words previous ;
 : .s            .s ;
 : bye           bye ;
 
+\ dummy
+: group 0 word drop ;
+
 \ turnkey direction
 : H forth ; immediate
 : T minimal ; immediate
 : G ghosts ; immediate
 
-: turnkey 
-   \GFORTH 0 set-order also ghosts
-   \ANSI [ ' ghosts >wordlist ] Literal 1 set-order
-   also target definitions
-   also Minimal also ;
 
 \ these ones are pefered:
 
-: lock   turnkey ;
 : unlock previous forth also cross ;
 
 \ also minimal
-: [[ also unlock ;
-: ]] previous previous also also ;
+>cross
+
+: turnkey 
+   ghosts-wordlist 1 set-order
+   also target definitions
+   also Minimal also ;
+
+>minimal
+
+: [[+++
+  turnkey unlock ;
 
 unlock definitions also minimal
-: lock   lock ;
-lock
 
+: lock   turnkey ;
+
+Defer +++]]-hook
+: +++]] +++]]-hook lock ;
+
+LOCK
 \ load cross compiler extension defined in mach file
 
 UNLOCK >CROSS