--- gforth/cross.fs	2001/09/05 11:01:27	1.107
+++ gforth/cross.fs	2002/03/19 11:13:08	1.120
@@ -202,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
 
@@ -242,21 +249,26 @@ 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 	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
+: 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:
 
@@ -705,6 +717,7 @@ Plugin branchtoresolve, ( branch-addr --
 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 -- )
@@ -891,10 +904,19 @@ Variable cross-space-dp-orig
   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 , ['] is-forward , 
-  0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
+    ghost-list linked <fwd> , 0 , ['] NoExec , what's is-forward ,
+    0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
 
 : ghostheader ( -- ) (ghostheader) 0 , ;
 
@@ -986,7 +1008,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 
@@ -1003,17 +1024,18 @@ 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
 
 : g>xt ( ghost -- xt )
 \G Returns the xt (cfa) of a ghost. Issues a warning if undefined.
@@ -1044,32 +1066,43 @@ 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
 
+' 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
 
 
->cross
 \ we define it ans like...
 wordlist Constant target-environment
 
@@ -1145,8 +1178,11 @@ true DefaultValue standardthreading
 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
 
@@ -1227,6 +1263,10 @@ Variable mirrored-link          \ linked
 : >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
@@ -1240,8 +1280,7 @@ Variable mirrored-link          \ linked
 	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 ) 
@@ -1359,8 +1398,11 @@ T has? rom H
 
 \ 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 ;
@@ -1612,6 +1654,29 @@ 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
 
@@ -1640,8 +1705,8 @@ T has? relocate H
 >TARGET
 
 : count dup X c@ swap X char+ swap ;
-\ FIXME -1 on 64 bit machines?!?!
-: on		T -1 swap ! H ; 
+
+: on		-1 -1 rot TD!  ; 
 : off   	T 0 swap ! H ;
 
 : tcmove ( source dest len -- )
@@ -1670,9 +1735,10 @@ previous
 >CROSS
 
 : (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 prim, 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 
@@ -1684,7 +1750,7 @@ previous
 
 : (cm) ( -- addr )
     T here align H
-    -1 colon, ;					' (cm) plugin-of colonmark,
+    -1 xt, ;					' (cm) plugin-of colonmark,
 
 >TARGET
 : compile, ( xt -- )
@@ -1710,7 +1776,9 @@ previous
     loadfile , 
     sourceline# , 
     space>
-  ;
+;
+
+' (refered) IS do-refered
 
 : refered ( ghost tag -- )
 \G creates a resolve structure
@@ -1774,13 +1842,7 @@ Defer resolve-warning
 : prim-resolved  ( ghost -- )
     >link @ prim, ;
 
-\ FIXME: not activated
-: does-resolved ( ghost -- )
-    dup g>body alit, >do:ghost @ g>body colon, ;
-
-: (is-forward)   ( ghost -- )
-  colonmark, 0 (refered) ; \ compile space for call
-' (is-forward) IS is-forward
+0 Value resolved
 
 : resolve  ( ghost tcfa -- )
 \G resolve referencies to ghost with tcfa
@@ -1801,7 +1863,10 @@ Defer resolve-warning
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )
     \ mark ghost as resolved
     dup r@ >link ! <res> r@ >magic !
-    r@ >comp @ ['] is-forward = IF
+    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 
@@ -1814,22 +1879,16 @@ Defer resolve-warning
 
 \ gexecute ghost,                                      01nov92py
 
-\ FIXME cleanup
-\ : is-resolved   ( ghost -- )
-\  >link @ colon, ; \ compile-call
-
 : (gexecute)   ( ghost -- )
   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 forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
 
-\ !! : ghost,     ghost  gexecute ;
-
 \ .unresolved                                          11may93jaw
 
 variable ResolveFlag
@@ -1946,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!
 	    
@@ -1964,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
@@ -1978,6 +2039,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?
@@ -2086,6 +2163,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 !
@@ -2111,29 +2189,30 @@ 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 !
   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 <do:> swap >magic ! ;
 
 Variable prim#
 : first-primitive ( n -- )  prim# ! ;
 : 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
@@ -2176,8 +2255,7 @@ 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
@@ -2199,7 +2277,8 @@ Cond: [']  T ' H alit, ;Cond
 
 : [T']
 \ returns the target-cfa of a ghost, or compiles it as literal
-  postpone [G'] state @ IF postpone g>xt ELSE g>xt THEN ; immediate
+  postpone [G'] 
+  state @ IF postpone g>xt ELSE g>xt THEN ; immediate
 
 \ \ threading modell					13dec92py
 \ modularized						14jun97jaw
@@ -2223,10 +2302,10 @@ T 2 cells H Value xt>body
   there xt>body + ca>native T a, H 1 fillcfa ;		' (doprim,) plugin-of doprim,
 
 : (doeshandler,) ( -- ) 
-  T cfalign H 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
@@ -2324,6 +2403,7 @@ Cond: MAXI
  ;Cond
 
 >CROSS
+
 \ Target compiling loop                                12dec92py
 \ ">tib trick thrown out                               10may93jaw
 \ number? defined at the top                           11may93jaw
@@ -2344,10 +2424,11 @@ 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 !
@@ -2362,6 +2443,8 @@ Cond: MAXI
    IF >ghost-xt @ execute X off ELSE drop THEN
    Interpreting comp-state ! ;
 
+>TARGET
+
 : ] 
     compiling-state
     BEGIN
@@ -2376,22 +2459,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
 
@@ -2414,8 +2498,8 @@ Cond: ; ( -- )
 	fini,
 	comp[
 	;Resolve @ 
-	IF 	;Resolve @ ;Resolve cell+ @ resolve 
-		['] colon-resolved ;Resolve @ >comp !
+	IF  ['] colon-resolved ;Resolve @ >comp !
+	    ;Resolve @ ;Resolve cell+ @ resolve 
 	THEN
 	interpreting-state
 	;Cond
@@ -2424,26 +2508,23 @@ 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 
-        \ TODO: set special DOES> resolver action here
-  THEN ;
+  IF  there resolve  THEN ;
 
 >TARGET
 Cond: DOES>
@@ -2451,28 +2532,29 @@ Cond: DOES>
         resolve-does>-part
         ;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
 
+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 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-ghost ghost )
-  dup >created on
-  rot swap		( do-ghost Create-xt ghost )
-  tuck >exec ! 
-  tuck >do:ghost ! 
-  ['] prim-resolved over >comp !
-  drop ;
+  ghost to built 
+  built >created @ 0= IF
+    built >created on
+  THEN ;
 
 : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built
@@ -2491,25 +2573,29 @@ Cond: DOES>
   ;
 
 : takeover-x-semantics ( S constructor-ghost new-ghost -- )
-\g stores execution semantic and compilation semantic in the built word
-\g if the word already has a semantic (concerns S", IS, .", DOES>)
-\g then keep it
-   swap >do:ghost @ 
-   \ we use the >exec2 field for the semantic of a crated word,
-   \ so predefined semantics e.g. for ....
-   \ FIXME: find an example in the normal kernel!!!
+   \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 ! ;
-\ old version of this:
-\  >exec dup @ ['] NoExec = 
-\  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;
+
+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
@@ -2517,14 +2603,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 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 ;
@@ -2537,98 +2623,94 @@ 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 @
-\ FIXME: cleanup
-\  compiling? ABORT" CROSS: Executing gdoes> while compiling"
-\ ?! compiling? IF  gexecute true EXIT  THEN
-  g>body ( false ) ;
+  executed-ghost @ g>body ;
 
 \ DO: ;DO                                               11may93jaw
-\ changed to ?EXIT                                      10may93jaw
 
-: DO:     ( -- do-ghost [xt] [colon-sys] )
-  here ghostheader
-  :noname postpone gdoes> ( postpone ?EXIT ) ;
+: do:ghost! ( ghost -- ) built >do:ghost ! ;
+: doexec! ( xt -- ) built >do:ghost @ >exec ! ;
 
-: by:     ( -- do-ghost [xt] [colon-sys] ) \ name
-  Ghost
-  :noname postpone gdoes> ( postpone ?EXIT ) ;
+: DO:     ( -- [xt] [colon-sys] )
+  here ghostheader do:ghost!
+  :noname postpone gdoes> ;
 
-: ;DO ( do-ghost [xt] [colon-sys] -- do-ghost )
-  postpone ;    ( S addr xt )
-  over >exec ! ; immediate
+: by:     ( -- [xt] [colon-sys] ) \ name
+  Ghost do:ghost!
+  :noname postpone gdoes> ;
 
-: by      ( -- do-ghost ) \ Name
-  Ghost >do:ghost @ ;
+: ;DO ( [xt] [colon-sys] -- )
+  postpone ; doexec! ; immediate
 
-: compile: ( do-ghost -- do-ghost [xt] [colon-sys] )
+: 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 ( do-ghost [xt] [colon-sys] -- do-ghost )
-  postpone ;  over >comp ! ; immediate
-
+: ;compile ( [xt] [colon-sys] -- )
+  postpone ; built >do:ghost @ >comp ! ; immediate
 
-
->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
-
 Variable tup  0 tup !
 Variable tudp 0 tudp !
 
@@ -2640,74 +2722,133 @@ 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 -- ) 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 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
 
@@ -2981,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
@@ -2997,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
@@ -3008,7 +3149,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
@@ -3062,6 +3203,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
@@ -3215,8 +3357,6 @@ Variable outfile-fd
 : save-asm-region ( region adr len -- )
   create-outfile (save-asm-region) close-outfile ;
 
-[THEN]
-
 \ \ minimal definitions
 	   
 >MINIMAL also minimal
@@ -3228,8 +3368,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
@@ -3485,6 +3625,3 @@ UNLOCK >CROSS
 [IFDEF] extend-cross extend-cross [THEN]
 
 LOCK
-
-
-