Diff for /gforth/cross.fs between versions 1.117 and 1.129

version 1.117, 2002/01/04 20:31:53 version 1.129, 2002/09/26 11:36:42
Line 27  ToDo: Line 27  ToDo:
   cross.fs is used 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
 - MAXU etc. can be done with dlit,  
   
 [THEN]  [THEN]
   
   s" compat/strcomp.fs" included
   
 hex  hex
   
 \ debugging for compiling  \ debugging for compiling
Line 71  H Line 72  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 249  hex     \ the defualt base for the cross Line 254  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" (" str=
         IF    postpone (          IF    postpone (
         ELSE  2dup s" \" compare 0= IF postpone \ THEN          ELSE  2dup s" \" str= IF postpone \ THEN
         THEN ;          THEN ;
   
 : X     bl word count [ ' target >wordlist ] Literal search-wordlist  : X ( -- <name> )
         IF      state @ IF compile,  \G The next word in the input is a target word.
                 ELSE execute THEN  \G Equivalent to T <name> but without permanent
         ELSE    -1 ABORT" Cross: access method not supported!"  \G switch to target dictionary. Used as prefix e.g. for @, !, here etc.
         THEN ; immediate    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:
   
Line 310  set-order previous Line 320  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 454  sourcepath value fpath Line 476  sourcepath value fpath
     2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....      2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
     over c@ [char] / = >r      over c@ [char] / = >r
     over c@ [char] ~ = >r      over c@ [char] ~ = >r
     \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic      \ 2dup S" ../" string-prefix? r> or >r \ not catered for in expandtopic
     2 min S" ./" compare 0=      S" ./" string-prefix?
     r> r> r> or or or ;      r> r> r> or or or ;
   
 Create ofile 0 c, 255 chars allot  Create ofile 0 c, 255 chars allot
Line 471  Create tfile 0 c, 255 chars allot Line 493  Create tfile 0 c, 255 chars allot
   REPEAT ;    REPEAT ;
   
 : remove~+ ( -- )  : remove~+ ( -- )
     ofile count 3 min s" ~+/" compare 0=      ofile count s" ~+/" string-prefix?
     IF      IF
         ofile count 3 /string ofile place          ofile count 3 /string ofile place
     THEN ;      THEN ;
   
 : expandtopic ( -- ) \ stack effect correct? - anton  : expandtopic ( -- ) \ stack effect correct? - anton
     \ expands "./" into an absolute name      \ expands "./" into an absolute name
     ofile count 2 min s" ./" compare 0=      ofile count s" ./" string-prefix?
     IF      IF
         ofile count 1 /string tfile place          ofile count 1 /string tfile place
         0 ofile c! sourcefilename extractpath ofile place          0 ofile c! sourcefilename extractpath ofile place
Line 491  Create tfile 0 c, 255 chars allot Line 513  Create tfile 0 c, 255 chars allot
     \ deletes phrases like "xy/.." out of our directory name 2dec97jaw      \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
     over swap      over swap
     BEGIN  dup  WHILE      BEGIN  dup  WHILE
         dup >r '/ scan 2dup 4 min s" /../" compare 0=          dup >r '/ scan 2dup s" /../" string-prefix?
         IF          IF
             dup r> - >r 4 /string over r> + 4 -              dup r> - >r 4 /string over r> + 4 -
             swap 2dup + >r move dup r> over -              swap 2dup + >r move dup r> over -
Line 554  fpath= ~+ Line 576  fpath= ~+
 : included? ( c-addr u -- f )  : included? ( c-addr u -- f )
   file-list    file-list
   BEGIN @ dup    BEGIN @ dup
   WHILE >r 2dup r@ >fl-name count compare 0=    WHILE >r 2dup r@ >fl-name count str=
         IF rdrop 2drop true EXIT THEN          IF rdrop 2drop true EXIT THEN
         r>          r>
   REPEAT    REPEAT
Line 712  Plugin branchtoresolve, ( branch-addr -- Line 734  Plugin branchtoresolve, ( branch-addr --
 Plugin branchtomark, ( -- target-addr ) \ marks a branch destination  Plugin branchtomark, ( -- target-addr ) \ marks a branch destination
   
 Plugin colon, ( tcfa -- )               \ compiles call to tcfa at current position  Plugin colon, ( tcfa -- )               \ compiles call to tcfa at current position
 Plugin xt, ( tcfa -- )                  \ compiles xt  
 Plugin prim, ( tcfa -- )                \ compiles primitive invocation  Plugin prim, ( tcfa -- )                \ compiles primitive invocation
 Plugin colonmark, ( -- addr )           \ marks a colon call  Plugin colonmark, ( -- addr )           \ marks a colon call
 Plugin colon-resolve ( tcfa addr -- )  Plugin colon-resolve ( tcfa addr -- )
Line 746  Plugin next, ( for-token ) Line 767  Plugin next, ( for-token )
 Plugin leave,   ( -- )  Plugin leave,   ( -- )
 Plugin ?leave,  ( -- )  Plugin ?leave,  ( -- )
   
 [IFUNDEF] ca>native  Plugin ca>native  \ Convert a code address to the processors
 Plugin ca>native                            \ native address. This is used in doprim, and
 [THEN]                    \ 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 doprim,  \ compiles start of a primitive
 Plugin docol,           \ compiles start of a colon definition  Plugin docol,           \ compiles start of a colon definition
Line 901  Variable cross-space-dp-orig Line 927  Variable cross-space-dp-orig
 Defer is-forward  Defer is-forward
   
 : (ghostheader) ( -- )  : (ghostheader) ( -- )
   ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward ,       ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward ,
   0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
   
 : ghostheader ( -- ) (ghostheader) 0 , ;  : ghostheader ( -- ) (ghostheader) 0 , ;
   
Line 1052  End-Struct addr-struct Line 1078  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 - 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 2drop drop  Ghost 2drop drop
 Ghost 2dup drop  Ghost 2dup drop
 Ghost state drop  
 Ghost call drop  Ghost call drop
 Ghost @ drop  Ghost @ drop
 Ghost useraddr drop  Ghost useraddr drop
 Ghost execute drop  Ghost execute drop
 Ghost + drop  Ghost + drop
 Ghost (C") drop  
 Ghost decimal drop  Ghost decimal drop
 Ghost hex 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 1150  false DefaultValue header Line 1174  false DefaultValue header
 false DefaultValue backtrace  false DefaultValue backtrace
 false DefaultValue new-input  false DefaultValue new-input
 false DefaultValue peephole  false DefaultValue peephole
   false DefaultValue abranch
 [THEN]  [THEN]
   
 true DefaultValue interpreter  true DefaultValue interpreter
Line 1212  tbits/char bits/byte / Constant tbyte Line 1237  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 1236  Variable region-link            \ linked Line 1262  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+ ;
Line 1251  Variable mirrored-link          \ linked Line 1277  Variable mirrored-link          \ linked
   >r r@ last-defined-region !    >r r@ last-defined-region !
   r@ >rlen ! dup r@ >rstart ! r> >rdp ! ;    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 1260  Variable mirrored-link          \ linked Line 1286  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 (region)          >body (region)
Line 1278  Variable mirrored-link          \ linked Line 1304  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 1410  variable sromdp  \ start of rom-area for Line 1440  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 1427  variable constflag constflag off Line 1457  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 1521  bigendian Line 1551  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 1536  bigendian Line 1568  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 1584  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1628  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 1593  T has? relocate H Line 1638  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 1616  T has? relocate H Line 1672  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 1637  T has? relocate H Line 1693  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
   
   Ghost (do)      Ghost (?do)                     2drop
   Ghost (for)                                     drop
   Ghost (loop)    Ghost (+loop)                   2drop
   Ghost (next)                                    drop
   Ghost (does>)   Ghost (compile)                 2drop
   Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
   Ghost (C")                                      drop
   Ghost '                                         drop
   
   \ user ghosts
   
   Ghost state drop
   
 \ \ --------------------        Host/Target copy etc.           29aug01jaw  \ \ --------------------        Host/Target copy etc.           29aug01jaw
   
Line 1695  previous Line 1767  previous
 >CROSS  >CROSS
   
 : (cc) T a, H ;                                 ' (cc) plugin-of colon,  : (cc) T a, H ;                                 ' (cc) plugin-of colon,
 : (xt) T a, H ;                                 ' (xt) plugin-of xt,  
 : (prim) T a, H ;                               ' (prim) plugin-of prim,  : (prim) T a, H ;                               ' (prim) plugin-of prim,
   
 : (cr) >tempdp ]comp xt, 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 1709  previous Line 1780  previous
         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 xt, ;                                    ' (cm) plugin-of colonmark,  
   
 >TARGET  >TARGET
 : compile, ( xt -- )  : compile, ( xt -- )
Line 1736  previous Line 1806  previous
     loadfile ,       loadfile , 
     sourceline# ,       sourceline# , 
     space>      space>
   ;  ;
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
 \G creates a resolve structure  \G creates a resolve structure
Line 1795  Defer resolve-warning Line 1865  Defer resolve-warning
   >link ! ;    >link ! ;
   
 : colon-resolved   ( ghost -- )  : colon-resolved   ( ghost -- )
     >link @ colon, ; \ compile-call  \ compiles a call to a colon definition,
   \ compile action for >comp field
       >link @ colon, ; 
   
 : prim-resolved  ( ghost -- )  : prim-resolved  ( ghost -- )
   \ compiles a call to a primitive
     >link @ prim, ;      >link @ prim, ;
   
 \ FIXME: not used currently  
 : does-resolved ( ghost -- )  
     dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ;  
   
 : (is-forward)   ( ghost -- )  : (is-forward)   ( ghost -- )
   colonmark, 0 (refered) ; \ compile space for call      colonmark, 0 (refered) ; \ compile space for call
 ' (is-forward) IS is-forward  ' (is-forward) IS is-forward
   
 : resolve  ( ghost tcfa -- )  0 Value resolved
 \G resolve referencies to ghost with tcfa  
   : 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 take over the alias ghost        \ this is for not to take over the alias ghost
       \ (different ghost, but identical xt)        \ (different ghost, but identical xt)
       \ but the very first that really defines it        \ but the very first that really defines it
       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 !  
     r@ >comp @ ['] is-forward = IF  : resolve-noforwards ( ghost tcfa -- )
         ['] prim-resolved  r@ >comp !  THEN  \G Same as resolve but complain if there are any
     \ loop through forward referencies  \G forward references on this ghost
     r> -rot      \ is ghost resolved?, second resolve means another 
     comp-state @ >r Resolving comp-state !     \ definition with the same name
     resolve-loop      over undefined? 0= IF  exists EXIT THEN
     r> comp-state !     (resolve)
      IF cr ." No forward references allowed on: " .ghost cr
     ['] noop IS resolve-warning         -1 ABORT" Illegal forward reference"
   ;     THEN
      drop ;
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
Line 1844  Defer resolve-warning Line 1944  Defer resolve-warning
   dup >comp @ EXECUTE ;    dup >comp @ EXECUTE ;
   
 : 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 -- )
Line 2097  Defer setup-execution-semantics Line 2197  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
     alias-mask flag!      alias-mask flag!
Line 2157  Defer setup-prim-semantics Line 2253  Defer setup-prim-semantics
   
 : mapprim:   ( "forthname" "asmlabel" -- )   : 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# ! ;
Line 2177  Variable prim# Line 2274  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 )
     ['] prim-resolved over >comp !
   dup >ghost-flags <primitive> set-flag    dup >ghost-flags <primitive> set-flag
   over resolve T A, H alias-mask flag!    over resolve-noforwards T A, H alias-mask flag!
   -1 prim# +! ;    -1 prim# +! ;
 >CROSS  >CROSS
   
Line 2258  T 2 cells H Value xt>body Line 2356  T 2 cells H Value xt>body
   
 : (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
Line 2296  Defer (end-code) Line 2396  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 2332  Cond: chars ;Cond Line 2441  Cond: chars ;Cond
   
 \ some special literals                                 27jan97jaw  \ some special literals                                 27jan97jaw
   
 \ !! Known Bug: Special Literals and plug-ins work only correct  
 \ on 16 and 32 Bit Targets and 32 Bit Hosts!  
   
 \ This section could be done with dlit, now. But first I need  
 \ some test code JAW  
   
 Cond: MAXU  Cond: MAXU
   tcell 1 cells u>     -1 s>d dlit,
   IF    compile lit tcell 0 ?DO FF T c, H LOOP   
   ELSE  ffffffff lit, THEN  
   ;Cond    ;Cond
   
   tcell 2 = tcell 4 = or tcell 8 = or 0=
   [IF]
   .( Warning: MINI and MAXI may not work with this host) cr
   [THEN]
   
 Cond: MINI  Cond: MINI
   tcell 1 cells u>    tcell 2 = IF $8000 ELSE $80000000 THEN 0
   IF    compile lit bigendian     tcell 8 = IF swap THEN dlit,
         IF      80 T c, H tcell 1 ?DO 0 T c, H LOOP   
         ELSE    tcell 1 ?DO 0 T c, H LOOP 80 T c, H  
         THEN  
   ELSE  tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN  
   ;Cond    ;Cond
     
 Cond: MAXI  Cond: MAXI
  tcell 1 cells u>    tcell 2 = IF $7fff ELSE $7fffffff THEN 0
  IF     compile lit bigendian     tcell 8 = IF drop -1 swap THEN dlit,
         IF      7F T c, H tcell 1 ?DO FF T c, H LOOP    ;Cond
         ELSE    tcell 1 ?DO FF T c, H LOOP 7F T c, H  
         THEN  
  ELSE   tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN  
  ;Cond  
   
 >CROSS  >CROSS
   
Line 2458  Cond: ; ( -- ) Line 2556  Cond: ; ( -- )
         fini,          fini,
         comp[          comp[
         ;Resolve @           ;Resolve @ 
         IF      ;Resolve @ ;Resolve cell+ @ resolve           IF  ['] colon-resolved ;Resolve @ >comp !
                 ['] colon-resolved ;Resolve @ >comp !              ;Resolve @ ;Resolve cell+ @ resolve 
         THEN          THEN
         interpreting-state          interpreting-state
         ;Cond          ;Cond
Line 2473  Cond: [ ( -- ) interpreting-state ;Cond Line 2571  Cond: [ ( -- ) interpreting-state ;Cond
 : !does ( does-action -- )  : !does ( does-action -- )
     tlastcfa @ [G'] :dovar killref      tlastcfa @ [G'] :dovar killref
     >space here >r ghostheader space>      >space here >r ghostheader space>
       ['] colon-resolved r@ >comp !
     r@ created >do:ghost ! r@ swap resolve      r@ created >do:ghost ! r@ swap resolve
     r> tlastcfa @ >tempdp dodoes, tempdp> ;      r> tlastcfa @ >tempdp dodoes, tempdp> ;
   
 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     Last-Header-Ghost @ >do:ghost @ ?dup 
Line 2489  Cond: DOES> Line 2591  Cond: DOES>
         resolve-does>-part          resolve-does>-part
         ;Cond          ;Cond
   
 : DOES> switchrom doeshandler, T here H !does   : DOES>
   ['] does-resolved created >comp !      ['] does-resolved created >comp !
   instant-interpret-does>-hook      switchrom doeshandler, T here H !does 
   depth T ] H ;      instant-interpret-does>-hook
       depth T ] H ;
   
 >CROSS  >CROSS
 \ Creation                                              01nov92py  \ Creation                                              01nov92py
Line 2538  Cond: DOES> Line 2641  Cond: DOES>
    2dup >exec @ swap >exec2 !      2dup >exec @ swap >exec2 ! 
    >comp @ swap >comp ! ;     >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 to created    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 2551  Cond: DOES> Line 2662  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 alias-mask 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 2572  Cond: DOES> Line 2683  Cond: DOES>
   [ [THEN] ] ;    [ [THEN] ] ;
   
 : ;Build  : ;Build
   postpone ; built >exec ! ; immediate    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 @ g>body ;    executed-ghost @ g>body ;
Line 2697  BuildSmart:  ( -- ) [T'] noop T A, H ;Bu Line 2812  BuildSmart:  ( -- ) [T'] noop T A, H ;Bu
 by: :dodefer ( ghost -- ) X @ texecute ;DO  by: :dodefer ( ghost -- ) X @ texecute ;DO
   
 Builder interpret/compile:  Builder interpret/compile:
 Build: ( inter comp -- ) swap T immediate A, A, H ;Build  Build: ( inter comp -- ) swap T A, A, H ;Build-immediate
 DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
   
 \ Sturctures                                           23feb95py  \ Sturctures                                           23feb95py
Line 2740  DO:  abort" Not in cross mode" ;DO Line 2855  DO:  abort" Not in cross mode" ;DO
 \ this section defines different compilation  \ this section defines different compilation
 \ actions for created words  \ actions for created words
 \ this will help the peephole optimizer  \ this will help the peephole optimizer
 \ I (jaw) took this from bernds lates cross-compiler  \ I (jaw) took this from bernds latest cross-compiler
 \ changes but seperated it from the original  \ changes but seperated it from the original
 \ Builder words. The final plan is to put this  \ Builder words. The final plan is to put this
 \ into a seperate file, together with the peephole  \ into a seperate file, together with the peephole
Line 2750  DO:  abort" Not in cross mode" ;DO Line 2865  DO:  abort" Not in cross mode" ;DO
 T has? peephole H [IF]  T has? peephole H [IF]
   
 >CROSS  >CROSS
   
 : (callc) compile call T >body a, H ;           ' (callc) plugin-of colon,  : (callc) compile call T >body a, H ;           ' (callc) plugin-of colon,
 : (prim) dup 0< IF  ( $4000 - ) ELSE  : (callcm) T here 0 a, 0 a, H ;                 ' (callcm) plugin-of colonmark,
     ." wrong usage of (prim) "  : (call-res) >tempdp resolved gexecute tempdp> drop ;
     dup gdiscover IF  .ghost  ELSE  .  THEN  cr -2 throw  THEN                                                  ' (call-res) plugin-of colon-resolve
     T a, H ;                                    ' (prim) plugin-of prim,  : (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  \ if we want this, we have to spilt aconstant
 \ and constant!!  \ and constant!!
Line 2762  T has? peephole H [IF] Line 2881  T has? peephole H [IF]
 \ compile: g>body X @ lit, ;compile  \ compile: g>body X @ lit, ;compile
   
 Builder (Constant)  Builder (Constant)
 compile: g>body alit, compile @ ;compile  compile: g>body compile lit@ T a, H ;compile
   
 Builder (Value)  Builder (Value)
 compile: g>body alit, compile @ ;compile  compile: g>body compile lit@ T a, H ;compile
   
 \ this changes also Variable, AVariable and 2Variable  \ this changes also Variable, AVariable and 2Variable
 Builder Create  Builder Create
Line 2775  Builder User Line 2894  Builder User
 compile: g>body compile useraddr T @ , H ;compile  compile: g>body compile useraddr T @ , H ;compile
   
 Builder Defer  Builder Defer
 compile: g>body alit, compile @ compile execute ;compile  compile: g>body compile lit-perform T A, H ;compile
   
 Builder (Field)  Builder (Field)
 compile: g>body T @ H lit, compile + ;compile  compile: g>body T @ H compile lit+ T , H ;compile
   
 Builder interpret/compile:  Builder interpret/compile:
 compile: does-resolved ;compile  compile: does-resolved ;compile
Line 2809  compile: does-resolved ;compile Line 2928  compile: does-resolved ;compile
   
 : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw  : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
   
 : >resolve    ( sys -- )          
         X here ( dup ." >" hex. ) over branchoffset swap X ! ;  
   
 : <resolve    ( sys -- )  
         X here ( dup ." <" hex. ) branchoffset X , ;  
   
 :noname compile branch X here branchoffset X , ;  :noname compile branch X here branchoffset X , ;
   IS branch, ( target-addr -- )    IS branch, ( target-addr -- )
 :noname compile ?branch X here branchoffset X , ;  :noname compile ?branch X here branchoffset X , ;
Line 2841  compile: does-resolved ;compile Line 2954  compile: does-resolved ;compile
   
 Variable tleavings 0 tleavings !  Variable tleavings 0 tleavings !
   
 : (done) ( addr -- )  : (done) ( do-addr -- )
   \G resolve branches of leave and ?leave and ?do
   \G do-addr is the address of the beginning of our
   \G loop so we can take care of nested loops
     tleavings @      tleavings @
     BEGIN  dup      BEGIN  dup
     WHILE      WHILE
Line 2891  Cond: ?LEAVE    ?leave, ;Cond Line 3007  Cond: ?LEAVE    ?leave, ;Cond
     0 DO  dup @ swap 1 cells -  LOOP      0 DO  dup @ swap 1 cells -  LOOP
     free throw ;      free throw ;
   
 : loop]     branchto, dup <resolve tcell - (done) ;  : loop] ( target-addr -- )
     branchto, 
     dup   X here branchoffset X , 
     tcell - (done) ;
   
 : skiploop] ?dup IF branchto, branchtoresolve, THEN ;  : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
   
Line 2995  Cond: LOOP 1 ncontrols? loop, ;Cond Line 3114  Cond: LOOP 1 ncontrols? loop, ;Cond
 Cond: +LOOP     1 ncontrols? +loop, ;Cond  Cond: +LOOP     1 ncontrols? +loop, ;Cond
 Cond: NEXT      1 ncontrols? next, ;Cond  Cond: NEXT      1 ncontrols? next, ;Cond
   
   \ Absoulte branches                                     26sep02jaw
   
   \ This section defined different semantics for
   \ conditionals, using and compiling absolute branches
   
   X has? abranch [IF]
   
   Ghost abranch drop
   Ghost a?branch drop
   Ghost a(?do) drop
   Ghost a(do) drop
   Ghost a(next) drop
   Ghost a(+loop) drop
   Ghost a(loop) drop
   
   :noname compile abranch X a, ;             plugin-of branch,
   
   :noname compile a?branch X a, ;            plugin-of ?branch,
   
   :noname compile abranch T here 0  a, H ;   plugin-of branchmark,
   
   :noname compile a?branch T here 0 a, H ;   plugin-of ?branchmark,
   
   :noname 
     dup X @ ABORT" CROSS: branch already resolved"
     X here swap X a! ;                       plugin-of branchtoresolve,
   
   :noname 
     0 compile a(?do) ?domark, (leave)
     branchtomark, 2 to1 ;                    plugin-of ?do,
   
   : aloop] ( target-addr -- )
     branchto, 
     dup X a, 
     tcell - (done) ;
   
   :noname 
     1to compile a(loop) aloop] 
     compile unloop skiploop] ;               plugin-of loop,
   
   :noname 
     1to compile a(+loop) aloop]
     compile unloop skiploop] ;               plugin-of +loop,
   
   :noname
     compile a(next) aloop] compile unloop ;   plugin-of next,
   
   [THEN]
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
   
 : ,"            [char] " parse ht-string, X align ;  : ,"            [char] " parse ht-string, X align ;
Line 3236  Variable outfile-fd Line 3404  Variable outfile-fd
   dup @ dup IF addr-refs @ THEN    dup @ dup IF addr-refs @ THEN
   swap >r    swap >r
   over align+ tuck tcell swap - rshift swap 0    over align+ tuck tcell swap - rshift swap 0
   DO dup 1 and     ?DO dup 1 and 
      IF drop rdrop snl-calc UNLOOP EXIT THEN        IF drop rdrop snl-calc UNLOOP EXIT THEN 
      2/ swap 1+ swap        2/ swap 1+ swap 
   LOOP    LOOP
Line 3323  Create parsed 20 chars allot \ store wor Line 3491  Create parsed 20 chars allot \ store wor
     1 BEGIN      1 BEGIN
         BEGIN bl word count dup WHILE          BEGIN bl word count dup WHILE
             comment? 20 umin parsed place upcase parsed count              comment? 20 umin parsed place upcase parsed count
             2dup s" [IF]" compare 0= >r               2dup s" [IF]" str= >r 
             2dup s" [IFUNDEF]" compare 0= >r              2dup s" [IFUNDEF]" str= >r
             2dup s" [IFDEF]" compare 0= r> or r> or              2dup s" [IFDEF]" str= r> or r> or
             IF   2drop 1+              IF   2drop 1+
             ELSE 2dup s" [ELSE]" compare 0=              ELSE 2dup s" [ELSE]" str=
                 IF   2drop 1- dup                  IF   2drop 1- dup
                     IF 1+                      IF 1+
                     THEN                      THEN
                 ELSE                  ELSE
                     2dup s" [ENDIF]" compare 0= >r                      2dup s" [ENDIF]" str= >r
                     s" [THEN]" compare 0= r> or                      s" [THEN]" str= r> or
                     IF 1- THEN                      IF 1- THEN
                 THEN                  THEN
             THEN              THEN
Line 3381  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3549  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
      IF    >in ! X :       IF    >in ! X :
      ELSE drop       ELSE drop
         BEGIN bl word dup c@          BEGIN bl word dup c@
               IF   count comment? s" ;" compare 0= ?EXIT                IF   count comment? s" ;" str= ?EXIT
               ELSE refill 0= ABORT" CROSS: Out of Input while C:"                ELSE refill 0= ABORT" CROSS: Out of Input while C:"
               THEN                THEN
         AGAIN          AGAIN
Line 3389  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3557  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 3469  previous Line 3645  previous
 : rot rot ;  : rot rot ;
 : drop drop ;  : drop drop ;
 : =   = ;  : =   = ;
   : <>  <> ;
 : 0=   0= ;  : 0=   0= ;
 : lshift lshift ;  : lshift lshift ;
 : 2/ 2/ ;  : 2/ 2/ ;
Line 3506  previous Line 3683  previous
 : doc-on        true  to-doc ! ;  : doc-on        true  to-doc ! ;
   
 : declareunique ( "name" -- )  : declareunique ( "name" -- )
 \G Sets the unique flag for a ghost. The assembler output  \ Sets the unique flag for a ghost. The assembler output
 \G generates labels with the ghostname concatenated with the address  \ generates labels with the ghostname concatenated with the address
 \G while cross-compiling. The address is concatenated  \ while cross-compiling. The address is concatenated
 \G because we have double occurences of the same name.  \ because we have double occurences of the same name.
 \G If we want to reference the labels from the assembler or C  \ If we want to reference the labels from the assembler or C
 \G code we declare them unique, so the address is skipped.  \ code we declare them unique, so the address is skipped.
   Ghost >ghost-flags dup @ <unique> or swap ! ;    Ghost >ghost-flags dup @ <unique> or swap ! ;
   
 \ [IFDEF] dbg : dbg dbg ; [THEN]  \ [IFDEF] dbg : dbg dbg ; [THEN]
Line 3523  previous Line 3700  previous
 \ : words       also ghosts   \ : words       also ghosts 
 \                words previous ;  \                words previous ;
 : .s            .s ;  : .s            .s ;
   : depth         depth ;
 : bye           bye ;  : bye           bye ;
   
 \ dummy  \ dummy

Removed from v.1.117  
changed lines
  Added in v.1.129


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