Diff for /gforth/cross.fs between versions 1.104 and 1.108

version 1.104, 2001/09/04 13:07:44 version 1.108, 2001/09/05 11:45:38
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 62  forth definitions Line 62  forth definitions
 : T  previous Ghosts also Target ; immediate  : T  previous Ghosts also Target ; immediate
 : G  Ghosts ; immediate  : G  Ghosts ; immediate
   
   
 : >cross  also Cross definitions previous ;  : >cross  also Cross definitions previous ;
 : >target also Target definitions previous ;  : >target also Target definitions previous ;
 : >minimal also Minimal definitions previous ;  : >minimal also Minimal definitions previous ;
Line 251  hex Line 252  hex
         ELSE  2dup s" \" compare 0= IF postpone \ THEN          ELSE  2dup s" \" compare 0= IF postpone \ THEN
         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
   
 \ Begin CROSS COMPILER:  \ Begin CROSS COMPILER:
   
 \ debugging  \ debugging
Line 628  stack-warn [IF] Line 635  stack-warn [IF]
 : defempty? ; immediate  : defempty? ; immediate
 [THEN]  [THEN]
   
   \ \ --------------------        Compiler Plug Ins               01aug97jaw
   
   >CROSS
   
   \ Compiler States
   
   Variable comp-state
   0 Constant interpreting
   1 Constant compiling
   2 Constant resolving
   3 Constant assembling
   
   : 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 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
   
   >TARGET
   : >body t>body ;
   
   
 \ Ghost Builder                                        06oct92py  \ Ghost Builder                                        06oct92py
   
   >CROSS
 hex  hex
   \ Values for ghost magic
 4711 Constant <fwd>             4712 Constant <res>  4711 Constant <fwd>             4712 Constant <res>
 4713 Constant <imm>             4714 Constant <do:>  4713 Constant <imm>             4714 Constant <do:>
 4715 Constant <skip>  4715 Constant <skip>
   
   \ Bitmask for ghost flags
 1 Constant <unique>  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  Struct
   
Line 649  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
   
     \ 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 711  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 722  Variable cross-space-dp-orig Line 890  Variable cross-space-dp-orig
   ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word"    ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word"
   THEN ;    THEN ;
   
   Defer is-forward
   
 : (ghostheader) ( -- )  : (ghostheader) ( -- )
   ghost-list linked <fwd> , 0 , ['] NoExec , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;    ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward , 
     0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
   
 : ghostheader ( -- ) (ghostheader) 0 , ;  : ghostheader ( -- ) (ghostheader) 0 , ;
   
Line 783  Defer search-ghosts Line 954  Defer search-ghosts
   REPEAT    REPEAT
   drop r> false ;    drop r> false ;
   
   : xt>ghost ( xt -- ghost )
     gdiscover 0= ABORT" CROSS: ghost not found for this xt" ;
   
 : Ghost   ( "name" -- ghost )  : Ghost   ( "name" -- ghost )
   >in @ bl word gfind IF  nip EXIT  THEN    >in @ bl word gfind IF  nip EXIT  THEN
   drop  >in !  Make-Ghost ;    drop  >in !  Make-Ghost ;
Line 841  Variable reuse-ghosts reuse-ghosts off Line 1015  Variable reuse-ghosts reuse-ghosts off
 \  bl word gfind 0= ABORT" CROSS: Ghost don't exists"  \  bl word gfind 0= ABORT" CROSS: Ghost don't exists"
   ghost state @ IF postpone literal THEN ; immediate    ghost state @ IF postpone literal THEN ; immediate
   
 : ghost>cfa ( ghost -- cfa )  : g>xt ( ghost -- xt )
   \G Returns the xt (cfa) of a ghost. Issues a warning if undefined.
   dup undefined? ABORT" CROSS: forward " >link @ ;    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>  1 Constant <label>
   
 Struct  Struct
Line 951  false DefaultValue dcomps Line 1131  false DefaultValue dcomps
 false DefaultValue hash  false DefaultValue hash
 false DefaultValue xconds  false DefaultValue xconds
 false DefaultValue header  false DefaultValue header
   false DefaultValue backtrace
   false DefaultValue new-input
   false DefaultValue peephole
 [THEN]  [THEN]
   
 true DefaultValue interpreter  true DefaultValue interpreter
Line 1022  Variable user-vars 0 user-vars ! Line 1205  Variable user-vars 0 user-vars !
 : target>bitmask-size ( u1 -- u2 )  : target>bitmask-size ( u1 -- u2 )
   1- tcell>bit rshift 1+ ;    1- tcell>bit rshift 1+ ;
   
 : allocatetarget ( size --- adr )  : allocatetarget ( size -- adr )
   dup allocate ABORT" CROSS: No memory for target"    dup allocate ABORT" CROSS: No memory for target"
   swap over swap erase ;    swap over swap erase ;
   
Line 1134  T has? rom H Line 1317  T has? rom H
 ' dictionary ALIAS rom-dictionary  ' dictionary ALIAS rom-dictionary
   
   
 : setup-target ( -- )   \G initialize targets memory space  : setup-target ( -- )   \G initialize target's memory space
   s" rom" T $has? H    s" rom" T $has? H
   IF  \ check for ram and rom...    IF  \ check for ram and rom...
       \ address-space area nip 0<>        \ address-space area nip 0<>
Line 1174  T has? rom H Line 1357  T has? rom H
         ELSE    r> drop THEN          ELSE    r> drop THEN
    REPEAT drop ;     REPEAT drop ;
   
 \ MakeKernal                                                    22feb99jaw  \ MakeKernel                                                    22feb99jaw
   
 : makekernel ( targetsize -- targetsize )  : makekernel ( targetsize -- targetsize )
   dup dictionary >rlen ! setup-target ;    dup dictionary >rlen ! setup-target ;
Line 1274  variable constflag constflag off Line 1457  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 1427  T has? relocate H Line 1613  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  
   
 : 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  
   
 [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 1479  previous Line 1644  previous
 : on            T -1 swap ! H ;   : on            T -1 swap ! H ; 
 : off           T 0 swap ! H ;  : off           T 0 swap ! H ;
   
 \ \ --------------------        Compiler Plug Ins               01aug97jaw  : tcmove ( source dest len -- )
   \G cmove in target memory
 >CROSS    tchar * bounds
     ?DO  dup T c@ H I T c! H 1+
 \  Compiler States    tchar +LOOP  drop ;
   
 Variable comp-state  
 0 Constant interpreting  
 1 Constant compiling  
 2 Constant resolving  
 3 Constant assembling  
   
 : compiling? comp-state @ compiling = ;  
   
 : Plugin ( -- : pluginname )  
   Create   
   ['] noop , \ action  
   ['] noop , \ 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 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)  
 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 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  : td, ( d -- )
 Plugin ca>native          \G Store a host value as one cell into the target
 [THEN]    there tcell X allot TD! ;
   
 Plugin doprim,  \ compiles start of a primitive  \ \ Load Assembler
 Plugin docol,           \ compiles start of a colon definition  
 Plugin doer,              
 Plugin fini,      \ compiles end of definition ;s  
 Plugin doeshandler,  
 Plugin dodoes,  
   
 Plugin colon-start  >TARGET
 Plugin colon-end  H also Forth definitions
   
 Plugin ]comp     \ starts compilation  \ FIXME: should we include the assembler really in the forth 
 Plugin comp[     \ ends compilation  \ dictionary?!?!?!? This conflicts with the existing assembler 
   \ of the host forth system!!
   [IFDEF] asm-include asm-include [THEN] hex
   
 T 2 cells H Value xt>body  previous
   
 Plugin t>body             \ we need the system >body  
                         \ and the target >body  
   
 >TARGET  
 : >body t>body ;  
 >CROSS  >CROSS
   
 : (cc) T a, H ;                                 ' (cc) plugin-of colon,  : (cc) T a, H ;                                 ' (cc) plugin-of colon,
   : (prim) T a, H ;                               ' (prim) plugin-of prim,
   
 : (cr) >tempdp ]comp colon, comp[ tempdp> ;     ' (cr) plugin-of colon-resolve  : (cr) >tempdp ]comp prim, comp[ tempdp> ;      ' (cr) plugin-of colon-resolve
 : (ar) T ! H ;                                  ' (ar) plugin-of addr-resolve  : (ar) T ! H ;                                  ' (ar) plugin-of addr-resolve
 : (dr)  ( ghost res-pnt target-addr addr )  : (dr)  ( ghost res-pnt target-addr addr )
         >tempdp drop over           >tempdp drop over 
Line 1616  Plugin t>body             \ we need the Line 1687  Plugin t>body             \ we need the
     -1 colon, ;                                 ' (cm) plugin-of colonmark,      -1 colon, ;                                 ' (cm) plugin-of colonmark,
   
 >TARGET  >TARGET
 : compile, colon, ;  : compile, ( xt -- )
     dup xt>ghost >comp @ EXECUTE ;
 >CROSS  >CROSS
   
 \ resolve structure  \ resolve structure
Line 1696  Defer resolve-warning Line 1768  Defer resolve-warning
   swap exists-warning    swap exists-warning
   >link ! ;    >link ! ;
   
 Variable rdbg  : colon-resolved   ( ghost -- )
       >link @ colon, ; \ compile-call
   
   : 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
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
 \G resolve referencies to ghost with tcfa  \G resolve referencies to ghost with tcfa
     rdbg @ IF break: THEN   
     dup taddr>region 0<> IF      dup taddr>region 0<> IF
       2dup (>regiontype) define-addr-struct addr-xt-ghost         2dup (>regiontype) define-addr-struct addr-xt-ghost 
   
       \ we define new address only if empty        \ we define new address only if empty
       \ this is for not to overtake the alias ghost        \ this is for not to take over the alias ghost
         \ (different ghost, but identical xt)
       \ but the very first that really defines it        \ but the very first that really defines it
 \ FIXME: define when HeaderGhost is ready  
       dup @ 0= IF ! ELSE 2drop THEN        dup @ 0= IF ! ELSE 2drop THEN
 \    !  
     THEN      THEN
   
     \ is ghost resolved?, second resolve means another       \ is ghost resolved?, second resolve means another 
Line 1719  Variable rdbg Line 1801  Variable rdbg
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )      swap >r r@ >link @ swap \ ( list tcfa R: ghost )
     \ mark ghost as resolved      \ mark ghost as resolved
     dup r@ >link ! <res> r@ >magic !      dup r@ >link ! <res> r@ >magic !
       r@ >comp @ ['] is-forward = IF
           ['] prim-resolved  r@ >comp !  THEN
     \ loop through forward referencies      \ loop through forward referencies
     r> -rot       r> -rot 
     comp-state @ >r Resolving comp-state !      comp-state @ >r Resolving comp-state !
Line 1730  Variable rdbg Line 1814  Variable rdbg
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 : is-forward   ( ghost -- )  \ FIXME cleanup
   colonmark, 0 (refered) ; \ compile space for call  \ : is-resolved   ( ghost -- )
   \  >link @ colon, ; \ compile-call
 : is-resolved   ( ghost -- )  
   >link @ colon, ; \ compile-call  
   
 : (gexecute)   ( ghost -- )  : (gexecute)   ( ghost -- )
   dup >magic @     dup >comp @ EXECUTE ;
   <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;  
   
 : gexecute ( ghost -- )  : 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) ;    (gexecute) ;
   
 : addr,  ( ghost -- )  : addr,  ( ghost -- )
   dup >magic @ <fwd> = 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 ;  \ !! : ghost,     ghost  gexecute ;
   
Line 1807  bigendian [IF] 0 [ELSE] tcell 1- [THEN] Line 1888  bigendian [IF] 0 [ELSE] tcell 1- [THEN]
   
 VARIABLE ^imm  VARIABLE ^imm
   
   \ !! should be target wordsize specific
   $80 constant alias-mask
   $40 constant immediate-mask
   $20 constant restrict-mask
   
 >TARGET  >TARGET
 : immediate     40 flag!  : immediate     immediate-mask flag!
                 ^imm @ @ dup <imm> = IF  drop  EXIT  THEN                  ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"                  <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                 <imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
 : restrict      20 flag! ;  : restrict      restrict-mask flag! ;
   
 : isdoer          : isdoer        
 \G define a forth word as doer, this makes obviously only sence on  \G define a forth word as doer, this makes obviously only sence on
Line 1847  Variable to-doc  to-doc on Line 1933  Variable to-doc  to-doc on
         s" " doc-file-id write-line throw          s" " doc-file-id write-line throw
         s" make-doc " doc-file-id write-file 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 @          >in @
         [char] ( parse 2drop          [char] ( parse 2drop
         [char] ) parse doc-file-id write-file throw          [char] ) parse doc-file-id write-file throw
Line 1980  Defer setup-execution-semantics Line 2066  Defer setup-execution-semantics
     [ [THEN] ]      [ [THEN] ]
     dup Last-Header-Ghost ! dup to lastghost      dup Last-Header-Ghost ! dup to lastghost
     dup >magic ^imm !     \ a pointer for immediate      dup >magic ^imm !     \ a pointer for immediate
     80 flag!      alias-mask flag!
     cross-doc-entry cross-tag-entry       cross-doc-entry cross-tag-entry 
     setup-execution-semantics      setup-execution-semantics
     ;      ;
Line 2011  Variable aprim-nr -20 aprim-nr ! Line 2097  Variable aprim-nr -20 aprim-nr !
 : Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
   >in @ skip? IF  2drop  EXIT  THEN  >in !    >in @ skip? IF  2drop  EXIT  THEN  >in !
   (THeader ( S xt ghost )    (THeader ( S xt ghost )
   2dup swap gdiscover 0= ABORT" missing" swap copy-execution-semantics    2dup swap xt>ghost swap copy-execution-semantics
   over resolve T A, H 80 flag! ;    over resolve T A, H alias-mask flag! ;
   
 Variable last-prim-ghost  Variable last-prim-ghost
 0 last-prim-ghost !  0 last-prim-ghost !
Line 2052  Variable prim# Line 2138  Variable prim#
      .sourcepos ." needs prim: " >in @ bl word count type >in ! cr       .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
   THEN    THEN
   prim# @ (THeader ( S xt ghost )    prim# @ (THeader ( S xt ghost )
   over resolve T A, H 80 flag!    dup >ghost-flags <primitive> set-flag
     over resolve T A, H alias-mask flag!
   -1 prim# +! ;    -1 prim# +! ;
 >CROSS  >CROSS
   
Line 2097  Comment (       Comment \ Line 2184  Comment (       Comment \
                           
 >TARGET  >TARGET
   
 : '  ( -- cfa )   : '  ( -- xt ) 
 \ returns the target-cfa of a ghost  \G returns the target-cfa of a ghost
   bl word gfind 0= ABORT" CROSS: Ghost don't exists"    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  \ FIXME: this works for the current use cases, but is not
 \ in all cases correct ;-)   \ in all cases correct ;-) 
Line 2112  Cond: [']  T ' H alit, ;Cond Line 2199  Cond: [']  T ' H alit, ;Cond
   
 : [T']  : [T']
 \ returns the target-cfa of a ghost, or compiles it as literal  \ 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  \ \ threading modell                                    13dec92py
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
   
 : fillcfa   ( usedcells -- )  T 2 cells H Value xt>body
   T cells H xt>body swap - 0 ?DO 0 X c, tchar +LOOP ;  
   
 : (>body)   ( cfa -- pfa )   : (>body)   ( cfa -- pfa ) 
   xt>body + ;                                   ' (>body) plugin-of t>body    xt>body + ;                                           ' (>body) plugin-of t>body
   
   : fillcfa   ( usedcells -- )
     T cells H xt>body swap -
     assert1( dup 0 >= )
     0 ?DO 0 X c, tchar +LOOP ;
   
 : (doer,)   ( ghost -- )   : (doer,)   ( ghost -- ) 
   addr, 1 fillcfa ;                             ' (doer,) plugin-of doer,    addr, 1 fillcfa ;                                     ' (doer,) plugin-of doer,
   
 : (docol,)  ( -- ) [G'] :docol (doer,) ;        ' (docol,) plugin-of docol,  : (docol,)  ( -- ) [G'] :docol (doer,) ;                ' (docol,) plugin-of docol,
   
 : (doprim,) ( -- )  : (doprim,) ( -- )
   there xt>body + ca>native T a, H 1 fillcfa ;  ' (doprim,) plugin-of doprim,    there xt>body + ca>native T a, H 1 fillcfa ;          ' (doprim,) plugin-of doprim,
   
 : (doeshandler,) ( -- )   : (doeshandler,) ( -- ) 
   T cfalign H compile :doesjump T 0 , H ;       ' (doeshandler,) plugin-of doeshandler,    T cfalign H compile :doesjump T 0 , H ;               ' (doeshandler,) plugin-of doeshandler,
   
 : (dodoes,) ( does-action-ghost -- )  : (dodoes,) ( does-action-ghost -- )
   ]comp [G'] :dodoes gexecute comp[    ]comp [G'] :dodoes gexecute comp[
Line 2140  Cond: [']  T ' H alit, ;Cond Line 2231  Cond: [']  T ' H alit, ;Cond
   \ the relocator in the c engine, does not like the    \ the relocator in the c engine, does not like the
   \ does-address to marked for relocation    \ does-address to marked for relocation
   [ 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,
 \ seperately for embedded systems....  \ seperately for embedded systems....
 T has? relocate H  T has? relocate H
 [IF]  [IF]
 : (alit,) ( n -- )  compile lit T  a, H ;       ' (alit,) plugin-of alit,  : (alit,) ( n -- )  compile lit T  a, H ;               ' (alit,) plugin-of alit,
 [ELSE]  [ELSE]
 : (alit,) ( n -- )  lit, ;                      ' (alit,) plugin-of alit,  : (alit,) ( n -- )  lit, ;                              ' (alit,) plugin-of alit,
 [THEN]  [THEN]
   
 : (fini,)         compile ;s ;                  ' (fini,) plugin-of fini,  : (fini,)         compile ;s ;                          ' (fini,) plugin-of fini,
   
 [IFUNDEF] (code)   [IFUNDEF] (code) 
 Defer (code)  Defer (code)
Line 2188  Defer (end-code) Line 2281  Defer (end-code)
 >TARGET  >TARGET
 Cond: \G  T-\G ;Cond  Cond: \G  T-\G ;Cond
   
 Cond:  Literal ( n -- )   lit, ;Cond  Cond: Literal  ( n -- )   lit, ;Cond
 Cond: ALiteral ( n -- )   alit, ;Cond  Cond: ALiteral ( n -- )   alit, ;Cond
   
 : Char ( "<char>" -- )  bl word char+ c@ ;  : Char ( "<char>" -- )  bl word char+ c@ ;
 Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond  Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond
   
 tchar 1 = [IF]  tchar 1 = [IF]
 Cond: chars ;Cond   \ Cond: chars ;Cond 
 [THEN]  [THEN]
   
 \ some special literals                                 27jan97jaw  \ some special literals                                 27jan97jaw
Line 2203  Cond: chars ;Cond Line 2296  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 2252  Cond: MAXI Line 2348  Cond: MAXI
 \ : ; DOES>                                            13dec92py  \ : ; DOES>                                            13dec92py
 \ ]                                                     9may93py/jaw  \ ]                                                     9may93py/jaw
   
 : ]   : compiling-state ( -- )
   \G set states to compililng
     Compiling comp-state !      Compiling comp-state !
     \ if we have a state in target, change it with the compile 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      [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 ! ;
   
   : ] 
       compiling-state
     BEGIN      BEGIN
         BEGIN save-input bl word          BEGIN save-input bl word
               dup c@ 0= WHILE drop discard refill 0=                dup c@ 0= WHILE drop discard refill 0=
Line 2298  Cond: ?EXIT ( -- ) 1 abort" CROSS: using Line 2406  Cond: ?EXIT ( -- ) 1 abort" CROSS: using
 Cond: recurse ( -- ) Last-Header-Ghost @ gexecute ;Cond  Cond: recurse ( -- ) Last-Header-Ghost @ gexecute ;Cond
   
 Cond: ; ( -- )   Cond: ; ( -- ) 
                depth ?dup IF   1- <> ABORT" CROSS: Stack changed"          depth ?dup 
                           ELSE true ABORT" CROSS: Stack empty" THEN          IF   1- <> ABORT" CROSS: Stack changed"
                colon-end          ELSE true ABORT" CROSS: Stack empty" 
                fini,          THEN
                comp[          colon-end
                ;Resolve @          fini,
                IF ;Resolve @ ;Resolve cell+ @ resolve THEN          comp[
     [G'] state dup undefined? 0= IF >ghost-xt @ execute X off ELSE drop THEN          ;Resolve @ 
                Interpreting comp-state !          IF      ;Resolve @ ;Resolve cell+ @ resolve 
                ;Cond                  ['] colon-resolved ;Resolve @ >comp !
 Cond: [            THEN
   \ if we have a state in target, change it with the compile state          interpreting-state
     [G'] state dup undefined? 0= IF >ghost-xt @ execute X off ELSE drop THEN          ;Cond
 \  [G'] state dup undefined? 0= IF ghost>cfa X >body X off ELSE drop THEN  
   Interpreting comp-state ! ;Cond  Cond: [ ( -- ) interpreting-state ;Cond
   
 >CROSS  >CROSS
   
Line 2328  Create GhostDummy ghostheader Line 2436  Create GhostDummy ghostheader
     tlastcfa @ >tempdp dodoes, tempdp> ;      tlastcfa @ >tempdp dodoes, tempdp> ;
   
   
 Defer instant-compile-does>-hook  
 Defer instant-interpret-does>-hook  Defer instant-interpret-does>-hook
   
 : resolve-does>-part ( -- )  : resolve-does>-part ( -- )
 \ resolve words made by builders  \ resolve words made by builders
   Last-Header-Ghost @ >do:ghost @ ?dup IF there resolve THEN ;    Last-Header-Ghost @ >do:ghost @ ?dup 
     IF    there resolve 
           \ TODO: set special DOES> resolver action here
     THEN ;
   
 >TARGET  >TARGET
 Cond: DOES>  Cond: DOES>
         compile (does>) doeshandler,          compile (does>) doeshandler,
         resolve-does>-part          resolve-does>-part
 \        instant-compile-does>-hook  
         ;Cond          ;Cond
   
 : DOES> switchrom doeshandler, T here H !does   : DOES> switchrom doeshandler, T here H !does 
Line 2347  Cond: DOES> Line 2456  Cond: DOES>
   depth T ] H ;    depth T ] H ;
   
 >CROSS  >CROSS
 \ Creation                                             01nov92py  \ Creation                                              01nov92py
   
 \ Builder                                               11may93jaw  \ Builder                                               11may93jaw
   
 : Builder    ( Create-xt do:-xt "name" -- )  0 Value built
   
   : 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-enrys is used  \ for do:-xt an additional entry after the normal ghost-entrys is used
   
   Make-Ghost            ( Create-xt do:-xt ghost )    ghost                 ( Create-xt do-ghost ghost )
   dup >created on    to built 
   rot swap              ( do:-xt Create-xt ghost )    built >created @ 0= IF
   tuck >exec ! >do:ghost ! ;      built >created on
 \  rot swap >exec dup @ ['] NoExec <>      ['] prim-resolved built >comp ! 
 \  IF 2drop ELSE ! THEN , ;    THEN ;
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
Line 2381  Cond: DOES> Line 2492  Cond: DOES>
   ;    ;
   
 : takeover-x-semantics ( S constructor-ghost new-ghost -- )  : takeover-x-semantics ( S constructor-ghost new-ghost -- )
 \g stores execution 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 if the word already has a semantic (concerns S", IS, .", DOES>)
 \g then keep it  \g then keep it
    swap >do:ghost @ >exec @ swap >exec2 ! ;     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!!!
      2dup >exec @ swap >exec2 ! 
      >comp @ swap >comp ! ;
   \ old version of this:
 \  >exec dup @ ['] NoExec =   \  >exec dup @ ['] NoExec = 
 \  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;  \  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;
   
Line 2403  Cond: DOES> Line 2520  Cond: DOES>
   executed-ghost @ (THeader     executed-ghost @ (THeader 
   dup >created on    dup >created on
   2dup takeover-x-semantics    2dup takeover-x-semantics
   there 0 T a, H 80 flag!    there 0 T a, H alias-mask flag!
   \ store poiter to code-field    \ store poiter to code-field
   switchram T cfalign H    switchram T cfalign H
   there swap T ! H    there swap T ! H
Line 2421  Cond: DOES> Line 2538  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 @
   \ FIXME: cleanup
 \  compiling? ABORT" CROSS: Executing gdoes> while compiling"  \  compiling? ABORT" CROSS: Executing gdoes> while compiling"
 \ ?! compiling? IF  gexecute true EXIT  THEN  \ ?! compiling? IF  gexecute true EXIT  THEN
   >link @ X >body ( false ) ;    g>body ( false ) ;
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
   
 : DO:     ( -- addr [xt] [colon-sys] )  : do:ghost! ( ghost -- ) built >do:ghost ! ;
   here ghostheader  : doexec! ( xt -- ) built >do:ghost @ >exec ! ;
   
   : DO:     ( -- [xt] [colon-sys] )
     here ghostheader do:ghost!
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ( postpone ?EXIT ) ;
   
 : by:     ( -- addr [xt] [colon-sys] ) \ name  : by:     ( -- [xt] [colon-sys] ) \ name
   Ghost    Ghost do:ghost!
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ( postpone ?EXIT ) ;
   
 : ;DO ( addr [xt] [colon-sys] -- addr )  : ;DO ( [xt] [colon-sys] -- )
   postpone ;    ( S addr xt )    postpone ; doexec! ; immediate
   over >exec ! ; 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  >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
Line 2515  Variable tudp 0 tudp ! Line 2644  Variable tudp 0 tudp !
   
 >TARGET  >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
   
Line 2553  Builder interpret/compile: Line 2686  Builder interpret/compile:
  1- tuck +  swap invert and ;   1- tuck +  swap invert and ;
 >TARGET  >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  
   
 : struct  T 1 chars 0 H ;  : struct  T 1 chars 0 H ;
 : end-struct  T 2Constant H ;  : end-struct  T 2Constant H ;
Line 2569  Builder Field Line 2702  Builder Field
 : cell% ( n -- size align )  : cell% ( n -- size align )
     T 1 cells H dup ;      T 1 cells H dup ;
   
   \ 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]
   
   : (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  \ structural conditionals                              17dec92py
   
Line 3314  previous Line 3481  previous
 : hwords        words ;  : hwords        words ;
 \ : words       also ghosts   \ : words       also ghosts 
 \                words previous ;  \                words previous ;
 \ : .s            .s ;  : .s            .s ;
 : bye           bye ;  : bye           bye ;
   
 \ dummy  \ dummy

Removed from v.1.104  
changed lines
  Added in v.1.108


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