--- gforth/cross.fs	2001/09/12 14:55:54	1.114
+++ gforth/cross.fs	2002/01/04 20:31:53	1.117
@@ -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
 
@@ -705,6 +712,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 -- )
@@ -1007,10 +1015,13 @@ Variable reuse-ghosts reuse-ghosts off
 
 \ ' >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.
@@ -1061,8 +1072,15 @@ Ghost :dovar					drop
 Ghost over      Ghost =         Ghost drop      2drop drop
 Ghost 2drop drop
 Ghost 2dup drop
-
-
+Ghost state drop
+Ghost call drop
+Ghost @ drop
+Ghost useraddr drop
+Ghost execute drop
+Ghost + drop
+Ghost (C") drop
+Ghost decimal drop
+Ghost hex drop
 
 \ \ Parameter for target systems                         06oct92py
 
@@ -1677,9 +1695,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 ]comp xt, comp[ tempdp> ; 	' (cr) plugin-of colon-resolve
 : (ar) T ! H ;					' (ar) plugin-of addr-resolve
 : (dr)  ( ghost res-pnt target-addr addr )
 	>tempdp drop over 
@@ -1691,7 +1710,7 @@ previous
 
 : (cm) ( -- addr )
     T here align H
-    -1 prim, ;					' (cm) plugin-of colonmark,
+    -1 xt, ;					' (cm) plugin-of colonmark,
 
 >TARGET
 : compile, ( xt -- )
@@ -1783,7 +1802,7 @@ Defer resolve-warning
 
 \ FIXME: not used currently
 : does-resolved ( ghost -- )
-    dup g>body alit, >do:ghost @ g>body colon, ;
+    dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ;
 
 : (is-forward)   ( ghost -- )
   colonmark, 0 (refered) ; \ compile space for call
@@ -1947,11 +1966,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!
 	    
@@ -1965,13 +1986,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
@@ -1979,6 +2000,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?
@@ -2087,6 +2124,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 !
@@ -2133,8 +2171,8 @@ Defer setup-prim-semantics
 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
@@ -2177,8 +2215,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
@@ -2200,7 +2237,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
@@ -2325,6 +2363,7 @@ Cond: MAXI
  ;Cond
 
 >CROSS
+
 \ Target compiling loop                                12dec92py
 \ ">tib trick thrown out                               10may93jaw
 \ number? defined at the top                           11may93jaw
@@ -2345,10 +2384,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 !
@@ -2363,6 +2403,8 @@ Cond: MAXI
    IF >ghost-xt @ execute X off ELSE drop THEN
    Interpreting comp-state ! ;
 
+>TARGET
+
 : ] 
     compiling-state
     BEGIN
@@ -2426,26 +2468,20 @@ 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
 
 : 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>
@@ -2454,6 +2490,7 @@ Cond: DOES>
         ;Cond
 
 : DOES> switchrom doeshandler, T here H !does 
+  ['] does-resolved created >comp !
   instant-interpret-does>-hook
   depth T ] H ;
 
@@ -2473,7 +2510,6 @@ Cond: DOES>
   ghost to built 
   built >created @ 0= IF
     built >created on
-    ['] prim-resolved built >comp ! 
   THEN ;
 
 : gdoes,  ( ghost -- )
@@ -2493,8 +2529,8 @@ Cond: DOES>
   ;
 
 : takeover-x-semantics ( S constructor-ghost new-ghost -- )
-\g stores execution semantic and compilation semantic in the built word
-   swap >do: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
@@ -2506,7 +2542,7 @@ Cond: DOES>
   create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN
   executed-ghost @ (Theader
-  dup >created on
+  dup >created on  dup to created
   2dup takeover-x-semantics hereresolve gdoes, ;
 
 : RTCreate ( <name> -- )
@@ -2715,6 +2751,10 @@ T has? peephole H [IF]
 
 >CROSS
 : (callc) compile call T >body a, H ;		' (callc) plugin-of colon,
+: (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!!
@@ -2729,7 +2769,7 @@ compile: g>body alit, compile @ ;compile
 
 \ this changes also Variable, AVariable and 2Variable
 Builder Create
-\ compile: g>body alit, ;compile
+compile: g>body alit, ;compile
 
 Builder User
 compile: g>body compile useraddr T @ , H ;compile
@@ -2740,6 +2780,15 @@ compile: g>body alit, compile @ compile
 Builder (Field)
 compile: g>body T @ H lit, compile + ;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