Diff for /gforth/cross.fs between versions 1.103 and 1.114

version 1.103, 2001/09/04 13:06:06 version 1.114, 2001/09/12 14:55:54
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 812  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 829  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 841  Variable reuse-ghosts reuse-ghosts off Line 1012  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 866  End-Struct addr-struct Line 1043  End-Struct addr-struct
   
 \ Predefined ghosts                                    12dec92py  \ Predefined ghosts                                    12dec92py
   
   Ghost - drop \ need a ghost otherwise "-" would be treated as a number
   
 Ghost 0=                                        drop  Ghost 0=                                        drop
 Ghost branch    Ghost ?branch                   2drop  Ghost branch    Ghost ?branch                   2drop
 Ghost (do)      Ghost (?do)                     2drop  Ghost (do)      Ghost (?do)                     2drop
Line 880  Ghost ' Line 1059  Ghost '
 Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop  Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
 Ghost :dovar                                    drop  Ghost :dovar                                    drop
 Ghost over      Ghost =         Ghost drop      2drop drop  Ghost over      Ghost =         Ghost drop      2drop drop
 Ghost - drop  
 Ghost 2drop drop  Ghost 2drop drop
 Ghost 2dup drop  Ghost 2dup drop
   
Line 951  false DefaultValue dcomps Line 1129  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 962  true DefaultValue standardthreading Line 1143  true DefaultValue standardthreading
 s" relocate" T environment? H   s" relocate" T environment? H 
 \ JAW why set NIL to this?!  \ JAW why set NIL to this?!
 [IF]    drop \ SetValue NIL  [IF]    drop \ SetValue NIL
 [ELSE]  >ENVIRON T NIL H SetValue relocate  [ELSE]  >ENVIRON X NIL SetValue relocate
 [THEN]  [THEN]
   >TARGET
   
   0 Constant NIL
   
 >CROSS  >CROSS
   
Line 1022  Variable user-vars 0 user-vars ! Line 1206  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 1044  Variable mirrored-link          \ linked Line 1228  Variable mirrored-link          \ linked
 : >rlen cell+ ;  : >rlen cell+ ;
 : >rstart ;  : >rstart ;
   
   : (region) ( addr len region -- )
   \G change startaddress and length of an existing region
     >r r@ last-defined-region !
     r@ >rlen ! dup r@ >rstart ! r> >rdp ! ;
   
 : region ( addr len -- )                  : region ( addr len -- )                
 \G create a new region  \G create a new region
Line 1057  Variable mirrored-link          \ linked Line 1245  Variable mirrored-link          \ linked
         region-link linked 0 , 0 , 0 , bl word count string,          region-link linked 0 , 0 , 0 , bl word count string,
   ELSE  \ store new parameters in region    ELSE  \ store new parameters in region
         bl word drop          bl word drop
         >body >r r@ last-defined-region !          >body (region)
         r@ >rlen ! dup r@ >rstart ! r> >rdp !  
   THEN ;    THEN ;
   
 : borders ( region -- startaddr endaddr )   : borders ( region -- startaddr endaddr ) 
Line 1134  T has? rom H Line 1321  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 1361  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 -- )
   dup dictionary >rlen ! setup-target ;  \G convenience word to setup the memory of the target
   \G used by main.fs of the c-engine based systems
     100 swap dictionary (region)
     setup-target ;
   
 >MINIMAL  >MINIMAL
 : makekernel makekernel ;  : makekernel makekernel ;
Line 1274  variable constflag constflag off Line 1464  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 1620  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 1475  previous Line 1647  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 ;   
 : off           T 0 swap ! H ;  
   
 \ \ --------------------        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 = ;  
   
 : 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 )  : on            -1 -1 rot TD!  ; 
 \ target plugin action  : off           T 0 swap ! H ;
 \ 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 )  : tcmove ( source dest len -- )
 Plugin ?do,     ( -- ?do-token )  \G cmove in target memory
 Plugin for,     ( -- for-token )    tchar * bounds
 Plugin loop,    ( do-token / ?do-token -- )    ?DO  dup T c@ H I T c! H 1+
 Plugin +loop,   ( do-token / ?do-token -- )    tchar +LOOP  drop ;
 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 1613  Plugin t>body             \ we need the Line 1691  Plugin t>body             \ we need the
   
 : (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, colon, ;  : compile, ( xt -- )
     dup xt>ghost >comp @ EXECUTE ;
 >CROSS  >CROSS
   
 \ resolve structure  \ resolve structure
Line 1696  Defer resolve-warning Line 1775  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 used currently
   : 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 1808  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 1821  Variable rdbg
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
 : is-forward   ( ghost -- )  
   colonmark, 0 (refered) ; \ compile space for 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 ;  
   
 \ .unresolved                                          11may93jaw  \ .unresolved                                          11may93jaw
   
Line 1807  bigendian [IF] 0 [ELSE] tcell 1- [THEN] Line 1889  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 1934  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 2067  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 2098  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 2025  Variable last-prim-ghost Line 2112  Variable last-prim-ghost
   
 Defer setup-prim-semantics  Defer setup-prim-semantics
   
 : aprim   ( -- )   : mapprim   ( "forthname" "asmlabel" -- ) 
   THeader -1 aprim-nr +! aprim-nr @ T A, H    THeader -1 aprim-nr +! aprim-nr @ T A, H
   asmprimname,     asmprimname, 
   setup-prim-semantics ;    setup-prim-semantics ;
   
 : aprim:   ( -- )   : mapprim:   ( "forthname" "asmlabel" -- ) 
   -1 aprim-nr +! aprim-nr @    -1 aprim-nr +! aprim-nr @
   Ghost tuck swap resolve <do:> swap tuck >magic !    Ghost tuck swap resolve <do:> swap tuck >magic !
   asmprimname, ;    asmprimname, ;
Line 2052  Variable prim# Line 2139  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 2185  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 2200  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 2232  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,
   
   : (dlit,) ( n -- ) compile lit td, ;                    ' (dlit,) plugin-of dlit,
   
 : (lit,) ( n -- )   compile lit T  ,  H ;       ' (lit,) plugin-of lit,  : (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 2282  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
   
 \ JAW Cond: chars ;Cond   tchar 1 = [IF]
   Cond: chars ;Cond 
   [THEN]
   
 \ some special literals                                 27jan97jaw  \ some special literals                                 27jan97jaw
   
 \ !! 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 2250  Cond: MAXI Line 2349  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 2266  Cond: MAXI Line 2377  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 2296  Cond: ?EXIT ( -- ) 1 abort" CROSS: using Line 2408  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 2326  Create GhostDummy ghostheader Line 2438  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 2345  Cond: DOES> Line 2458  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 to built 
   dup >created on    built >created @ 0= IF
   rot swap              ( do:-xt Create-xt ghost )      built >created on
   tuck >exec ! >do:ghost ! ;      ['] prim-resolved built >comp ! 
 \  rot swap >exec dup @ ['] NoExec <>    THEN ;
 \  IF 2drop ELSE ! THEN , ;  
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
 \ makes the codefield for a word that is built  \ makes the codefield for a word that is built
Line 2379  Cond: DOES> Line 2493  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>)     swap >do:ghost @ 
 \g then keep it     \ we use the >exec2 field for the semantic of a created word,
    swap >do:ghost @ >exec @ swap >exec2 ! ;     \ using exec or exec2 makes no difference for normal cross-compilation
 \  >exec dup @ ['] NoExec =      \ but is usefull for instant where the exec field is already
 \  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;     \ defined (e.g. Vocabularies)
      2dup >exec @ swap >exec2 ! 
      >comp @ swap >comp ! ;
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   create-forward-warn    create-forward-warn
Line 2401  Cond: DOES> Line 2517  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 2419  Cond: DOES> Line 2535  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 ;
 \  compiling? ABORT" CROSS: Executing gdoes> while compiling"  
 \ ?! compiling? IF  gexecute true EXIT  THEN  
   >link @ X >body ( false ) ;  
   
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  
   
 : DO:     ( -- addr [xt] [colon-sys] )  
   here ghostheader  
   :noname postpone gdoes> ( postpone ?EXIT ) ;  
   
 : by:     ( -- addr [xt] [colon-sys] ) \ name  : do:ghost! ( ghost -- ) built >do:ghost ! ;
   Ghost  : doexec! ( xt -- ) built >do:ghost @ >exec ! ;
   :noname postpone gdoes> ( postpone ?EXIT ) ;  
   
 : ;DO ( addr [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 2511  Variable tudp 0 tudp ! Line 2630  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
   
   
 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 2852  magic 7 + c! Line 3014  magic 7 + c!
 : save-cross ( "image-name" "binary-name" -- )  : save-cross ( "image-name" "binary-name" -- )
   bl parse ." Saving to " 2dup type cr    bl parse ." Saving to " 2dup type cr
   w/o bin create-file throw >r    w/o bin create-file throw >r
   TNIL IF    s" header" X $has? IF
       s" #! "           r@ write-file throw        s" #! "           r@ write-file throw
       bl parse          r@ write-file throw        bl parse          r@ write-file throw
       s"  --image-file" r@ write-file throw        s"  --image-file" r@ write-file throw
Line 2868  magic 7 + c! Line 3030  magic 7 + c!
   THEN    THEN
   image @ there     image @ there 
   r@ write-file throw \ write image    r@ write-file throw \ write image
   TNIL IF    s" relocate" X $has? IF
       bit$  @ there 1- tcell>bit rshift 1+        bit$  @ there 1- tcell>bit rshift 1+
                 r@ write-file throw \ write tags                  r@ write-file throw \ write tags
   THEN    THEN
Line 2879  magic 7 + c! Line 3041  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 2933  Create name-buf 200 chars allot Line 3095  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 3086  Variable outfile-fd Line 3249  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 3099  Variable outfile-fd Line 3260  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
Line 3312  previous Line 3473  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
Line 3356  UNLOCK >CROSS Line 3517  UNLOCK >CROSS
 [IFDEF] extend-cross extend-cross [THEN]  [IFDEF] extend-cross extend-cross [THEN]
   
 LOCK  LOCK
   
   
   

Removed from v.1.103  
changed lines
  Added in v.1.114


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