Diff for /gforth/cross.fs between versions 1.105 and 1.111

version 1.105, 2001/09/05 09:42:38 version 1.111, 2001/09/06 08:14:16
Line 23 Line 23
 [IF]  [IF]
   
 ToDo:  ToDo:
 Crossdoc destination ./doc/crossdoc.fd makes no sense when  - Crossdoc destination ./doc/crossdoc.fd makes no sense when
 cross.fs is uses seperately. jaw    cross.fs is used seperately. jaw
 Do we need this char translation with >address and in branchoffset?   - Do we need this char translation with >address and in branchoffset? 
 (>body also affected) jaw    (>body also affected) jaw
 Clean up mark> and >resolve stuff jaw  - MAXU etc. can be done with dlit,
   
 [THEN]  [THEN]
   
Line 690  Variable ppi-temp 0 ppi-temp ! Line 690  Variable ppi-temp 0 ppi-temp !
   POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate    POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate
   
   
   Plugin dlit, ( d -- )                   \ compile numerical value the target
 Plugin lit, ( n -- )  Plugin lit, ( n -- )
 Plugin alit, ( n -- )  Plugin alit, ( n -- )
   
Line 801  Struct Line 802  Struct
   \ points to the where we have to resolve (linked-list)    \ points to the where we have to resolve (linked-list)
   cell% field >link    cell% field >link
   
   \ execution symantics (while target compiling) of ghost    \ execution semantics (while target compiling) of ghost
   cell% field >exec    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    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    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 >exec2
   
   cell% field >created    cell% field >created
Line 865  Variable cross-space-dp-orig Line 878  Variable cross-space-dp-orig
   cross-space-end u> ABORT" CROSS: cross-space overflow"    cross-space-end u> ABORT" CROSS: cross-space overflow"
   cross-space-dp-orig @ dp ! ;    cross-space-dp-orig @ dp ! ;
   
   \ this is just for debugging, to see this in the backtrace
 : execute-exec execute ;  : execute-exec execute ;
 : execute-exec2 execute ;  : execute-exec2 execute ;
 : execute-exec-compile execute ;  : execute-exec-compile execute ;
Line 972  Exists-Warnings on Line 986  Exists-Warnings on
   
 Variable reuse-ghosts reuse-ghosts off  Variable reuse-ghosts reuse-ghosts off
   
 1 [IF] \ FIXME: define when vocs are ready  
 : HeaderGhost ( "name" -- ghost )  : HeaderGhost ( "name" -- ghost )
   >in @     >in @ 
   bl word count     bl word count 
Line 989  Variable reuse-ghosts reuse-ghosts off Line 1002  Variable reuse-ghosts reuse-ghosts off
   \ defined words, this is a workaround    \ defined words, this is a workaround
   \ for the redefined \ until vocs work    \ for the redefined \ until vocs work
   Make-Ghost ;    Make-Ghost ;
 [THEN]   
   
     
 : .ghost ( ghost -- ) >ghostname type ;  : .ghost ( ghost -- ) >ghostname type ;
   
Line 1443  variable constflag constflag off Line 1454  variable constflag constflag off
   
 bigendian  bigendian
 [IF]  [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 ;       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds     : DS@  ( addr -- d )  >r 0 0 r> tcell bounds
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP ;
    : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-     : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-
      DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds     : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
 [ELSE]  [ELSE]
    : S!  ( n addr -- )  >r s>d r> tcell bounds     : DS!  ( d addr -- )  tcell bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-     : DS@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP ;
    : Sc!  ( n addr -- )  >r s>d r> tchar bounds     : Sc!  ( n addr -- )  >r s>d r> tchar bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds swap 1-     : 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 ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
 [THEN]  [THEN]
   
   : S! ( n addr -- ) >r s>d r> DS! ;
   : S@ ( addr -- n ) DS@ d>s ;
   
 : taddr>region ( taddr -- region | 0 )  : taddr>region ( taddr -- region | 0 )
 \G finds for a target-address the correct region  \G finds for a target-address the correct region
 \G returns 0 if taddr is not in range of a target memory region  \G returns 0 if taddr is not in range of a target memory region
Line 1596  T has? relocate H Line 1610  T has? relocate H
 : A,    ( w -- )        >address T here H relon T , 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  \ \ --------------------        Host/Target copy etc.           29aug01jaw
   
   
 >CROSS  >CROSS
   
   : TD! >image DS! ;
   : TD@ >image DS@ ;
   
 : th-count ( taddr -- host-addr len )  : th-count ( taddr -- host-addr len )
 \G returns host address of target string  \G returns host address of target string
   assert1( tbyte 1 = )    assert1( tbyte 1 = )
Line 1641  previous Line 1637  previous
 >TARGET  >TARGET
   
 : count dup X c@ swap X char+ swap ;  : 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 ;  : 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  >CROSS
   
 : (cc) T a, H ;                                 ' (cc) plugin-of colon,  : (cc) T a, H ;                                 ' (cc) plugin-of colon,
Line 1662  previous Line 1681  previous
   
 : (cm) ( -- addr )  : (cm) ( -- addr )
     T here align H      T here align H
     -1 colon, ;                                 ' (cm) plugin-of colonmark,      -1 prim, ;                                  ' (cm) plugin-of colonmark,
   
 >TARGET  >TARGET
 : compile, ( xt -- )  : compile, ( xt -- )
   dup xt>ghost >ghost-flags <primitive> get-flag    dup xt>ghost >comp @ EXECUTE ;
   IF prim, ELSE colon, THEN ;  
 >CROSS  >CROSS
   
 \ resolve structure  \ resolve structure
Line 1753  Defer resolve-warning Line 1771  Defer resolve-warning
 : prim-resolved  ( ghost -- )  : prim-resolved  ( ghost -- )
     >link @ prim, ;      >link @ prim, ;
   
 \ FIXME: not activated  \ FIXME: not used currently
 : does-resolved ( ghost -- )  : does-resolved ( ghost -- )
     dup g>body alit, >do:ghost @ g>body colon, ;      dup g>body alit, >do:ghost @ g>body colon, ;
   
Line 1793  Defer resolve-warning Line 1811  Defer resolve-warning
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 \ FIXME cleanup  
 \ : is-resolved   ( ghost -- )  
 \  >link @ colon, ; \ compile-call  
   
 : (gexecute)   ( ghost -- )  : (gexecute)   ( ghost -- )
   dup >comp @ EXECUTE ;    dup >comp @ EXECUTE ;
   
Line 1807  Defer resolve-warning Line 1821  Defer resolve-warning
 : addr,  ( ghost -- )  : addr,  ( ghost -- )
   dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;    dup forward? IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;
   
 \ !! : ghost,     ghost  gexecute ;  
   
 \ .unresolved                                          11may93jaw  \ .unresolved                                          11may93jaw
   
 variable ResolveFlag  variable ResolveFlag
Line 2183  Cond: [']  T ' H alit, ;Cond Line 2195  Cond: [']  T ' H alit, ;Cond
 \ \ threading modell                                    13dec92py  \ \ threading modell                                    13dec92py
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
   
 T 2 cells H .s Value xt>body  T 2 cells H Value xt>body
   
 : (>body)   ( cfa -- pfa )   : (>body)   ( cfa -- pfa ) 
   xt>body + ;                                           ' (>body) plugin-of t>body    xt>body + ;                                           ' (>body) plugin-of t>body
   
 : fillcfa   ( usedcells -- )  : fillcfa   ( usedcells -- )
   T cells H xt>body swap - dup .    T cells H xt>body swap -
   assert1( dup 0 >= )    assert1( dup 0 >= )
   0 ?DO 0 X c, tchar +LOOP ;    0 ?DO 0 X c, tchar +LOOP ;
   
Line 2212  T 2 cells H .s Value xt>body Line 2224  T 2 cells H .s Value xt>body
   [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]    [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]
   2 fillcfa ;                                           ' (dodoes,) plugin-of dodoes,    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  \ if we dont produce relocatable code alit, defaults to lit, jaw
 \ this is just for convenience, so we don't have to define alit,  \ this is just for convenience, so we don't have to define alit,
Line 2273  Cond: chars ;Cond Line 2287  Cond: chars ;Cond
 \ !! Known Bug: Special Literals and plug-ins work only correct  \ !! Known Bug: Special Literals and plug-ins work only correct
 \ on 16 and 32 Bit Targets and 32 Bit Hosts!  \ 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  Cond: MAXU
   tcell 1 cells u>     tcell 1 cells u> 
   IF    compile lit tcell 0 ?DO FF T c, H LOOP     IF    compile lit tcell 0 ?DO FF T c, H LOOP 
Line 2350  Cond: MAXI Line 2367  Cond: MAXI
 \ by the way: defining a second interpreter (a compiler-)loop  \ by the way: defining a second interpreter (a compiler-)loop
 \             is not allowed if a system should be ans conform  \             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  : : ( -- colon-sys ) \ Name
   defempty?    defempty?
   constflag off \ don't let this flag work over colon defs    constflag off \ don't let this flag work over colon defs
                 \ just to go sure nothing unwanted happens                  \ just to go sure nothing unwanted happens
   >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !    >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
   (THeader ;Resolve ! there ;Resolve cell+ !    (THeader (:) ;
    docol, ]comp  colon-start depth T ] H ;  
   
 : :noname ( -- colon-sys )  : :noname ( -- colon-sys )
   X cfalign    X cfalign there 
   \ FIXME: cleanup!!!!!!!!    \ define a nameless ghost
   \ idtentical to : with dummy ghost?!    here ghostheader dup last-header-ghost ! dup to lastghost
   here ghostheader dup ;Resolve ! dup last-header-ghost ! to lastghost    (:) ;  
   there ;Resolve cell+ !  
   there docol, ]comp   
   colon-start depth T ] H ;  
   
 Cond: EXIT ( -- )   compile ;S  ;Cond  Cond: EXIT ( -- )   compile ;S  ;Cond
   
Line 2430  Cond: DOES> Line 2448  Cond: DOES>
   depth T ] H ;    depth T ] H ;
   
 >CROSS  >CROSS
 \ Creation                                             01nov92py  \ Creation                                              01nov92py
   
 \ Builder                                               11may93jaw  \ Builder                                               11may93jaw
   
   0 Value built
   
 : Builder    ( Create-xt do-ghost "name" -- )  : Builder    ( Create-xt do-ghost "name" -- )
 \ builds up a builder in current vocabulary  \ builds up a builder in current vocabulary
 \ create-xt is executed when word is interpreted  \ create-xt is executed when word is interpreted
 \ do:-xt is executet when the created word from builder is executed  \ 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  \ for do:-xt an additional entry after the normal ghost-entrys is used
   
   Make-Ghost            ( Create-xt do-ghost ghost )    ghost to built 
   dup >created on    built >created @ 0= IF
   rot swap              ( do-ghost Create-xt ghost )      built >created on
   tuck >exec !       ['] prim-resolved built >comp ! 
   tuck >do:ghost !     THEN ;
   ['] prim-resolved over >comp !  
   drop ;  
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
Line 2466  Cond: DOES> Line 2484  Cond: DOES>
   
 : takeover-x-semantics ( S constructor-ghost new-ghost -- )  : takeover-x-semantics ( S constructor-ghost new-ghost -- )
 \g stores execution semantic and compilation semantic in the built word  \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 @      swap >do:ghost @ 
    \ we use the >exec2 field for the semantic of a crated word,     \ we use the >exec2 field for the semantic of a created word,
    \ so predefined semantics e.g. for ....     \ using exec or exec2 makes no difference for normal cross-compilation
    \ FIXME: find an example in the normal kernel!!!     \ but is usefull for instant where the exec field is already
      \ defined (e.g. Vocabularies)
    2dup >exec @ swap >exec2 !      2dup >exec @ swap >exec2 ! 
    >comp @ swap >comp ! ;     >comp @ swap >comp ! ;
 \ old version of this:  
 \  >exec dup @ ['] NoExec =   
 \  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;  
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   create-forward-warn    create-forward-warn
Line 2511  Cond: DOES> Line 2525  Cond: DOES>
   postpone TCreate     postpone TCreate 
   [ [THEN] ] ;    [ [THEN] ] ;
   
   : ;Build
     postpone ; built >exec ! ; immediate
   
 : gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
   executed-ghost @    executed-ghost @ g>body ;
 \ FIXME: cleanup  
 \  compiling? ABORT" CROSS: Executing gdoes> while compiling"  
 \ ?! compiling? IF  gexecute true EXIT  THEN  
   g>body ( false ) ;  
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  
   
 : DO:     ( -- ghost [xt] [colon-sys] )  
   here ghostheader  
   :noname postpone gdoes> ( postpone ?EXIT ) ;  
   
 : by:     ( -- ghost [xt] [colon-sys] ) \ name  : do:ghost! ( ghost -- ) built >do:ghost ! ;
   Ghost  : doexec! ( xt -- ) built >do:ghost @ >exec ! ;
   :noname postpone gdoes> ( postpone ?EXIT ) ;  
   
 : ;DO ( ghost [xt] [colon-sys] -- addr )  : DO:     ( -- [xt] [colon-sys] )
   postpone ;    ( S addr xt )    here ghostheader do:ghost!
   over >exec ! ; immediate    :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 ;
   
 : by      ( -- addr ) \ Name  : ;compile ( [xt] [colon-sys] -- )
   Ghost >do:ghost @ ;    postpone ; built >do:ghost @ >comp ! ; immediate
   
 >TARGET  
 \ Variables and Constants                              05dec92py  \ Variables and Constants                              05dec92py
   
 Build:  ( n -- ) ;  
 by: :docon ( target-body-addr -- n ) T @ H ;DO  
 Builder (Constant)  Builder (Constant)
   Build:  ( n -- ) ;Build
   by: :docon ( target-body-addr -- n ) T @ H ;DO
   
 Build:  ( n -- ) T , H ;  
 by (Constant)  
 Builder Constant  Builder Constant
   Build:  ( n -- ) T , H ;Build
 Build:  ( n -- ) T A, H ;  
 by (Constant)  by (Constant)
   
 Builder AConstant  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  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  Builder Create
   BuildSmart: ;Build
   by: :dovar ( target-body-addr -- addr ) ;DO
   
   Builder Variable
 T has? rom H [IF]  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)  by (Constant)
 Builder Variable  
 [ELSE]  [ELSE]
 Build: T 0 , H ;  Build: T 0 , H ;Build
 by Create  by Create
 Builder Variable  
 [THEN]  [THEN]
   
   Builder 2Variable
 T has? rom H [IF]  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)  by (Constant)
 Builder 2Variable  
 [ELSE]  [ELSE]
 Build: T 0 , 0 , H ;  Build: T 0 , 0 , H ;Build
 by Create  by Create
 Builder 2Variable  
 [THEN]  [THEN]
   
   Builder AVariable
 T has? rom H [IF]  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)  by (Constant)
 Builder AVariable  
 [ELSE]  [ELSE]
 Build: T 0 A, H ;  Build: T 0 A, H ;Build
 by Create  by Create
 Builder AVariable  
 [THEN]  [THEN]
   
 \ User variables                                       04may94py  \ User variables                                       04may94py
   
 >CROSS  
   
 Variable tup  0 tup !  Variable tup  0 tup !
 Variable tudp 0 tudp !  Variable tudp 0 tudp !
   
Line 2604  Variable tudp 0 tudp ! Line 2620  Variable tudp 0 tudp !
   tup @ tudp @ + T A! H    tup @ tudp @ + T A! H
   tudp @ dup T cell+ H tudp ! ;    tudp @ dup T cell+ H tudp ! ;
   
 >TARGET  
   
 Build: 0 u, X , ;  
 by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO  
 Builder User  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  Builder 2User
   Build: 0 u, X , 0 u, drop ;Build
 Build: 0 au, X , ;  
 by User  by User
   
 Builder AUser  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  Builder Value
   BuildSmart: T , H ;Build
   by (Value)
   
 BuildSmart: T A, H ;  
 by (Constant)  
 Builder AValue  Builder AValue
   BuildSmart: T A, H ;Build
   by (Value)
   
 Defer texecute  Defer texecute
   
 BuildSmart:  ( -- ) [T'] noop T A, H ;  
 by: :dodefer ( ghost -- ) X @ texecute ;DO  
 Builder Defer  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:  Builder interpret/compile:
   Build: ( inter comp -- ) swap T immediate A, A, H ;Build
   DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   
 \ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
   
 >CROSS  
 : nalign ( addr1 n -- addr2 )  : nalign ( addr1 n -- addr2 )
 \ addr2 is the aligned version of addr1 wrt the alignment size n  \ addr2 is the aligned version of addr1 wrt the alignment size n
  1- tuck +  swap invert and ;   1- tuck +  swap invert and ;
 >TARGET  
   
 Build: ;  
 by: :dofield T @ H + ;DO  
 Builder (Field)  Builder (Field)
   Build: ;Build
   by: :dofield T @ H + ;DO
   
   Builder Field
 Build: ( align1 offset1 align size "name" --  align2 offset2 )  Build: ( align1 offset1 align size "name" --  align2 offset2 )
     rot dup T , H ( align1 align size offset1 )      rot dup T , H ( align1 align size offset1 )
     + >r nalign r> ;      + >r nalign r> ;Build
 by (Field)  by (Field)
 Builder Field  
   
   >TARGET
 : struct  T 1 chars 0 H ;  : struct  T 1 chars 0 H ;
 : end-struct  T 2Constant H ;  : end-struct  T 2Constant H ;
   
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      T 1 cells H dup ;
   >CROSS
   
 \ Input-Methods                                            01py  \ Input-Methods                                            01py
   
 Build: ( m v -- m' v )  dup T , cell+ H ;  
 DO:  abort" Not in cross mode" ;DO  
 Builder input-method  Builder input-method
   Build: ( m v -- m' v )  dup T , cell+ H ;Build
 Build: ( m v size -- m v' )  over T , H + ;  
 DO:  abort" Not in cross mode" ;DO  DO:  abort" Not in cross mode" ;DO
   
 Builder input-var  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,
   
   \ if we want this, we have to spilt aconstant
   \ and constant!!
   \ Builder (Constant)
   \ compile: g>body X @ lit, ;compile
   
   Builder (Constant)
   compile: g>body alit, compile @ ;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  \ structural conditionals                              17dec92py
   
Line 2972  magic 7 + c! Line 3031  magic 7 + c!
   swap >image swap r@ write-file throw    swap >image swap r@ write-file throw
   r> close-file throw ;    r> close-file throw ;
   
 1 [IF]  \ save-asm-region                                       29aug01jaw
   
 Variable name-ptr  Variable name-ptr
 Create name-buf 200 chars allot  Create name-buf 200 chars allot
Line 3026  Create name-buf 200 chars allot Line 3085  Create name-buf 200 chars allot
   THEN    THEN
   @nb ;    @nb ;
   
   \ FIXME why disabled?!
 : label-from-ghostnameXX ( ghost -- addr len )  : label-from-ghostnameXX ( ghost -- addr len )
 \ same as (label-from-ghostname) but caches generated names  \ same as (label-from-ghostname) but caches generated names
   dup >asm-name @ ?dup IF nip count EXIT THEN    dup >asm-name @ ?dup IF nip count EXIT THEN
Line 3179  Variable outfile-fd Line 3239  Variable outfile-fd
 : save-asm-region ( region adr len -- )  : save-asm-region ( region adr len -- )
   create-outfile (save-asm-region) close-outfile ;    create-outfile (save-asm-region) close-outfile ;
   
 [THEN]  
   
 \ \ minimal definitions  \ \ minimal definitions
                         
 >MINIMAL also minimal  >MINIMAL also minimal
Line 3192  Variable outfile-fd Line 3250  Variable outfile-fd
 \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw  \ \ [IF] [ELSE] [THEN] ...                              14sep97jaw
   
 \ it is useful to define our own structures and not to rely  \ it is useful to define our own structures and not to rely
 \ on the words in the compiler  \ on the words in the host system
 \ The words in the compiler might be defined with vocabularies  \ The words in the host system might be defined with vocabularies
 \ this doesn't work with our self-made compile-loop  \ this doesn't work with our self-made compile-loop
   
 Create parsed 20 chars allot    \ store word we parsed  Create parsed 20 chars allot    \ store word we parsed

Removed from v.1.105  
changed lines
  Added in v.1.111


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>