Diff for /gforth/cross.fs between versions 1.119 and 1.181

version 1.119, 2002/01/05 22:58:59 version 1.181, 2012/03/09 21:16:22
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 899  Variable cross-space-dp-orig Line 928  Variable cross-space-dp-orig
   THEN ;    THEN ;
   
 Defer is-forward  Defer is-forward
 Defer do-refered  
   
 : prim-forward   ( ghost -- )  
   colonmark, 0 do-refered ; \ compile space for call  
 : doer-forward   ( ghost -- )  
   colonmark, 2 do-refered ; \ compile space for doer  
 ' prim-forward IS is-forward  
   
 : (ghostheader) ( -- )  : (ghostheader) ( -- )
     ghost-list linked <fwd> , 0 , ['] NoExec , what's 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 1085  Ghost lit-perform drop Line 1107  Ghost lit-perform drop
 Ghost lit+ drop  Ghost lit+ drop
 Ghost does-exec drop  Ghost does-exec drop
   
 ' doer-forward IS is-forward  
   
 Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop  Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
 Ghost :dovar                                    drop  Ghost :dovar                                    drop
   
 ' prim-forward IS is-forward  
   
 \ \ Parameter for target systems                         06oct92py  \ \ Parameter for target systems                         06oct92py
   
   
Line 1159  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 1217  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 1245  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 1260  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 1269  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 1287  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 1328  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 1347  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 1372  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 1419  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 1436  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 1522  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 1530  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 1545  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 1590  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 1602  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 1625  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 1650  T has? relocate H Line 1725  T has? relocate H
   
 >CROSS  >CROSS
   
 : call-forward ( ghost -- )  
     there 0 colon, 0 do-refered ;  
 ' call-forward IS is-forward  
   
 Ghost (do)      Ghost (?do)                     2drop  Ghost (do)      Ghost (?do)                     2drop
 Ghost (for)                                     drop  Ghost (for)                                     drop
 Ghost (loop)    Ghost (+loop)                   2drop  Ghost (loop)    Ghost (+loop)   Ghost (-loop)   2drop drop
 Ghost (next)                                    drop  Ghost (next)                                    drop
 Ghost (does>)   Ghost (compile)                 2drop  Ghost !does                                     drop
   Ghost compile,                                  drop
 Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop  Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
 Ghost (C")                                      drop  Ghost (C")      Ghost c(abort") Ghost type      2drop drop
 Ghost '                                         drop  Ghost '                                         drop
   
 \ ' prim-forward IS is-forward  
   
 \ user ghosts  \ user ghosts
   
 Ghost state drop  Ghost state drop
Line 1688  Ghost state drop Line 1758  Ghost state drop
   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 1706  Ghost state drop Line 1782  Ghost state drop
   ?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 1726  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 colon, tempdp> ;                 ' (cr) plugin-of colon-resolve  : (cr) >tempdp colon, tempdp> ;                 ' (cr) plugin-of colon-resolve
Line 1740  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 1769  previous Line 1846  previous
     space>      space>
 ;  ;
   
 ' (refered) IS do-refered  
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
 \G creates a resolve structure  \G creates a resolve structure
     T here aligned H swap (refered)      T here aligned H swap (refered)
Line 1828  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, ;
   
   : (is-forward)   ( ghost -- )
       colonmark, 0 (refered) ; \ compile space for call
   ' (is-forward) IS is-forward
   
 0 Value resolved  0 Value resolved
   
 : resolve  ( ghost tcfa -- )  : resolve-forward-references ( ghost resolve-list -- )
 \G resolve referencies to ghost with tcfa      \ 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@ to resolved  : resolve-noforwards ( ghost tcfa -- )
     r@ >comp @ ['] prim-forward = IF  \G Same as resolve but complain if there are any
         ['] prim-resolved  r@ >comp !  THEN  \G forward references on this ghost
     r@ >comp @ what's is-forward = IF     \ is ghost resolved?, second resolve means another 
         ['] prim-resolved  r@ >comp !  THEN     \ definition with the same name
     \ loop through forward referencies     over undefined? 0= IF  exists EXIT THEN
     r> -rot      (resolve)
     comp-state @ >r Resolving comp-state !     IF cr ." No forward references allowed on: " .ghost cr
     resolve-loop         -1 ABORT" Illegal forward reference"
     r> comp-state !     THEN
      drop ;
     ['] noop IS resolve-warning   
   ;  
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
Line 1874  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 1933  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 1962  $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 1999  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 2016  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 2080  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 2106  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 2127  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 2187  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, ;
   
 : Doer:   ( cfa -- ) \ name  : Doer:   ( cfa -- ) \ name
Line 2197  Defer setup-prim-semantics Line 2319  Defer setup-prim-semantics
       .sourcepos ." needs doer: " >in @ bl word count type >in ! cr        .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
   THEN    THEN
   Ghost    Ghost
   tuck swap resolve <do:> swap >magic ! ;    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 2208  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 2289  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 [G'] :doesjump addr, T 0 , H ;            ' (doeshandler,) plugin-of doeshandler,      T H ;                                       ' (doeshandler,) plugin-of doeshandler,
   
 : (dodoes,) ( does-action-ghost -- )  : (dodoes,) ( does-action-ghost -- )
   ]comp [G'] :dodoes addr, 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 2327  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 2357  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 2411  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 2463  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 2504  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 -- )  : does-resolved ( ghost -- )
     compile does-exec g>xt T 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 2519  Defer instant-interpret-does>-hook Line 2662  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>  : DOES>
Line 2702  by Create Line 2846  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 2725  Builder AUser Line 2892  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 2736  by (Value) Line 2918  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 A, A, H ;Build-immediate  Build: ( inter comp -- ) swap T A, A, H ;Build-immediate
Line 2772  by (Field) Line 2960  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 2782  Builder input-var Line 2979  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,
   : (callcm) T here 0 a, 0 a, H ;                 ' (callcm) plugin-of colonmark,
 : (call-res) >tempdp resolved gexecute tempdp> drop ;  : (call-res) >tempdp resolved gexecute tempdp> drop ;
                                                 ' (call-res) plugin-of colon-resolve                                                  ' (call-res) plugin-of colon-resolve
 : (prim) dup 0< IF  $4000 -  ELSE  T has? ec H [IF]
     ." wrong usage of (prim) "  : (pprim) T @ H >signed dup 0< IF  $4000 -  ELSE
     dup gdiscover IF  .ghost  ELSE  .  THEN  cr -2 throw  THEN      cr ." wrong usage of (prim) "
     T a, H ;                                    ' (prim) plugin-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 2828  Builder Defer Line 3054  Builder Defer
 compile: g>body compile lit-perform T A, H ;compile  compile: g>body compile lit-perform T A, H ;compile
   
 Builder (Field)  Builder (Field)
 compile: g>body T @ H compile lit+ T , H ;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 2855  compile: does-resolved ;compile Line 3081  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  
   
 : >resolve    ( sys -- )          
         X here ( dup ." >" hex. ) over branchoffset swap X ! ;  
   
 : <resolve    ( sys -- )  X has? abranch [IF]
         X here ( dup ." <" hex. ) branchoffset X , ;      : branchoffset ( src dest -- )  drop ;
       : offset, ( n -- )  X A, ;
   [ELSE]
       : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw
       : offset, ( n -- )  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 2891  compile: does-resolved ;compile Line 3117  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 2941  Cond: ?LEAVE    ?leave, ;Cond Line 3170  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 3034  Cond: ENDCASE   endcase, ;Cond Line 3266  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 3043  Cond: FOR for, ;Cond Line 3279  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 3090  Cond: postpone ( -- ) \ name Line 3347  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 3111  tchar 8 = 78 and or Line 3368  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 3127  magic 7 + c! Line 3385  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 3286  Variable outfile-fd Line 3545  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 3373  Create parsed 20 chars allot \ store wor Line 3632  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 3431  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3690  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 3439  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3698  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 3514  previous Line 3781  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 3537  previous Line 3811  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 3556  previous Line 3835  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 3573  previous Line 3852  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.119  
changed lines
  Added in v.1.181


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