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

version 1.104, 2001/09/04 13:07:44 version 1.124, 2002/03/21 17:11:10
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 70  H Line 71  H
   
 >CROSS  >CROSS
   
   \ Test against this definitions to find out whether we are cross-compiling
   \ may be usefull for assemblers
   0 Constant gforth-cross-indicator
   
 \ find out whether we are compiling with gforth  \ find out whether we are compiling with gforth
   
 : defined? bl word find nip ;  : defined? bl word find nip ;
Line 201  Create bases   10 ,   2 ,   A , 100 , Line 206  Create bases   10 ,   2 ,   A , 100 ,
   
 [THEN]  [THEN]
   
   \ this provides assert( and struct stuff
   \GFORTH [IFUNDEF] assert1(
   \GFORTH also forth definitions require assert.fs previous
   \GFORTH [THEN]
   
   >CROSS
   
 hex     \ the defualt base for the cross-compiler is hex !!  hex     \ the defualt base for the cross-compiler is hex !!
 \ Warnings off  \ Warnings off
   
Line 241  hex     \ the defualt base for the cross Line 253  hex     \ the defualt base for the cross
   
 hex  hex
   
   \ FIXME delete`
 \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are  \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are
                         \ for cross-compiling                          \ for cross-compiling
 \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!  \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
   
   \ FIXME move down
 : comment? ( c-addr u -- c-addr u )  : comment? ( c-addr u -- c-addr u )
         2dup s" (" compare 0=          2dup s" (" compare 0=
         IF    postpone (          IF    postpone (
         ELSE  2dup s" \" compare 0= IF postpone \ THEN          ELSE  2dup s" \" compare 0= IF postpone \ THEN
         THEN ;          THEN ;
   
   : X ( -- <name> )
   \G The next word in the input is a target word.
   \G Equivalent to T <name> but without permanent
   \G switch to target dictionary. Used as prefix e.g. for @, !, here etc.
     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 296  set-order previous Line 319  set-order previous
         \ POSTPONE false           \ POSTPONE false 
   THEN ; immediate    THEN ; immediate
   
   : symentry ( adr len taddr -- )
   \G Produce a symbol table (an optional symbol address
   \G map) if wanted
       [ [IFDEF] fd-symbol-table ]
         base @ swap hex s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
         s" :" fd-symbol-table write-file throw
         fd-symbol-table write-line throw
       [ [ELSE] ]
         2drop drop
       [ [THEN] ] ;
   
   
 \ \ --------------------        source file  \ \ --------------------        source file
   
 decimal  decimal
Line 628  stack-warn [IF] Line 663  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,  ( -- )
   
   Plugin ca>native  \ Convert a code address to the processors
                     \ native address. This is used in doprim, and
                     \ code/code: primitive definitions word to
                     \ convert the addresses.
                     \ The only target where we need this is the misc
                     \ which is a 16 Bit processor with word addresses
                     \ but the forth system we build has a normal byte
                     \ addressed memory model    
   
   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 835  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 911  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 923  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 987  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 1019  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 1035  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 ;
   
 \ ' >ghostname ALIAS @name  \ ' >ghostname ALIAS @name
   
   : findghost ( "ghostname" -- ghost ) 
     bl word gfind 0= ABORT" CROSS: Ghost don't exists" ;
   
 : [G'] ( -- ghost : name )  : [G'] ( -- ghost : name )
 \G ticks a ghost and returns its address  \G ticks a ghost and returns its address
 \  bl word gfind 0= ABORT" CROSS: Ghost don't exists"    findghost
   ghost state @ IF postpone literal THEN ; immediate    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 864  End-Struct addr-struct Line 1077  End-Struct addr-struct
   dup @ ?dup IF nip EXIT THEN    dup @ ?dup IF nip EXIT THEN
   addr-struct %allocerase tuck swap ! ;    addr-struct %allocerase tuck swap ! ;
   
   >cross
   
 \ 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 (for)                                     drop  
 Ghost (loop)    Ghost (+loop)                   2drop  
 Ghost (next)                                    drop  
 Ghost unloop    Ghost ;S                        2drop  Ghost unloop    Ghost ;S                        2drop
 Ghost lit       Ghost (compile) Ghost !         2drop drop  Ghost lit       Ghost !                         2drop
 Ghost (does>)   Ghost noop                      2drop  Ghost noop                                      drop
 Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop  
 Ghost '                                         drop  
 Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop 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
   Ghost call drop
   Ghost @ drop
   Ghost useraddr drop
   Ghost execute drop
   Ghost + drop
   Ghost decimal drop
   Ghost hex drop
   Ghost lit@ drop
   Ghost lit-perform drop
   Ghost lit+ drop
   Ghost does-exec drop
   
   Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
   Ghost :dovar                                    drop
   
 \ \ Parameter for target systems                         06oct92py  \ \ Parameter for target systems                         06oct92py
   
   
 >cross  
 \ we define it ans like...  \ we define it ans like...
 wordlist Constant target-environment  wordlist Constant target-environment
   
Line 951  false DefaultValue dcomps Line 1170  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 1184  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 1010  tbits/char bits/byte / Constant tbyte Line 1235  tbits/char bits/byte / Constant tbyte
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
   
 Variable image  Variable image
 Variable tlast    TNIL tlast !  \ Last name field  Variable (tlast)    
   (tlast) Value tlast TNIL tlast !  \ Last name field
 Variable tlastcfa \ Last code field  Variable tlastcfa \ Last code field
 Variable bit$  Variable bit$
   
Line 1022  Variable user-vars 0 user-vars ! Line 1248  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 1034  Variable region-link            \ linked Line 1260  Variable region-link            \ linked
 Variable mirrored-link          \ linked list for mirrored regions  Variable mirrored-link          \ linked list for mirrored regions
 0 dup mirrored-link ! region-link !  0 dup mirrored-link ! region-link !
   
   : >rname 8 cells + ;
 : >rname 7 cells + ;  : >rbm   4 cells + ; \ bitfield per cell witch indicates relocation
 : >rbm   4 cells + ;  
 : >rmem  5 cells + ;  : >rmem  5 cells + ;
 : >rtype 6 cells + ;  : >rtype 6 cells + ; \ field per cell witch points to a type struct
   : >rrom 7 cells + ;  \ a -1 indicates that this region is rom
 : >rlink 3 cells + ;  : >rlink 3 cells + ;
 : >rdp 2 cells + ;  : >rdp 2 cells + ;
 : >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 -- "name" )                
 \G create a new region  \G create a new region
   \ check whether predefined region exists     \ check whether predefined region exists 
   save-input bl word find >r >r restore-input throw r> r> 0=     save-input bl word find >r >r restore-input throw r> r> 0= 
Line 1054  Variable mirrored-link          \ linked Line 1284  Variable mirrored-link          \ linked
         save-input create restore-input throw          save-input create restore-input throw
         here last-defined-region !          here last-defined-region !
         over ( startaddr ) , ( length ) , ( dp ) ,          over ( startaddr ) , ( length ) , ( dp ) ,
         region-link linked 0 , 0 , 0 , bl word count string,          region-link linked 0 , 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 1073  Variable mirrored-link          \ linked Line 1302  Variable mirrored-link          \ linked
 \G returns the total area  \G returns the total area
   dup >rstart @ swap >rlen @ ;    dup >rstart @ swap >rlen @ ;
   
 : mirrored                                : mirrored ( -- )                              
 \G mark a region as mirrored  \G mark last defined region as mirrored
   mirrored-link    mirrored-link
   align linked last-defined-region @ , ;    align linked last-defined-region @ , ;
   
   : writeprotected
   \G mark a region as write protected
     -1 last-defined-region @ >rrom ! ;
   
 : .addr ( u -- )  : .addr ( u -- )
 \G prints a 16 or 32 Bit nice hex value  \G prints a 16 or 32 Bit nice hex value
   base @ >r hex    base @ >r hex
Line 1134  T has? rom H Line 1367  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 1407  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 1202  variable sromdp  \ start of rom-area for Line 1438  variable sromdp  \ start of rom-area for
   
 [THEN]  [THEN]
   
   0 Value current-region
 0 value tdp  0 Value tdp
 variable fixed          \ flag: true: no automatic switching  Variable fixed          \ flag: true: no automatic switching
                         \       false: switching is done automatically                          \       false: switching is done automatically
   
 \ Switch-Policy:  \ Switch-Policy:
Line 1219  variable constflag constflag off Line 1455  variable constflag constflag off
   
 : activate ( region -- )  : activate ( region -- )
 \G next code goes to this region  \G next code goes to this region
   >rdp to tdp ;    dup to current-region >rdp to tdp ;
   
 : (switchram)  : (switchram)
   fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT    fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
Line 1274  variable constflag constflag off Line 1510  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 1310  bigendian Line 1549  bigendian
   2drop 0 ;    2drop 0 ;
   
 : taddr>region-abort ( taddr -- region | 0 )  : taddr>region-abort ( taddr -- region | 0 )
   \G Same as taddr>region but aborts if taddr is not
   \G a valid address in the target address space
   dup taddr>region dup 0=     dup taddr>region dup 0= 
   IF    drop cr ." Wrong address: " .addr    IF    drop cr ." Wrong address: " .addr
         -1 ABORT" Address out of range!"          -1 ABORT" Address out of range!"
Line 1325  bigendian Line 1566  bigendian
   \ add regions real address in our memory    \ add regions real address in our memory
   r> >rmem @ + ;    r> >rmem @ + ;
   
   : (>regionramimage) ( taddr -- 'taddr )
   \G same as (>regionimage) but aborts if the region is rom
     dup
     \ find region we want to address
     taddr>region-abort
     >r
     r@ >rrom @ ABORT" CROSS: region is write-protected!"
     \ calculate offset in region
     r@ >rstart @ -
     \ add regions real address in our memory
     r> >rmem @ + ;
   
 : (>regionbm) ( taddr -- 'taddr bitmaskbaseaddr )  : (>regionbm) ( taddr -- 'taddr bitmaskbaseaddr )
   dup    dup
   \ find region we want to address    \ find region we want to address
Line 1373  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1626  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
 : (>image) ( taddr -- absaddr ) image @ + ;  : (>image) ( taddr -- absaddr ) image @ + ;
   
 DEFER >image  DEFER >image
   DEFER >ramimage
 DEFER relon  DEFER relon
 DEFER reloff  DEFER reloff
 DEFER correcter  DEFER correcter
Line 1382  T has? relocate H Line 1636  T has? relocate H
 ' (relon) IS relon  ' (relon) IS relon
 ' (reloff) IS reloff  ' (reloff) IS reloff
 ' (>regionimage) IS >image  ' (>regionimage) IS >image
   ' (>regionimage) IS >ramimage
 [ELSE]  [ELSE]
 ' drop IS relon  ' drop IS relon
 ' drop IS reloff  ' drop IS reloff
 ' (>regionimage) IS >image  ' (>regionimage) IS >image
   ' (>regionimage) IS >ramimage
 [THEN]  [THEN]
   
   : enforce-writeprotection ( -- )
     ['] (>regionramimage) IS >ramimage ;
   
   : relax-writeprotection ( -- )
     ['] (>regionimage) IS >ramimage ;
   
   : writeprotection-relaxed? ( -- )
     ['] >ramimage >body @ ['] (>regionimage) = ;
   
 \ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py
   
 : align+  ( taddr -- rest )  : align+  ( taddr -- rest )
Line 1405  T has? relocate H Line 1670  T has? relocate H
     dup cfalign+ + ;      dup cfalign+ + ;
   
 : @  ( taddr -- w )     >image S@ ;  : @  ( taddr -- w )     >image S@ ;
 : !  ( w taddr -- )     >image S! ;  : !  ( w taddr -- )     >ramimage S! ;
 : c@ ( taddr -- char )  >image Sc@ ;  : c@ ( taddr -- char )  >image Sc@ ;
 : c! ( char taddr -- )  >image Sc! ;  : c! ( char taddr -- )  >ramimage Sc! ;
 : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;  : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
 : 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ;  : 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ;
   
Line 1426  T has? relocate H Line 1691  T has? relocate H
 : A!                    swap >address swap dup relon T ! H ;  : A!                    swap >address swap dup relon T ! H ;
 : A,    ( w -- )        >address T here H relon T , H ;  : A,    ( w -- )        >address T here H relon T , H ;
   
   \ high-level ghosts
   
 >CROSS  >CROSS
   
 : tcmove ( source dest len -- )  Ghost (do)      Ghost (?do)                     2drop
 \G cmove in target memory  Ghost (for)                                     drop
   tchar * bounds  Ghost (loop)    Ghost (+loop)                   2drop
   ?DO  dup T c@ H I T c! H 1+  Ghost (next)                                    drop
   tchar +LOOP  drop ;  Ghost (does>)   Ghost (compile)                 2drop
   Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
   Ghost (C")                                      drop
 \ \ Load Assembler  Ghost '                                         drop
   
 >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  \ user ghosts
   
 previous  Ghost state drop
   
 \ \ --------------------        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 1735  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 )  
 \ 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  
   
   : on            -1 -1 rot TD!  ; 
   : off           T 0 swap ! H ;
   
 Plugin lit, ( n -- )  : tcmove ( source dest len -- )
 Plugin alit, ( n -- )  \G cmove in target memory
     tchar * bounds
 Plugin branch, ( target-addr -- )       \ compiles a branch    ?DO  dup T c@ H I T c! H 1+
 Plugin ?branch, ( target-addr -- )      \ compiles a ?branch    tchar +LOOP  drop ;
 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 colon, 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 1612  Plugin t>body             \ we need the Line 1778  Plugin t>body             \ we need the
         tempdp> ;                               ' (dr) plugin-of doer-resolve          tempdp> ;                               ' (dr) plugin-of doer-resolve
   
 : (cm) ( -- addr )  : (cm) ( -- addr )
     T here align H      there -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 1638  Plugin t>body             \ we need the Line 1804  Plugin t>body             \ we need the
     loadfile ,       loadfile , 
     sourceline# ,       sourceline# , 
     space>      space>
   ;  ;
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
 \G creates a resolve structure  \G creates a resolve structure
Line 1696  Defer resolve-warning Line 1862  Defer resolve-warning
   swap exists-warning    swap exists-warning
   >link ! ;    >link ! ;
   
 Variable rdbg  : colon-resolved   ( ghost -- )
   \ compiles a call to a colon definition,
   \ compile action for >comp field
       >link @ colon, ; 
   
   : prim-resolved  ( ghost -- )
   \ compiles a call to a primitive
       >link @ prim, ;
   
   : (is-forward)   ( ghost -- )
       colonmark, 0 (refered) ; \ compile space for call
   ' (is-forward) IS is-forward
   
 : resolve  ( ghost tcfa -- )  0 Value resolved
 \G resolve referencies to ghost with tcfa  
     rdbg @ IF break: THEN   : resolve-forward-references ( ghost resolve-list -- )
       \ loop through forward referencies
       comp-state @ >r Resolving comp-state !
       over >link @ resolve-loop 
       r> comp-state !
   
       ['] noop IS resolve-warning ;
   
   
   : (resolve) ( ghost tcfa -- ghost resolve-list )
       \ check for a valid address, it is a primitive reference
       \ otherwise
     dup taddr>region 0<> IF      dup taddr>region 0<> IF
         \ define this address in the region address type table
       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
       swap >r
       r@ to resolved
   
   \    r@ >comp @ ['] is-forward =
   \    ABORT" >comp action not set on a resolved ghost"
   
       \ copmile action defaults to colon-resolved
       \ if this is not right something must be set before
       \ calling resolve
       r@ >comp @ ['] is-forward = IF
          ['] colon-resolved r@ >comp !
      THEN
       r@ >link @ swap \ ( list tcfa R: ghost )
       \ mark ghost as resolved
       r@ >link ! <res> r@ >magic !
       r> swap ;
   
   : resolve  ( ghost tcfa -- )
   \G resolve referencies to ghost with tcfa
     \ is ghost resolved?, second resolve means another       \ is ghost resolved?, second resolve means another 
     \ definition with the same name      \ definition with the same name
     over undefined? 0= IF  exists EXIT THEN      over undefined? 0= IF  exists EXIT THEN
     \ get linked-list      (resolve)
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )      ( ghost resolve-list )
     \ mark ghost as resolved      resolve-forward-references ;
     dup r@ >link ! <res> r@ >magic !  
     \ loop through forward referencies  : resolve-noforwards ( ghost tcfa -- )
     r> -rot   \G Same as resolve but complain if there are any
     comp-state @ >r Resolving comp-state !  \G forward references on this ghost
     resolve-loop      \ is ghost resolved?, second resolve means another 
     r> comp-state !     \ definition with the same name
      over undefined? 0= IF  exists EXIT THEN
     ['] noop IS resolve-warning      (resolve)
   ;     IF cr ." No forward references allowed on: " .ghost cr
         -1 ABORT" Illegal forward reference"
      THEN
      drop ;
   
 \ 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> = ABORT" CROSS: gexecute on immediate word"
   (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 2006  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 2051  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 1860  Variable to-doc  to-doc on Line 2064  Variable to-doc  to-doc on
 \ Target TAGS creation  \ Target TAGS creation
   
 s" kernel.TAGS" r/w create-file throw value tag-file-id  s" kernel.TAGS" r/w create-file throw value tag-file-id
   s" kernel.tags" r/w create-file throw value vi-tag-file-id
 \ contains the file-id of the tags file  \ contains the file-id of the tags file
   
 Create tag-beg 2 c,  7F c, bl c,  Create tag-beg 2 c,  7F c, bl c,
 Create tag-end 2 c,  bl c, 01 c,  Create tag-end 2 c,  bl c, 01 c,
 Create tag-bof 1 c,  0C c,  Create tag-bof 1 c,  0C c,
   Create tag-tab 1 c,  09 c,
   
 2variable last-loadfilename 0 0 last-loadfilename 2!  2variable last-loadfilename 0 0 last-loadfilename 2!
                           
Line 1878  Create tag-bof 1 c,  0C c, Line 2084  Create tag-bof 1 c,  0C c,
         s" ,0" tag-file-id write-line throw          s" ,0" tag-file-id write-line throw
     THEN ;      THEN ;
   
 : cross-tag-entry  ( -- )  : cross-gnu-tag-entry  ( -- )
     tlast @ 0<> \ not an anonymous (i.e. noname) header      tlast @ 0<> \ not an anonymous (i.e. noname) header
     IF      IF
         put-load-file-name          put-load-file-name
         source >in @ min tag-file-id write-file throw          source >in @ min tag-file-id write-file throw
         tag-beg count tag-file-id write-file throw          tag-beg count tag-file-id write-file throw
         tlast @ >image count 1F and tag-file-id write-file throw          Last-Header-Ghost @ >ghostname tag-file-id write-file throw
         tag-end count tag-file-id write-file throw          tag-end count tag-file-id write-file throw
         base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw          base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
 \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw  \       >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
Line 1892  Create tag-bof 1 c,  0C c, Line 2098  Create tag-bof 1 c,  0C c,
         base !          base !
     THEN ;      THEN ;
   
   : cross-vi-tag-entry ( -- )
       tlast @ 0<> \ not an anonymous (i.e. noname) header
       IF
           sourcefilename vi-tag-file-id write-file throw
           tag-tab count vi-tag-file-id write-file throw
           Last-Header-Ghost @ >ghostname vi-tag-file-id write-file throw
           tag-tab count vi-tag-file-id write-file throw
           s" /^" vi-tag-file-id write-file throw
           source vi-tag-file-id write-file throw
           s" $/" vi-tag-file-id write-line throw
       THEN ;
   
   : cross-tag-entry ( -- )
       cross-gnu-tag-entry
       cross-vi-tag-entry ;
   
 \ Check for words  \ Check for words
   
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
Line 1973  Defer setup-execution-semantics Line 2195  Defer setup-execution-semantics
 \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !  \    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
     HeaderGhost      HeaderGhost
     \ output symbol table to extra file      \ output symbol table to extra file
     [ [IFDEF] fd-symbol-table ]      dup >ghostname there symentry
       base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !  
       s" :" fd-symbol-table write-file throw  
       dup >ghostname fd-symbol-table write-line throw  
     [ [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 2000  Variable aprim-nr -20 aprim-nr ! Line 2218  Variable aprim-nr -20 aprim-nr !
 : copy-execution-semantics ( ghost-from ghost-dest -- )  : copy-execution-semantics ( ghost-from ghost-dest -- )
   >r    >r
   dup >exec @ r@ >exec !    dup >exec @ r@ >exec !
     dup >comp @ r@ >comp !
   dup >exec2 @ r@ >exec2 !    dup >exec2 @ r@ >exec2 !
   dup >exec-compile @ r@ >exec-compile !    dup >exec-compile @ r@ >exec-compile !
   dup >ghost-xt @ r@ >ghost-xt !    dup >ghost-xt @ r@ >ghost-xt !
Line 2011  Variable aprim-nr -20 aprim-nr ! Line 2230  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 2244  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-noforwards <do:> swap tuck >magic !
   asmprimname, ;    asmprimname, ;
   
 : Alias:   ( cfa -- ) \ name  : Doer:   ( cfa -- ) \ name
   >in @ skip? IF  2drop  EXIT  THEN  >in !    >in @ skip? IF  2drop  EXIT  THEN  >in !
   dup 0< s" prims" T $has? H 0= and    dup 0< s" prims" T $has? H 0= and
   IF    IF
       .sourcepos ." needs doer: " >in @ bl word count type >in ! cr        .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
   THEN    THEN
   Ghost tuck swap resolve <do:> swap >magic ! ;    Ghost
     tuck swap resolve-noforwards <do:> swap >magic ! ;
   
 Variable prim#  Variable prim#
 : first-primitive ( n -- )  prim# ! ;  : first-primitive ( n -- )  prim# ! ;
 : Primitive  ( -- ) \ name  : Primitive  ( -- ) \ name
   >in @ skip? IF  2drop  EXIT  THEN  >in !    >in @ skip? IF  drop  EXIT  THEN  >in !
   dup 0< s" prims" T $has? H 0= and    s" prims" T $has? H 0=
   IF    IF
      .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!    ['] prim-resolved over >comp !
     dup >ghost-flags <primitive> set-flag
     over resolve-noforwards T A, H alias-mask flag!
   -1 prim# +! ;    -1 prim# +! ;
 >CROSS  >CROSS
   
Line 2089  Comment (       Comment \ Line 2311  Comment (       Comment \
 \ compile                                              10may93jaw  \ compile                                              10may93jaw
   
 : compile  ( "name" -- ) \ name  : compile  ( "name" -- ) \ name
 \  bl word gfind 0= ABORT" CROSS: Can't compile "    findghost
   ghost  
   dup >exec-compile @ ?dup    dup >exec-compile @ ?dup
   IF    nip compile,    IF    nip compile,
   ELSE  postpone literal postpone gexecute  THEN ;  immediate restrict    ELSE  postpone literal postpone gexecute  THEN ;  immediate restrict
                           
 >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 2333  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,                                                          ' NOOP plugin-of ca>native
   
 : (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 [G'] :doesjump addr, T 0 , H ;            ' (doeshandler,) plugin-of doeshandler,
   
 : (dodoes,) ( does-action-ghost -- )  : (dodoes,) ( does-action-ghost -- )
   ]comp [G'] :dodoes gexecute comp[    ]comp [G'] :dodoes addr, comp[
   addr,    addr,
   \ 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 2164  Defer (end-code) Line 2394  Defer (end-code)
 >TARGET  >TARGET
 : Code  : Code
   defempty?    defempty?
   (THeader there resolve    (THeader ( ghost )
     ['] prim-resolved over >comp !
     there resolve-noforwards
     
   [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]    [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
   doprim,     doprim, 
   [THEN]    [THEN]
   depth (code) ;    depth (code) ;
   
   \ FIXME : no-compile -1 ABORT" this ghost is not for compilation" ;
   
 : Code:  : Code:
   defempty?    defempty?
     Ghost dup there ca>native resolve  <do:> swap >magic !      Ghost >r 
       r@ >ghostname there symentry
       r@ there ca>native resolve-noforwards
       <do:> r@ >magic !
       r> drop
     depth (code) ;      depth (code) ;
   
 : end-code  : end-code
Line 2188  Defer (end-code) Line 2427  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@ ;
Line 2203  Cond: chars ;Cond Line 2442  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 2228  Cond: MAXI Line 2470  Cond: MAXI
  ;Cond   ;Cond
   
 >CROSS  >CROSS
   
 \ Target compiling loop                                12dec92py  \ Target compiling loop                                12dec92py
 \ ">tib trick thrown out                               10may93jaw  \ ">tib trick thrown out                               10may93jaw
 \ number? defined at the top                           11may93jaw  \ number? defined at the top                           11may93jaw
Line 2248  Cond: MAXI Line 2491  Cond: MAXI
   IF    0> IF swap lit,  THEN  lit, discard    IF    0> IF swap lit,  THEN  lit, discard
   ELSE  2drop restore-input throw Ghost gexecute THEN  ;    ELSE  2drop restore-input throw Ghost gexecute THEN  ;
   
 >TARGET  
 \ : ; DOES>                                            13dec92py  \ : ; DOES>                                            13dec92py
 \ ]                                                     9may93py/jaw  \ ]                                                     9may93py/jaw
   
 : ]   >CROSS
   
   : 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 ! ;
   
   >TARGET
   
   : ] 
       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 2268  Cond: MAXI Line 2526  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 2298  Cond: ?EXIT ( -- ) 1 abort" CROSS: using Line 2557  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  ['] colon-resolved ;Resolve @ >comp !
                ;Cond              ;Resolve @ ;Resolve cell+ @ resolve 
 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
   
 Create GhostDummy ghostheader  0 Value created
 <res> GhostDummy >magic !  
   
 : !does ( does-action -- )  : !does ( does-action -- )
 \ !! zusammenziehen und dodoes, machen!  
     tlastcfa @ [G'] :dovar killref      tlastcfa @ [G'] :dovar killref
 \    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;      >space here >r ghostheader space>
 \ !! geht so nicht, da dodoes, ghost will!      ['] colon-resolved r@ >comp !
     GhostDummy >link ! GhostDummy       r@ created >do:ghost ! r@ swap resolve
     tlastcfa @ >tempdp dodoes, tempdp> ;      r> tlastcfa @ >tempdp dodoes, tempdp> ;
   
   
 Defer instant-compile-does>-hook  
 Defer instant-interpret-does>-hook  Defer instant-interpret-does>-hook
   
   : does-resolved ( ghost -- )
       compile does-exec g>xt T a, H ;
   
 : 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  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>
   instant-interpret-does>-hook      ['] does-resolved created >comp !
   depth T ] H ;      switchrom doeshandler, T here H !does 
       instant-interpret-does>-hook
       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 ! ;    THEN ;
 \  rot swap >exec dup @ ['] NoExec <>  
 \  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 2381  Cond: DOES> Line 2641  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 @ 2dup 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 ! ;
   
   0 Value createhere
   
   : create-resolve ( -- )
       created createhere resolve 0 ;Resolve ! ;
   : create-resolve-immediate ( -- )
       create-resolve T immediate H ;
   
 : TCreate ( <name> -- )  : TCreate ( <name> -- )
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   executed-ghost @ (Theader    executed-ghost @ (Theader
   dup >created on    dup >created on  dup to created
   2dup takeover-x-semantics hereresolve gdoes, ;    2dup takeover-x-semantics
     there to createhere drop gdoes, ;
   
 : RTCreate ( <name> -- )  : RTCreate ( <name> -- )
 \ creates a new word with code-field in ram  \ creates a new word with code-field in ram
Line 2401  Cond: DOES> Line 2671  Cond: DOES>
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   \ make Alias    \ make Alias
   executed-ghost @ (THeader     executed-ghost @ (THeader 
   dup >created on    dup >created on  dup to created
   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
   there tlastcfa !     there tlastcfa ! 
   hereresolve gdoes, ;    there to createhere drop gdoes, ;
   
 : Build:  ( -- [xt] [colon-sys] )  : Build:  ( -- [xt] [colon-sys] )
   :noname postpone TCreate ;    :noname postpone TCreate ;
Line 2421  Cond: DOES> Line 2691  Cond: DOES>
   postpone TCreate     postpone TCreate 
   [ [THEN] ] ;    [ [THEN] ] ;
   
   : ;Build
     postpone create-resolve postpone ; built >exec ! ; immediate
   
   : ;Build-immediate
       postpone create-resolve-immediate
       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] )  : do:ghost! ( ghost -- ) built >do:ghost ! ;
   here ghostheader  : doexec! ( xt -- ) built >do:ghost @ >exec ! ;
   :noname postpone gdoes> ( postpone ?EXIT ) ;  
   
 : by:     ( -- addr [xt] [colon-sys] ) \ name  : DO:     ( -- [xt] [colon-sys] )
   Ghost    here ghostheader do:ghost!
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ;
   
 : ;DO ( addr [xt] [colon-sys] -- addr )  : by:     ( -- [xt] [colon-sys] ) \ name
   postpone ;    ( S addr xt )    Ghost do:ghost!
   over >exec ! ; immediate    :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 2513  Variable tudp 0 tudp ! Line 2790  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 A, A, H ;Build-immediate
   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 latest 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,
   : (callcm) T here 0 a, 0 a, H ;                 ' (callcm) plugin-of colonmark,
   : (call-res) >tempdp resolved gexecute tempdp> drop ;
                                                   ' (call-res) plugin-of colon-resolve
   : (pprim) dup 0< IF  $4000 -  ELSE
       cr ." wrong usage of (prim) "
       dup gdiscover IF  .ghost  ELSE  .  THEN  cr -1 throw  THEN
       T a, H ;                                    ' (pprim) plugin-of prim,
   
   \ if we want this, we have to spilt aconstant
   \ and constant!!
   \ Builder (Constant)
   \ compile: g>body X @ lit, ;compile
   
   Builder (Constant)
   compile: g>body compile lit@ T a, H ;compile
   
   Builder (Value)
   compile: g>body compile lit@ T a, H ;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 compile lit-perform T A, H ;compile
   
   Builder (Field)
   compile: g>body T @ H compile lit+ T , H ;compile
   
   Builder interpret/compile:
   compile: does-resolved ;compile
   
   Builder input-method
   compile: does-resolved ;compile
   
   Builder input-var
   compile: does-resolved ;compile
   
   [THEN]
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py
   
Line 2854  magic 7 + c! Line 3191  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 2870  magic 7 + c! Line 3207  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 2881  magic 7 + c! Line 3218  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 2935  Create name-buf 200 chars allot Line 3272  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 3088  Variable outfile-fd Line 3426  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 3101  Variable outfile-fd Line 3437  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 3181  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3517  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
   
 : d? d? ;  : d? d? ;
   
   : \D ( -- "debugswitch" ) 
 \G doesn't skip line when debug switch is on  \G doesn't skip line when debug switch is on
 : \D D? 0= IF postpone \ THEN ;      D? 0= IF postpone \ THEN ;
   
   : \- ( -- "wordname" )
 \G interprets the line if word is not defined  \G interprets the line if word is not defined
 : \- tdefined? IF postpone \ THEN ;     tdefined? IF postpone \ THEN ;
   
   : \+ ( -- "wordname" )
 \G interprets the line if word is defined  \G interprets the line if word is defined
 : \+ tdefined? 0= IF postpone \ THEN ;     tdefined? 0= IF postpone \ THEN ;
   
   : \? ( -- "envorinstring" )
   \G Skip line if environmental variable evaluates to false
      X has? 0= IF postpone \ THEN ;
   
 Cond: \- \- ;Cond  Cond: \- \- ;Cond
 Cond: \+ \+ ;Cond  Cond: \+ \+ ;Cond
 Cond: \D \D ;Cond  Cond: \D \D ;Cond
   Cond: \? \? ;Cond
   
 : ?? bl word find IF execute ELSE drop 0 THEN ;  : ?? bl word find IF execute ELSE drop 0 THEN ;
   
Line 3261  previous Line 3605  previous
 : rot rot ;  : rot rot ;
 : drop drop ;  : drop drop ;
 : =   = ;  : =   = ;
   : <>  <> ;
 : 0=   0= ;  : 0=   0= ;
 : lshift lshift ;  : lshift lshift ;
 : 2/ 2/ ;  : 2/ 2/ ;
Line 3314  previous Line 3659  previous
 : hwords        words ;  : hwords        words ;
 \ : words       also ghosts   \ : words       also ghosts 
 \                words previous ;  \                words previous ;
 \ : .s            .s ;  : .s            .s ;
   : depth         depth ;
 : bye           bye ;  : bye           bye ;
   
 \ dummy  \ dummy
Line 3358  UNLOCK >CROSS Line 3704  UNLOCK >CROSS
 [IFDEF] extend-cross extend-cross [THEN]  [IFDEF] extend-cross extend-cross [THEN]
   
 LOCK  LOCK
   
   
   

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


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