Diff for /gforth/cross.fs between versions 1.121 and 1.153

version 1.121, 2002/03/19 18:07:55 version 1.153, 2006/02/18 13:12: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 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 27  ToDo: Line 27  ToDo:
   cross.fs is used seperately. jaw    cross.fs is used seperately. jaw
 - Do we need this char translation with >address and in branchoffset?   - Do we need this char translation with >address and in branchoffset? 
   (>body also affected) jaw    (>body also affected) jaw
 - MAXU etc. can be done with dlit,  
   
 [THEN]  [THEN]
   
   s" compat/strcomp.fs" included
   
 hex  hex
   
 \ debugging for compiling  \ debugging for compiling
Line 71  H Line 72  H
   
 >CROSS  >CROSS
   
   \ Test against this definitions to find out whether we are cross-compiling
   \ may be usefull for assemblers
   0 Constant gforth-cross-indicator
   
 \ find out whether we are compiling with gforth  \ find out whether we are compiling with gforth
   
 : defined? bl word find nip ;  : defined? bl word find nip ;
Line 256  hex Line 261  hex
   
 \ FIXME move down  \ 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 ( -- <name> )  : X ( -- <name> )
Line 315  set-order previous Line 320  set-order previous
         \ POSTPONE false           \ POSTPONE false 
   THEN ; immediate    THEN ; immediate
   
   : symentry ( adr len taddr -- )
   \G Produce a symbol table (an optional symbol address
   \G map) if wanted
       [ [IFDEF] fd-symbol-table ]
         base @ swap hex s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
         s" :" fd-symbol-table write-file throw
         fd-symbol-table write-line throw
       [ [ELSE] ]
         2drop drop
       [ [THEN] ] ;
   
   
 \ \ --------------------        source file  \ \ --------------------        source file
   
 decimal  decimal
Line 430  sourcepath value fpath Line 447  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 439  sourcepath value fpath Line 456  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 459  sourcepath value fpath Line 476  sourcepath value fpath
     2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....      2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
     over c@ [char] / = >r      over c@ [char] / = >r
     over c@ [char] ~ = >r      over c@ [char] ~ = >r
     \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic      \ 2dup S" ../" string-prefix? r> or >r \ not catered for in expandtopic
     2 min S" ./" compare 0=      S" ./" string-prefix?
     r> r> r> or or or ;      r> r> r> or or or ;
   
 Create ofile 0 c, 255 chars allot  Create ofile 0 c, 255 chars allot
Line 476  Create tfile 0 c, 255 chars allot Line 493  Create tfile 0 c, 255 chars allot
   REPEAT ;    REPEAT ;
   
 : remove~+ ( -- )  : remove~+ ( -- )
     ofile count 3 min s" ~+/" compare 0=      ofile count s" ~+/" string-prefix?
     IF      IF
         ofile count 3 /string ofile place          ofile count 3 /string ofile place
     THEN ;      THEN ;
   
 : expandtopic ( -- ) \ stack effect correct? - anton  : expandtopic ( -- ) \ stack effect correct? - anton
     \ expands "./" into an absolute name      \ expands "./" into an absolute name
     ofile count 2 min s" ./" compare 0=      ofile count s" ./" string-prefix?
     IF      IF
         ofile count 1 /string tfile place          ofile count 1 /string tfile place
         0 ofile c! sourcefilename extractpath ofile place          0 ofile c! sourcefilename extractpath ofile place
Line 496  Create tfile 0 c, 255 chars allot Line 513  Create tfile 0 c, 255 chars allot
     \ deletes phrases like "xy/.." out of our directory name 2dec97jaw      \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
     over swap      over swap
     BEGIN  dup  WHILE      BEGIN  dup  WHILE
         dup >r '/ scan 2dup 4 min s" /../" compare 0=          dup >r '/ scan 2dup s" /../" string-prefix?
         IF          IF
             dup r> - >r 4 /string over r> + 4 -              dup r> - >r 4 /string over r> + 4 -
             swap 2dup + >r move dup r> over -              swap 2dup + >r move dup r> over -
Line 529  Create tfile 0 c, 255 chars allot Line 546  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 559  fpath= ~+ Line 576  fpath= ~+
 : included? ( c-addr u -- f )  : included? ( c-addr u -- f )
   file-list    file-list
   BEGIN @ dup    BEGIN @ dup
   WHILE >r 2dup r@ >fl-name count compare 0=    WHILE >r 2dup r@ >fl-name count str=
         IF rdrop 2drop true EXIT THEN          IF rdrop 2drop true EXIT THEN
         r>          r>
   REPEAT    REPEAT
Line 645  stack-warn [IF] Line 662  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 1157  false DefaultValue header Line 1175  false DefaultValue header
 false DefaultValue backtrace  false DefaultValue backtrace
 false DefaultValue new-input  false DefaultValue new-input
 false DefaultValue peephole  false DefaultValue peephole
   false DefaultValue abranch
   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
 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 1218  tbits/char bits/byte / Constant tbyte Line 1245  tbits/char bits/byte / Constant tbyte
   
 \ 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 1243  Variable region-link            \ linked Line 1269  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 1258  Variable mirrored-link          \ linked Line 1285  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 1267  Variable mirrored-link          \ linked Line 1296  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 1285  Variable mirrored-link          \ linked Line 1316  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 1326  Variable mirrored-link          \ linked Line 1364  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 1345  T has? rom H Line 1387  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 1370  T has? rom H Line 1427  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 1417  variable sromdp  \ start of rom-area for Line 1461  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 1434  variable constflag constflag off Line 1478  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 1520  bigendian Line 1564  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 1528  bigendian Line 1574  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 1543  bigendian Line 1591  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 1588  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1648  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 1600  T has? relocate H Line 1659  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 1623  T has? relocate H Line 1693  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 1652  Ghost (do)      Ghost (?do) Line 1722  Ghost (do)      Ghost (?do)
 Ghost (for)                                     drop  Ghost (for)                                     drop
 Ghost (loop)    Ghost (+loop)                   2drop  Ghost (loop)    Ghost (+loop)                   2drop
 Ghost (next)                                    drop  Ghost (next)                                    drop
 Ghost (does>)   Ghost (compile)                 2drop  Ghost (does>)   Ghost (does>1)  Ghost (does>2)  2drop 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
   
 \ user ghosts  \ user ghosts
Line 1683  Ghost state drop Line 1754  Ghost state drop
   
 : 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 1830  Defer resolve-warning Line 1903  Defer resolve-warning
   
 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
     \ is ghost resolved?, second resolve means another   
     \ definition with the same name  
     over undefined? 0= IF  exists EXIT THEN  
     \ get linked-list  
     swap >r r@ >link @ swap \ ( list tcfa R: ghost )  
     \ mark ghost as resolved  
     dup r@ >link ! <res> r@ >magic !  
     r@ to resolved      r@ to resolved
   
 \    r@ >comp @ ['] is-forward =  \    r@ >comp @ ['] is-forward =
Line 1858  Defer resolve-warning Line 1934  Defer resolve-warning
     \ if this is not right something must be set before      \ if this is not right something must be set before
     \ calling resolve      \ calling resolve
     r@ >comp @ ['] is-forward = IF      r@ >comp @ ['] is-forward = IF
         ['] colon-resolved r@ >comp !         ['] colon-resolved r@ >comp !
     THEN     THEN
     \ loop through forward referencies      r@ >link @ swap \ ( list tcfa R: ghost )
     r> -rot       \ mark ghost as resolved
     comp-state @ >r Resolving comp-state !      r@ >link ! <res> r@ >magic !
     resolve-loop       r> swap ;
     r> comp-state !  
   
     ['] noop IS resolve-warning   : resolve  ( ghost tcfa -- )
   ;  \G resolve referencies to ghost with tcfa
       \ is ghost resolved?, second resolve means another 
       \ definition with the same name
       over undefined? 0= IF  exists EXIT THEN
       (resolve)
       ( ghost resolve-list )
       resolve-forward-references ;
   
   : resolve-noforwards ( ghost tcfa -- )
   \G Same as resolve but complain if there are any
   \G forward references on this ghost
      \ is ghost resolved?, second resolve means another 
      \ definition with the same name
      over undefined? 0= IF  exists EXIT THEN
      (resolve)
      IF cr ." No forward references allowed on: " .ghost cr
         -1 ABORT" Illegal forward reference"
      THEN
      drop ;
   
 \ gexecute ghost,                                      01nov92py  \ gexecute ghost,                                      01nov92py
   
Line 1934  variable ResolveFlag Line 2027  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 1963  $20 constant restrict-mask Line 2056  $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-string, 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 2000  s" kernel.TAGS" r/w create-file throw va Line 2097  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 2081  Defer skip? ' false IS skip? Line 2178  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 2107  NoHeaderFlag off Line 2205  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 2128  Defer setup-execution-semantics Line 2226  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 2188  Defer setup-prim-semantics Line 2282  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 2198  Defer setup-prim-semantics Line 2292  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 2211  Variable prim# Line 2307  Variable prim#
   prim# @ (THeader ( S xt ghost )    prim# @ (THeader ( S xt ghost )
   ['] prim-resolved over >comp !    ['] prim-resolved over >comp !
   dup >ghost-flags <primitive> set-flag    dup >ghost-flags <primitive> set-flag
   over resolve T A, H alias-mask flag!    over resolve-noforwards T A, H alias-mask flag!
   -1 prim# +! ;    -1 prim# +! ;
 >CROSS  >CROSS
   
Line 2333  Defer (end-code) Line 2429  Defer (end-code)
   defempty?    defempty?
   (THeader ( ghost )    (THeader ( ghost )
   ['] prim-resolved over >comp !    ['] prim-resolved over >comp !
   there resolve    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, 
Line 2345  Defer (end-code) Line 2441  Defer (end-code)
 : Code:  : Code:
   defempty?    defempty?
     Ghost >r       Ghost >r 
     r@ there ca>native resolve        r@ >ghostname there symentry
       r@ there ca>native resolve-noforwards
     <do:> r@ >magic !      <do:> r@ >magic !
     r> drop      r> drop
     depth (code) ;      depth (code) ;
Line 2369  Cond: ALiteral ( n -- )   alit, ;Cond Line 2466  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 2520  Cond: [ ( -- ) interpreting-state ;Cond Line 2615  Cond: [ ( -- ) interpreting-state ;Cond
     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? peephole 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 2532  Defer instant-interpret-does>-hook Line 2632  Defer instant-interpret-does>-hook
   
 >TARGET  >TARGET
 Cond: DOES>  Cond: DOES>
         compile (does>) doeshandler,          T here 5 cells H + alit, compile (does>2) compile ;s
         resolve-does>-part          doeshandler, resolve-does>-part
         ;Cond          ;Cond
   
 : DOES>  : DOES>
Line 2715  by Create Line 2815  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 2738  Builder AUser Line 2861  Builder AUser
 Build: 0 au, X , ;Build  Build: 0 au, X , ;Build
 by User  by User
   
   [THEN]
   
 Builder (Value)  Builder (Value)
 Build:  ( n -- ) ;Build  Build:  ( n -- ) ;Build
 by: :docon ( target-body-addr -- n ) T @ H ;DO  by: :docon ( target-body-addr -- n ) T @ H ;DO
Line 2809  DO:  abort" Not in cross mode" ;DO Line 2934  DO:  abort" Not in cross mode" ;DO
   
 T has? peephole H [IF]  T has? peephole 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,
Line 2871  compile: does-resolved ;compile Line 2998  compile: does-resolved ;compile
   
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 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 2905  compile: does-resolved ;compile Line 3032  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 2955  Cond: ?LEAVE    ?leave, ;Cond Line 3085  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 3063  Cond: NEXT 1 ncontrols? next, ;Cond Line 3196  Cond: NEXT 1 ncontrols? next, ;Cond
   
 : ,"            [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: ."        '" parse tuck 2>r ahead, there 2r> ht-mem, X align
                   >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]
   
 Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
 : IS            T >address ' >body ! H ;  : IS            T >address ' >body ! H ;
Line 3104  Cond: postpone ( -- ) \ name Line 3248  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" Gforth3x" 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 3125  tchar 8 = 78 and or Line 3269  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 3141  magic 7 + c! Line 3286  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 3300  Variable outfile-fd Line 3446  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 3387  Create parsed 20 chars allot \ store wor Line 3533  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 3445  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3591  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 3453  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3599  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 3528  previous Line 3682  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 ;
 \ : . . ;  \ : . . ;
   
 : all-words    ['] forced?    IS skip? ;  : all-words    ['] forced?    IS skip? ;
Line 3551  previous Line 3710  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 3570  previous Line 3734  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 3587  previous Line 3751  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.121  
changed lines
  Added in v.1.153


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