--- gforth/cross.fs	2001/09/05 10:18:46	1.106
+++ gforth/cross.fs	2001/09/05 11:45:38	1.108
@@ -23,11 +23,11 @@
 [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]
 
@@ -690,6 +690,7 @@ Variable ppi-temp 0 ppi-temp !
   POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate
 
 
+Plugin dlit, ( d -- )			\ compile numerical value the target
 Plugin lit, ( n -- )
 Plugin alit, ( n -- )
 
@@ -1612,32 +1613,14 @@ T has? relocate H
 : A,    ( w -- )        >address T here H relon T , H ;
 
 
->CROSS
-
-: tcmove ( source dest len -- )
-\G cmove in target memory
-  tchar * bounds
-  ?DO  dup T c@ H I T c! H 1+
-  tchar +LOOP  drop ;
-
-
-\ \ Load Assembler
-
->TARGET
-H also Forth definitions
-
-\ 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
-
 \ \ --------------------        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 = )
@@ -1661,6 +1644,29 @@ previous
 : on		T -1 swap ! H ; 
 : 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
+
+\ 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
 
 : (cc) T a, H ;					' (cc) plugin-of colon,
@@ -1682,8 +1688,7 @@ previous
 
 >TARGET
 : compile, ( xt -- )
-  dup xt>ghost >ghost-flags <primitive> get-flag
-  IF prim, ELSE colon, THEN ;
+  dup xt>ghost >comp @ EXECUTE ;
 >CROSS
 
 \ resolve structure
@@ -1817,7 +1822,7 @@ Defer resolve-warning
   dup >comp @ EXECUTE ;
 
 : gexecute ( ghost -- )
-  dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN
+\  dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN
   (gexecute) ;
 
 : addr,  ( ghost -- )
@@ -2228,7 +2233,9 @@ T 2 cells H Value xt>body
   [ 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,) plugin-of 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,
@@ -2281,7 +2288,7 @@ Cond: ALiteral ( n -- )   alit, ;Cond
 Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond
 
 tchar 1 = [IF]
-Cond: chars ;Cond 
+\ Cond: chars ;Cond 
 [THEN]
 
 \ some special literals					27jan97jaw
@@ -2289,6 +2296,9 @@ Cond: chars ;Cond
 \ !! 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
   tcell 1 cells u> 
   IF	compile lit tcell 0 ?DO FF T c, H LOOP 
@@ -2446,23 +2456,24 @@ Cond: DOES>
   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 		( Create-xt do-ghost ghost )
+  to built 
+  built >created @ 0= IF
+    built >created on
+    ['] prim-resolved built >comp ! 
+  THEN ;
 
 : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built
@@ -2527,6 +2538,9 @@ Cond: DOES>
   postpone TCreate 
   [ [THEN] ] ;
 
+: ;Build
+  postpone ; built >exec ! ; immediate
+
 : gdoes>  ( ghost -- addr flag )
   executed-ghost @
 \ FIXME: cleanup
@@ -2537,72 +2551,80 @@ Cond: DOES>
 \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw
 
-: DO:     ( -- ghost [xt] [colon-sys] )
-  here ghostheader
+: do:ghost! ( ghost -- ) built >do:ghost ! ;
+: doexec! ( xt -- ) built >do:ghost @ >exec ! ;
+
+: DO:     ( -- [xt] [colon-sys] )
+  here ghostheader do:ghost!
   :noname postpone gdoes> ( postpone ?EXIT ) ;
 
-: by:     ( -- ghost [xt] [colon-sys] ) \ name
-  Ghost
+: by:     ( -- [xt] [colon-sys] ) \ name
+  Ghost do:ghost!
   :noname postpone gdoes> ( postpone ?EXIT ) ;
 
-: ;DO ( ghost [xt] [colon-sys] -- addr )
-  postpone ;    ( S addr xt )
-  over >exec ! ; immediate
+: ;DO ( [xt] [colon-sys] -- )
+  postpone ; doexec! ; immediate
+
+: by      ( -- do-ghost ) \ Name
+  Ghost >do:ghost @ do:ghost! ;
+
+: compile: ( do-ghost -- do-ghost [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 ;  built >do:ghost @ >comp ! ; immediate
 
-: by      ( -- addr ) \ Name
-  Ghost >do:ghost @ ;
 
 >TARGET
 \ Variables and Constants                              05dec92py
 
-Build:  ( n -- ) ;
-by: :docon ( target-body-addr -- n ) T @ H ;DO
 Builder (Constant)
+Build:  ( n -- ) ;Build
+by: :docon ( target-body-addr -- n ) T @ H ;DO
 
-Build:  ( n -- ) T , H ;
-by (Constant)
 Builder Constant
-
-Build:  ( n -- ) T A, H ;
+Build:  ( n -- ) T , H ;Build
 by (Constant)
+
 Builder AConstant
+Build:  ( n -- ) T A, H ;Build
+by (Constant)
 
-Build:  ( d -- ) T , , H ;
-DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
 Builder 2Constant
+Build:  ( d -- ) T , , H ;Build
+DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
 
-BuildSmart: ;
-by: :dovar ( target-body-addr -- addr ) ;DO
 Builder Create
+BuildSmart: ;Build
+by: :dovar ( target-body-addr -- addr ) ;DO
 
+Builder Variable
 T has? rom H [IF]
-Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;
+Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;Build
 by (Constant)
-Builder Variable
 [ELSE]
-Build: T 0 , H ;
+Build: T 0 , H ;Build
 by Create
-Builder Variable
 [THEN]
 
+Builder 2Variable
 T has? rom H [IF]
-Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;
+Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;Build
 by (Constant)
-Builder 2Variable
 [ELSE]
-Build: T 0 , 0 , H ;
+Build: T 0 , 0 , H ;Build
 by Create
-Builder 2Variable
 [THEN]
 
+Builder AVariable
 T has? rom H [IF]
-Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;
+Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;Build
 by (Constant)
-Builder AVariable
 [ELSE]
-Build: T 0 A, H ;
+Build: T 0 A, H ;Build
 by Create
-Builder AVariable
 [THEN]
 
 \ User variables                                       04may94py
@@ -2622,35 +2644,39 @@ Variable tudp 0 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 immediate A, A, H ;Build
+DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
 
 \ Sturctures                                           23feb95py
 
@@ -2660,15 +2686,15 @@ Builder interpret/compile:
  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
 
 : struct  T 1 chars 0 H ;
 : end-struct  T 2Constant H ;
@@ -2678,16 +2704,50 @@ Builder Field
 
 \ 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]
 
+: (cc) compile call T >body a, H ;		' (cc) IS colon,
+
+Builder (Constant)
+compile: g>body X @ lit, ;compile
+
+Builder (Value)
+compile: g>body alit, compile @ ;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 alit, compile @ compile execute ;compile
+
+Builder (Field)
+compile: g>body T @ H lit, compile + ;compile
+
+[THEN]
 
 \ structural conditionals                              17dec92py