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

version 1.117, 2002/01/04 20:31:53 version 1.182, 2012/05/09 22:23:52
Line 1 Line 1
 \ CROSS.FS     The Cross-Compiler                      06oct92py  \ CROSS.FS     The Cross-Compiler                      06oct92py
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 \ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006,2007,2009,2010,2011 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
 \ Gforth is free software; you can redistribute it and/or  \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License  \ modify it under the terms of the GNU General Public License
 \ as published by the Free Software Foundation; either version 2  \ as published by the Free Software Foundation, either version 3
 \ of the License, or (at your option) any later version.  \ of the License, or (at your option) any later version.
   
 \ This program is distributed in the hope that it will be useful,  \ This program is distributed in the hope that it will be useful,
Line 16 Line 16
 \ GNU General Public License for more details.  \ GNU General Public License for more details.
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program. If not, see http://www.gnu.org/licenses/.
 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  
   
 0   0 
 [IF]  [IF]
Line 27  ToDo: Line 26  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 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 187  Create bases   10 ,   2 ,   A , 100 , Line 191  Create bases   10 ,   2 ,   A , 100 ,
         1+          1+
     THEN ;      THEN ;
   
 : number? ( string -- string 0 / n -1 / d 0> )  : (number?) ( string -- string 0 / n -1 / d 0> )
     dup >r count snumber? dup if      dup >r count snumber? dup if
         rdrop          rdrop
     else      else
Line 195  Create bases   10 ,   2 ,   A , 100 , Line 199  Create bases   10 ,   2 ,   A , 100 ,
     then ;      then ;
   
 : number ( string -- d )  : number ( string -- d )
     number? ?dup 0= abort" ?"  0<      (number?) ?dup 0= abort" ?"  0<
     IF      IF
         s>d          s>d
     THEN ;      THEN ;
   
 [THEN]  [THEN]
   
   [IFUNDEF] (number?) : (number?) number? ; [THEN]
   
 \ this provides assert( and struct stuff  \ this provides assert( and struct stuff
 \GFORTH [IFUNDEF] assert1(  \GFORTH [IFUNDEF] assert1(
 \GFORTH also forth definitions require assert.fs previous  \GFORTH also forth definitions require assert.fs previous
Line 249  hex     \ the defualt base for the cross Line 255  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 321  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 425  sourcepath value fpath Line 448  sourcepath value fpath
     \G Make a complete new Forth search path; the path separator is |.      \G Make a complete new Forth search path; the path separator is |.
     fpath path= ;      fpath path= ;
   
 : path>counted  cell+ dup cell+ swap @ ;  : path>string  cell+ dup cell+ swap @ ;
   
 : next-path ( adr len -- adr2 len2 )  : next-path ( adr len -- adr2 len2 )
   2dup 0 scan    2dup 0 scan
Line 434  sourcepath value fpath Line 457  sourcepath value fpath
   r> - ;    r> - ;
   
 : previous-path ( path^ -- )  : previous-path ( path^ -- )
   dup path>counted    dup path>string
   BEGIN tuck dup WHILE repeat ;    BEGIN tuck dup WHILE repeat ;
   
 : .path ( path-addr -- ) \ gforth  : .path ( path-addr -- ) \ gforth
     \G Display the contents of the search path @var{path-addr}.      \G Display the contents of the search path @var{path-addr}.
     path>counted      path>string
     BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ;      BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ;
   
 : .fpath ( -- ) \ gforth  : .fpath ( -- ) \ gforth
Line 454  sourcepath value fpath Line 477  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 494  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 514  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 524  Create tfile 0 c, 255 chars allot Line 547  Create tfile 0 c, 255 chars allot
   IF    rdrop    IF    rdrop
         ofile place open-ofile          ofile place open-ofile
         dup 0= IF >r ofile count r> THEN EXIT          dup 0= IF >r ofile count r> THEN EXIT
   ELSE  r> path>counted    ELSE  r> path>string
         BEGIN  next-path dup          BEGIN  next-path dup
         WHILE  5 pick 5 pick check-path          WHILE  5 pick 5 pick check-path
         0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN          0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN
Line 554  fpath= ~+ Line 577  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 640  stack-warn [IF] Line 663  stack-warn [IF]
 : defempty? empty? ;  : defempty? empty? ;
 [ELSE]  [ELSE]
 : defempty? ; immediate  : defempty? ; immediate
   \ : defempty? .sourcepos ; 
 [THEN]  [THEN]
   
 \ \ --------------------        Compiler Plug Ins               01aug97jaw  \ \ --------------------        Compiler Plug Ins               01aug97jaw
Line 712  Plugin branchtoresolve, ( branch-addr -- Line 736  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 742  Plugin ?do, ( -- ?do-token ) Line 765  Plugin ?do, ( -- ?do-token )
 Plugin for,     ( -- for-token )  Plugin for,     ( -- for-token )
 Plugin loop,    ( do-token / ?do-token -- )  Plugin loop,    ( do-token / ?do-token -- )
 Plugin +loop,   ( do-token / ?do-token -- )  Plugin +loop,   ( do-token / ?do-token -- )
   Plugin -loop,   ( do-token / ?do-token -- )
 Plugin next,    ( for-token )  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 930  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 1081  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 1177  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 primcentric
   false DefaultValue abranch
   true DefaultValue f83headerstring
   true DefaultValue control-rack
 [THEN]  [THEN]
   
   true DefaultValue gforthcross
 true DefaultValue interpreter  true DefaultValue interpreter
 true DefaultValue ITC  true DefaultValue ITC
 false DefaultValue rom  false DefaultValue rom
   false DefaultValue flash
 true DefaultValue standardthreading  true DefaultValue standardthreading
   
   \ ANSForth environment  stuff
   8 DefaultValue ADDRESS-UNIT-BITS
   255 DefaultValue MAX-CHAR
   255 DefaultValue /COUNTED-STRING
   
 >TARGET  >TARGET
 s" relocate" T environment? H   s" relocate" T environment? H 
 \ JAW why set NIL to this?!  \ JAW why set NIL to this?!
Line 1208  bits/byte  Constant tbits/byte Line 1246  bits/byte  Constant tbits/byte
 H  H
 tbits/char bits/byte /  Constant tbyte  tbits/char bits/byte /  Constant tbyte
   
   : >signed ( u -- n )
       1 tbits/char tcell * 1- lshift 2dup and
       IF  negate or  ELSE  drop  THEN ;
   
 \ Variables                                            06oct92py  \ Variables                                            06oct92py
   
 Variable image  Variable (tlast)    
 Variable tlast    TNIL tlast !  \ Last name field  (tlast) Value tlast TNIL tlast !  \ Last name field
 Variable tlastcfa \ Last code field  Variable tlastcfa \ Last code field
 Variable bit$  
   
 \ statistics                                            10jun97jaw  \ statistics                                            10jun97jaw
   
Line 1236  Variable region-link            \ linked Line 1276  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 9 cells + ;
 : >rname 7 cells + ;  : >rtouch 8 cells + ; \ executed when region is accessed
 : >rbm   4 cells + ;  : >rbm   4 cells + ; \ bitfield per cell witch indicates relocation
 : >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 1292  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 -- )                  : uninitialized -1 ABORT" CROSS: Region is uninitialized" ;
   
   : 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 1303  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 , 
           ['] uninitialized ,
           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 1323  Variable mirrored-link          \ linked
 \G returns the total area  \G returns the total area
   dup >rstart @ swap >rlen @ ;    dup >rstart @ swap >rlen @ ;
   
 : mirrored                                : dp@ ( region -- dp )
 \G mark a region as mirrored    >rdp @ ;
   
   : 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 1319  Variable mirrored-link          \ linked Line 1371  Variable mirrored-link          \ linked
 0 0 region address-space  0 0 region address-space
 \ total memory addressed and used by the target system  \ total memory addressed and used by the target system
   
   0 0 region user-region
   \ data for user variables goes here
   \ this has to be defined before dictionary or ram-dictionary
   
 0 0 region dictionary  0 0 region dictionary
 \ rom area for the compiler  \ rom area for the compiler
   
Line 1338  T has? rom H Line 1394  T has? rom H
   
 ' dictionary ALIAS rom-dictionary  ' dictionary ALIAS rom-dictionary
   
   : setup-region ( region -- )
     >r
     \ allocate mem
     r@ >rlen @ allocatetarget
     r@ >rmem !
   
     r@ >rlen @
     target>bitmask-size allocatetarget
     r@ >rbm !
   
     r@ >rlen @
     tcell / 1+ cells allocatetarget r@ >rtype !
   
     ['] noop r@ >rtouch !
     rdrop ;
   
 : setup-target ( -- )   \G initialize target's memory space  : setup-target ( -- )   \G initialize target's memory space
   s" rom" T $has? H    s" rom" T $has? H
Line 1363  T has? rom H Line 1434  T has? rom H
   WHILE dup    WHILE dup
         0 >rlink - >r          0 >rlink - >r
         r@ >rlen @          r@ >rlen @
         IF      \ allocate mem          IF      r@ setup-region
                 r@ >rlen @ allocatetarget dup image !          THEN    rdrop
                 r@ >rmem !  
   
                 r@ >rlen @  
                 target>bitmask-size allocatetarget  
                 dup bit$ !  
                 r@ >rbm !  
   
                 r@ >rlen @  
                 tcell / 1+ cells allocatetarget r@ >rtype !  
   
                 rdrop  
         ELSE    r> drop THEN  
    REPEAT drop ;     REPEAT drop ;
   
 \ MakeKernel                                                    22feb99jaw  \ MakeKernel                                                    22feb99jaw
   
 : makekernel ( targetsize -- )  : makekernel ( start targetsize -- )
 \G convenience word to setup the memory of the target  \G convenience word to setup the memory of the target
 \G used by main.fs of the c-engine based systems  \G used by main.fs of the c-engine based systems
   100 swap dictionary (region)    dictionary (region) setup-target ;
   setup-target ;  
   
 >MINIMAL  >MINIMAL
 : makekernel makekernel ;  : makekernel makekernel ;
Line 1410  variable sromdp  \ start of rom-area for Line 1468  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 1485  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 1513  bigendian Line 1571  bigendian
         0 >rlink - >r          0 >rlink - >r
         r@ >rlen @          r@ >rlen @
         IF      dup r@ borders within          IF      dup r@ borders within
                 IF r> r> drop nip EXIT THEN                  IF r> r> drop nip 
                      dup >rtouch @ EXECUTE EXIT 
                   THEN
         THEN          THEN
         r> drop          r> drop
         r>          r>
Line 1521  bigendian Line 1581  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 1598  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 1581  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1655  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
   [ [THEN] ]    [ [THEN] ]
   (>regionbm) swap cell/ -bit ;    (>regionbm) swap cell/ -bit ;
   
 : (>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 1666  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 1700  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 1721  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)   Ghost (-loop)   2drop drop
   Ghost (next)                                    drop
   Ghost !does                                     drop
   Ghost compile,                                  drop
   Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
   Ghost (C")      Ghost c(abort") Ghost type      2drop drop
   Ghost '                                         drop
   
   \ user ghosts
   
   Ghost state drop
   
 \ \ --------------------        Host/Target copy etc.           29aug01jaw  \ \ --------------------        Host/Target copy etc.           29aug01jaw
   
Line 1657  T has? relocate H Line 1758  T has? relocate H
   swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ;    swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ;
   
 2Variable last-string  2Variable last-string
   X has? rom [IF] $60 [ELSE] $00 [THEN] Constant header-masks
   
   : ht-header,  ( addr count -- )
     dup there swap last-string 2!
       dup header-masks or T c, H bounds  ?DO  I c@ T c, H  LOOP ;
 : ht-string,  ( addr count -- )  : ht-string,  ( addr count -- )
   dup there swap last-string 2!    dup there swap last-string 2!
   dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;       dup T c, H bounds  ?DO  I c@ T c, H  LOOP ;
   : ht-mem, ( addr count )
       bounds ?DO  I c@  T c, H  LOOP ;
   
 >TARGET  >TARGET
   
 : count dup X c@ swap X char+ swap ;  : count dup X c@ swap X char+ swap ;
   
 : on            -1 -1 rot TD!  ;   : on            >r -1 -1 r> TD!  ; 
 : off           T 0 swap ! H ;  : off           T 0 swap ! H ;
   
 : tcmove ( source dest len -- )  : tcmove ( source dest len -- )
Line 1675  T has? relocate H Line 1782  T has? relocate H
   ?DO  dup T c@ H I T c! H 1+    ?DO  dup T c@ H I T c! H 1+
   tchar +LOOP  drop ;    tchar +LOOP  drop ;
   
   : tcallot ( char size -- )
       0 ?DO  dup T c, H  tchar +LOOP  drop ;
   
 : td, ( d -- )  : td, ( d -- )
 \G Store a host value as one cell into the target  \G Store a host value as one cell into the target
   there tcell X allot TD! ;    there tcell X allot TD! ;
Line 1695  previous Line 1805  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 1818  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 1844  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 1903  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 1982  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 1903  variable ResolveFlag Line 2041  variable ResolveFlag
 \ Header states                                        12dec92py  \ Header states                                        12dec92py
   
 \ : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;  \ : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
 bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+  X has? f83headerstring bigendian or [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+
 : flag! ( w -- )   tlast @ flag+ + dup >r T c@ xor r> c! H ;  : flag! ( w -- )   tlast @ flag+ + dup >r T c@ xor r> c! H ;
   
 VARIABLE ^imm  VARIABLE ^imm
Line 1932  $20 constant restrict-mask Line 2070  $20 constant restrict-mask
   dup T , H bounds  ?DO  I c@ T c, H  LOOP ;    dup T , H bounds  ?DO  I c@ T c, H  LOOP ;
   
 >TARGET  >TARGET
   X has? f83headerstring [IF]
   : name,  ( "name" -- )  bl word count ht-header, X cfalign ;
   [ELSE]
 : name,  ( "name" -- )  bl word count ht-lstring, X cfalign ;  : name,  ( "name" -- )  bl word count ht-lstring, X cfalign ;
   [THEN]
 : view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;
 >CROSS  >CROSS
   
Line 1969  s" kernel.TAGS" r/w create-file throw va Line 2111  s" kernel.TAGS" r/w create-file throw va
 s" kernel.tags" r/w create-file throw value vi-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 1 c,  7F c,
 Create tag-end 2 c,  bl c, 01 c,  Create tag-end 1 c,  01 c,
 Create tag-bof 1 c,  0C c,  Create tag-bof 1 c,  0C c,
 Create tag-tab 1 c,  09 c,  Create tag-tab 1 c,  09 c,
   
Line 1986  Create tag-tab 1 c,  09 c, Line 2128  Create tag-tab 1 c,  09 c,
         s" ,0" tag-file-id write-line throw          s" ,0" tag-file-id write-line throw
     THEN ;      THEN ;
   
 : cross-gnu-tag-entry  ( -- )  : put-cross-gnu-tag-entry  ( addr u -- )
     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
         Last-Header-Ghost @ >ghostname tag-file-id write-file throw          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
         s" ,0" tag-file-id write-line throw          s" ,0" tag-file-id write-line throw
         base !          base !
     THEN ;      ELSE  2drop  THEN ;
   
 : cross-vi-tag-entry ( -- )  : cross-gnu-tag-entry  ( -- )
       Last-Header-Ghost @ >ghostname put-cross-gnu-tag-entry ;
   
   : put-cross-vi-tag-entry ( addr u -- )
     tlast @ 0<> \ not an anonymous (i.e. noname) header      tlast @ 0<> \ not an anonymous (i.e. noname) header
     IF      IF
         sourcefilename vi-tag-file-id write-file throw          sourcefilename vi-tag-file-id write-file throw
         tag-tab count 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          vi-tag-file-id write-file throw
         tag-tab count 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          s" /^" vi-tag-file-id write-file throw
         source vi-tag-file-id write-file throw          source vi-tag-file-id write-file throw
         s" $/" vi-tag-file-id write-line throw          s" $/" vi-tag-file-id write-line throw
     THEN ;      ELSE  2drop  THEN ;
   
   : cross-vi-tag-entry ( -- )
       Last-Header-Ghost @ >ghostname put-cross-vi-tag-entry ;
   
 : cross-tag-entry ( -- )  : cross-tag-entry ( -- )
     cross-gnu-tag-entry      cross-gnu-tag-entry
     cross-vi-tag-entry ;      cross-vi-tag-entry ;
   
   : put-cross-tag-entry ( addr u -- )
       2dup put-cross-gnu-tag-entry
       put-cross-vi-tag-entry ;
   
   : cross-record-name ( -- )
       >in @ parse-name put-cross-tag-entry >in ! ;
   
 \ Check for words  \ Check for words
   
 Defer skip? ' false IS skip?  Defer skip? ' false IS skip?
Line 2050  Defer skip? ' false IS skip? Line 2205  Defer skip? ' false IS skip?
         0=          0=
     ELSE  drop true  THEN ;      ELSE  drop true  THEN ;
   
 : doer? ( -- flag ) \ name  : doer? ( "name" -- 0 | addr ) \ name
     Ghost >magic @ <do:> = ;      Ghost dup >magic @ <do:> = 
       IF >link @ ELSE drop 0 THEN ;
   
 : skip-defs ( -- )  : skip-defs ( -- )
     BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;      BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;
Line 2076  NoHeaderFlag off Line 2232  NoHeaderFlag off
         ENDCASE          ENDCASE
     LOOP ;      LOOP ;
   
 Defer setup-execution-semantics  Defer setup-execution-semantics  ' noop IS setup-execution-semantics
 0 Value lastghost  0 Value lastghost
   
 : (THeader ( "name" -- ghost )  : (THeader ( "name" -- ghost )
Line 2097  Defer setup-execution-semantics Line 2253  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 2309  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# ! ;
   : group 0 word drop prim# @ 1- -$200 and prim# ! ;
   : groupadd  ( n -- )  drop ;
 : Primitive  ( -- ) \ name  : Primitive  ( -- ) \ name
   >in @ skip? IF  drop  EXIT  THEN  >in !    >in @ skip? IF  drop  EXIT  THEN  >in !
   s" prims" T $has? H 0=    s" prims" T $has? H 0=
Line 2177  Variable prim# Line 2332  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!    s" EC" T $has? H 0=
     IF
         over resolve-noforwards T A, H
         alias-mask flag!
     ELSE
         T here H resolve-noforwards T A, H
     THEN
   -1 prim# +! ;    -1 prim# +! ;
 >CROSS  >CROSS
   
Line 2258  T 2 cells H Value xt>body Line 2420  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 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  
   \ does-address to marked for relocation  
   [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]  
   2 fillcfa ;                                           ' (dodoes,) plugin-of dodoes,    2 fillcfa ;                                           ' (dodoes,) plugin-of dodoes,
   
 : (dlit,) ( n -- ) compile lit td, ;                    ' (dlit,) plugin-of dlit,  : (dlit,) ( n -- ) compile lit td, ;                    ' (dlit,) plugin-of dlit,
Line 2296  Defer (end-code) Line 2457  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 2326  Cond: ALiteral ( n -- )   alit, ;Cond Line 2496  Cond: ALiteral ( n -- )   alit, ;Cond
 : Char ( "<char>" -- )  bl word char+ c@ ;  : Char ( "<char>" -- )  bl word char+ c@ ;
 Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond  Cond: [Char]   ( "<char>" -- )  Char  lit, ;Cond
   
   : (x#) ( adr len base -- )
     base @ >r base ! 0 0 name >number 2drop drop r> base ! ;
   
   : d# $0a (x#) ;
   : h# $010 (x#) ;
   
   Cond: d# $0a (x#) lit, ;Cond
   Cond: h# $010 (x#) lit, ;Cond
   
 tchar 1 = [IF]  tchar 1 = [IF]
 Cond: chars ;Cond   Cond: chars ;Cond 
 [THEN]  [THEN]
   
 \ 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 2380  Cond: MAXI Line 2548  Cond: MAXI
         IF   nip execute-exec-compile ELSE gexecute  THEN           IF   nip execute-exec-compile ELSE gexecute  THEN 
         EXIT           EXIT 
   THEN    THEN
   number? dup      (number?) dup  
   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  ;
   
Line 2432  Cond: MAXI Line 2600  Cond: MAXI
   (THeader (:) ;    (THeader (:) ;
   
 : :noname ( -- colon-sys )  : :noname ( -- colon-sys )
   X cfalign there     switchrom X cfalign there 
   \ define a nameless ghost    \ define a nameless ghost
   here ghostheader dup last-header-ghost ! dup to lastghost    here ghostheader dup last-header-ghost ! dup to lastghost
   (:) ;      (:) ;  
Line 2458  Cond: ; ( -- ) Line 2626  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 2641  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  ' noop IS instant-interpret-does>-hook
   
   T has? primcentric H [IF]
   : does-resolved ( ghost -- )
   \    g>xt dup T >body H alit, compile call T cell+ @ a, H ;
       compile does-exec g>xt T a, H ;
   [ELSE]
   : does-resolved ( ghost -- )
       g>xt T a, H ;
   [THEN]
   
 : resolve-does>-part ( -- )  : resolve-does>-part ( -- )
 \ resolve words made by builders  \ resolve words made by builders
Line 2485  Defer instant-interpret-does>-hook Line 2663  Defer instant-interpret-does>-hook
   
 >TARGET  >TARGET
 Cond: DOES>  Cond: DOES>
         compile (does>) doeshandler,          T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells
         resolve-does>-part          H + alit, compile !does compile ;s
           doeshandler, 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 2718  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 2739  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 2760  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 2655  by Create Line 2847  by Create
   
 \ User variables                                       04may94py  \ User variables                                       04may94py
   
 Variable tup  0 tup !  : tup@ user-region >rstart @ ;
 Variable tudp 0 tudp !  
   \ Variable tup  0 tup !
   \ Variable tudp 0 tudp !
   
 : u,  ( n -- udp )  : u,  ( n -- udp )
   tup @ tudp @ + T  ! H    current-region >r user-region activate
   tudp @ dup T cell+ H tudp ! ;    X here swap X , tup@ -
     r> activate ;
   
 : au, ( n -- udp )  : au, ( n -- udp )
   tup @ tudp @ + T A! H    current-region >r user-region activate
   tudp @ dup T cell+ H tudp ! ;    X here swap X a, tup@ - 
     r> activate ;
   
   T has? no-userspace H [IF]
   
   : buildby
     ghost >exec @ built >exec ! ;
   
   Builder User
   buildby Variable
   by Variable
   
   Builder 2User
   buildby 2Variable
   by 2Variable
   
   Builder AUser
   buildby AVariable
   by AVariable
   
   [ELSE]
   
 Builder User  Builder User
 Build: 0 u, X , ;Build  Build: 0 u, X , ;Build
 by: :douser ( ghost -- up-addr )  X @ tup @ + ;DO  by: :douser ( ghost -- up-addr )  X @ tup@ + ;DO
   
 Builder 2User  Builder 2User
 Build: 0 u, X , 0 u, drop ;Build  Build: 0 u, X , 0 u, drop ;Build
Line 2678  Builder AUser Line 2893  Builder AUser
 Build: 0 au, X , ;Build  Build: 0 au, X , ;Build
 by User  by User
   
   [THEN]
   
   T has? rom H [IF]
 Builder (Value)  Builder (Value)
 Build:  ( n -- ) ;Build  Build:  ( n -- ) ;Build
 by: :docon ( target-body-addr -- n ) T @ H ;DO  by: :dovalue ( target-body-addr -- n ) T @ @ H ;DO
   
   Builder Value
   Build: T here 0 A, H switchram T align here swap ! , H ;Build
   by (Value)
   
   Builder AValue
   Build: T here 0 A, H switchram T align here swap ! A, H ;Build
   by (Value)
   [ELSE]
   Builder (Value)
   Build:  ( n -- ) ;Build
   by: :dovalue ( target-body-addr -- n ) T @ H ;DO
   
 Builder Value  Builder Value
 BuildSmart: T , H ;Build  BuildSmart: T , H ;Build
Line 2689  by (Value) Line 2919  by (Value)
 Builder AValue  Builder AValue
 BuildSmart: T A, H ;Build  BuildSmart: T A, H ;Build
 by (Value)  by (Value)
   [THEN]
   
 Defer texecute  Defer texecute
   
 Builder Defer  Builder Defer
 BuildSmart:  ( -- ) [T'] noop T A, H ;Build  T has? rom H [IF]
 by: :dodefer ( ghost -- ) X @ texecute ;DO      Build: ( -- )  T here 0 A, H switchram T align here swap ! H [T'] noop T A, H ( switchrom ) ;Build
       by: :dodefer ( ghost -- ) X @ X @ texecute ;DO
   [ELSE]
       BuildSmart:  ( -- ) [T'] noop T A, H ;Build
       by: :dodefer ( ghost -- ) X @ texecute ;DO
   [THEN]
   
 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 2725  by (Field) Line 2961  by (Field)
     T 1 cells H dup ;      T 1 cells H dup ;
 >CROSS  >CROSS
   
   \ ABI-CODE support
   Builder (ABI-CODE)
   Build: ;Build
   by: :doabicode noop ;DO
   
   BUILDER (;abi-code)
   Build: ;Build
   by: :do;abicode noop ;DO
   
 \ Input-Methods                                            01py  \ Input-Methods                                            01py
   
 Builder input-method  Builder input-method
Line 2735  Builder input-var Line 2980  Builder input-var
 Build: ( m v size -- m v' )  over T , H + ;Build  Build: ( m v size -- m v' )  over T , H + ;Build
 DO:  abort" Not in cross mode" ;DO  DO:  abort" Not in cross mode" ;DO
   
   \ Mini-OOF
   
   Builder method
   Build: ( m v -- m' v )  over T , swap cell+ swap H ;Build
   DO:  abort" Not in cross mode" ;DO
   
   Builder var
   Build: ( m v size -- m v+size )  over T , H + ;Build
   DO: ( o -- addr ) T @ H + ;DO
   
   Builder end-class
   Build: ( addr m v -- )
      T here >r , dup , 2 cells H ?DO T ['] noop , 1 cells H +LOOP
      T cell+ dup cell+ r> rot @ 2 cells /string move H ;Build
   by Create
   
   : class ( class -- class methods vars ) dup T 2@ H ;
   : defines ( xt class -- )  T ' >body @ + ! H ;
   
 \ Peephole optimization                                 05sep01jaw  \ Peephole optimization                                 05sep01jaw
   
 \ 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
 \ optimizer for cross  \ optimizer for cross
   
   
 T has? peephole H [IF]  T has? primcentric H [IF]
   
   \ .( loading peephole optimization) cr
   
 >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,  T has? ec H [IF]
   : (pprim) T @ H >signed 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,
   [ELSE]
   : (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,
   [THEN]
   
 \ 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 3039  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 3052  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 here H reloff T , H ;compile
   
 Builder interpret/compile:  Builder interpret/compile:
 compile: does-resolved ;compile  compile: does-resolved ;compile
Line 2805  compile: does-resolved ;compile Line 3082  compile: does-resolved ;compile
 \ : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;  \ : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
 \ : sys?        ( sys -- sys )    dup 0= ?struc ;  \ : sys?        ( sys -- sys )    dup 0= ?struc ;
   
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  : >mark       ( -- sys )        T here  0 , H ;
   
 : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw  X has? abranch [IF]
       : branchoffset ( src dest -- )  drop ;
 : >resolve    ( sys -- )              : offset, ( n -- )  X A, ;
         X here ( dup ." >" hex. ) over branchoffset swap X ! ;  [ELSE]
       : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
 : <resolve    ( sys -- )      : offset, ( n -- )  X , ;
         X here ( dup ." <" hex. ) branchoffset X , ;  [THEN]
   
 :noname compile branch X here branchoffset X , ;  :noname compile branch X here branchoffset offset, ;
   IS branch, ( target-addr -- )    IS branch, ( target-addr -- )
 :noname compile ?branch X here branchoffset X , ;  :noname compile ?branch X here branchoffset offset, ;
   IS ?branch, ( target-addr -- )    IS ?branch, ( target-addr -- )
 :noname compile branch T here 0 , H ;  :noname compile branch T here 0 H offset, ;
   IS branchmark, ( -- branchtoken )    IS branchmark, ( -- branchtoken )
 :noname compile ?branch T here 0 , H ;  :noname compile ?branch T here 0 H offset, ;
   IS ?branchmark, ( -- branchtoken )    IS ?branchmark, ( -- branchtoken )
 :noname T here 0 , H ;  :noname T here 0 H offset, ;
   IS ?domark, ( -- branchtoken )    IS ?domark, ( -- branchtoken )
 :noname dup X @ ?struc X here over branchoffset swap X ! ;  :noname dup X @ ?struc X here over branchoffset swap X ! ;
   IS branchtoresolve, ( branchtoken -- )    IS branchtoresolve, ( branchtoken -- )
Line 2841  compile: does-resolved ;compile Line 3118  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 3171  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 offset, 
     tcell - (done) ;
   
 : skiploop] ?dup IF branchto, branchtoresolve, THEN ;  : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
   
Line 2984  Cond: ENDCASE   endcase, ;Cond Line 3267  Cond: ENDCASE   endcase, ;Cond
   1to compile (+loop)  loop]     1to compile (+loop)  loop] 
   compile unloop skiploop] ;                    ' (+loop,) plugin-of +loop,    compile unloop skiploop] ;                    ' (+loop,) plugin-of +loop,
   
   : (-loop,) ( target-addr -- )
     1to compile (-loop)  loop] 
     compile unloop skiploop] ;                    ' (-loop,) plugin-of -loop,
   
 : (next,)   : (next,) 
   compile (next)  loop] compile unloop ;        ' (next,) plugin-of next,    compile (next)  loop] compile unloop ;        ' (next,) plugin-of next,
   
Line 2993  Cond: FOR for, ;Cond Line 3280  Cond: FOR for, ;Cond
   
 Cond: LOOP      1 ncontrols? loop, ;Cond  Cond: LOOP      1 ncontrols? loop, ;Cond
 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
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
   
 : ,"            [char] " parse ht-string, X align ;  : ,"            [char] " parse ht-string, X align ;
   
   X has? control-rack [IF]
 Cond: ."        compile (.")     T ," H ;Cond  Cond: ."        compile (.")     T ," H ;Cond
 Cond: S"        compile (S")     T ," H ;Cond  Cond: S"        compile (S")     T ," H ;Cond
 Cond: C"        compile (C")     T ," H ;Cond  Cond: C"        compile (C")     T ," H ;Cond
 Cond: ABORT"    compile (ABORT") T ," H ;Cond  Cond: ABORT"    compile (ABORT") T ," H ;Cond
   [ELSE]
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: ."        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
 : IS            T >address ' >body ! H ;                  >r then, r> compile ALiteral compile Literal compile type ;Cond
   Cond: S"        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
                   >r then, r> compile ALiteral compile Literal ;Cond
   Cond: C"        ahead, there [char] " parse ht-string, X align
                   >r then, r> compile ALiteral ;Cond
   Cond: ABORT"    if, ahead, there [char] " parse ht-string, X align
                   >r then, r> compile ALiteral compile c(abort") then, ;Cond
   [THEN]
   
   X has? rom [IF]
   Cond: IS        cross-record-name T ' >body @ H compile ALiteral compile ! ;Cond
   : IS            cross-record-name T >address ' >body @ ! H ;
   Cond: TO        T ' >body @ H compile ALiteral compile ! ;Cond
   : TO            T ' >body @ ! H ;
   Cond: CTO       T ' >body H compile ALiteral compile ! ;Cond
   : CTO           T ' >body ! H ;
   [ELSE]
   Cond: IS        cross-record-name T ' >body H compile ALiteral compile ! ;Cond
   : IS            cross-record-name T >address ' >body ! H ;
 Cond: TO        T ' >body H compile ALiteral compile ! ;Cond  Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
 : TO            T ' >body ! H ;  : TO            T ' >body ! H ;
   [THEN]
   
 Cond: defers    T ' >body @ compile, H ;Cond  Cond: defers    T ' >body @ compile, H ;Cond
   
Line 3040  Cond: postpone ( -- ) \ name Line 3348  Cond: postpone ( -- ) \ name
       ABORT" CROSS: Can't postpone on forward declaration"        ABORT" CROSS: Can't postpone on forward declaration"
       dup >magic @ <imm> =        dup >magic @ <imm> =
       IF   (gexecute)        IF   (gexecute)
       ELSE compile (compile) addr, THEN ;Cond        ELSE >link @ alit, compile compile,  THEN ;Cond
                         
 \ save-cross                                           17mar93py  \ save-cross                                           17mar93py
   
 hex  hex
   
 >CROSS  >CROSS
 Create magic  s" Gforth2x" here over allot swap move  Create magic  s" Gforth4x" here over allot swap move
   
 bigendian 1+ \ strangely, in magic big=0, little=1  bigendian 1+ \ strangely, in magic big=0, little=1
 tcell 1 = 0 and or  tcell 1 = 0 and or
Line 3061  tchar 8 = 78 and or Line 3369  tchar 8 = 78 and or
 magic 7 + c!  magic 7 + c!
   
 : save-cross ( "image-name" "binary-name" -- )  : save-cross ( "image-name" "binary-name" -- )
     .regions \  s" ec" X $has? IF  .regions  THEN
   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
   s" header" X $has? IF    s" header" X $has? IF
Line 3077  magic 7 + c! Line 3386  magic 7 + c!
   ELSE    ELSE
       bl parse 2drop        bl parse 2drop
   THEN    THEN
   image @ there     >rom dictionary >rmem @ there
     s" rom" X $has? IF  dictionary >rstart @ -  THEN
   r@ write-file throw \ write image    r@ write-file throw \ write image
   s" relocate" X $has? IF    s" relocate" X $has? IF
       bit$  @ there 1- tcell>bit rshift 1+        dictionary >rbm @ there 1- tcell>bit rshift 1+
                 r@ write-file throw \ write tags                  r@ write-file throw \ write tags
   THEN    THEN
   r> close-file throw ;    r> close-file throw ;
Line 3236  Variable outfile-fd Line 3546  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 3633  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 3691  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 3699  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 3464  previous Line 3782  previous
 : * * ;  : * * ;
 : / / ;  : / / ;
 : dup dup ;  : dup dup ;
   : ?dup ?dup ;
 : over over ;  : over over ;
 : swap swap ;  : swap swap ;
 : rot rot ;  : rot rot ;
 : drop drop ;  : drop drop ;
   : 2drop 2drop ;
 : =   = ;  : =   = ;
   : <>  <> ;
 : 0=   0= ;  : 0=   0= ;
 : lshift lshift ;  : lshift lshift ;
 : 2/ 2/ ;  : 2/ 2/ ;
   : hex. base @ $10 base ! swap . base ! ;
   : invert invert ;
   : linkstring ( addr u n addr -- )
       X here over X @ X , swap X ! X , ht-string, X align ;
 \ : . . ;  \ : . . ;
   
 : all-words    ['] forced?    IS skip? ;  : all-words    ['] forced?    IS skip? ;
Line 3487  previous Line 3812  previous
 : require require ;  : require require ;
 : needs require ;  : needs require ;
 : .( [char] ) parse type ;  : .( [char] ) parse type ;
   : ERROR" [char] " parse 
     rot 
     IF cr ." *** " type ."  ***" -1 ABORT" CROSS: Target error, see text above" 
     ELSE 2drop 
     THEN ;
 : ." [char] " parse type ;  : ." [char] " parse type ;
 : cr cr ;  : cr cr ;
   
Line 3506  previous Line 3836  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 3853  previous
 \ : words       also ghosts   \ : words       also ghosts 
 \                words previous ;  \                words previous ;
 : .s            .s ;  : .s            .s ;
   : depth         depth ;
 : bye           bye ;  : bye           bye ;
   
 \ dummy  \ dummy
 : group 0 word drop ;  
   
 \ turnkey direction  \ turnkey direction
 : H forth ; immediate  : H forth ; immediate

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


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