Diff for /gforth/cross.fs between versions 1.125 and 1.170

version 1.125, 2002/03/21 17:20:38 version 1.170, 2010/04/18 06:18:36
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 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 30  ToDo: Line 29  ToDo:
   
 [THEN]  [THEN]
   
   s" compat/strcomp.fs" included
   
 hex  hex
   
 \ debugging for compiling  \ debugging for compiling
Line 190  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 198  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 259  hex Line 262  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 445  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 454  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 474  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 491  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 511  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 544  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 574  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 660  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 1172  false DefaultValue header Line 1176  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 1230  bits/byte  Constant tbits/byte Line 1245  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)    
 (tlast) Value 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 1259  Variable region-link            \ linked Line 1275  Variable region-link            \ linked
 Variable mirrored-link          \ linked list for mirrored regions  Variable mirrored-link          \ linked list for mirrored regions
 0 dup mirrored-link ! region-link !  0 dup mirrored-link ! region-link !
   
 : >rname 8 cells + ;  : >rname 9 cells + ;
   : >rtouch 8 cells + ; \ executed when region is accessed
 : >rbm   4 cells + ; \ bitfield per cell witch indicates relocation  : >rbm   4 cells + ; \ bitfield per cell witch indicates relocation
 : >rmem  5 cells + ;  : >rmem  5 cells + ;
 : >rtype 6 cells + ; \ field per cell witch points to a type struct  : >rtype 6 cells + ; \ field per cell witch points to a type struct
Line 1274  Variable mirrored-link          \ linked Line 1291  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 ! ;
   
   : uninitialized -1 ABORT" CROSS: Region is uninitialized" ;
   
 : region ( addr len -- "name" )                  : region ( addr len -- "name" )                
 \G create a new region  \G create a new region
   \ check whether predefined region exists     \ check whether predefined region exists 
Line 1283  Variable mirrored-link          \ linked Line 1302  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 , 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 1301  Variable mirrored-link          \ linked Line 1322  Variable mirrored-link          \ linked
 \G returns the total area  \G returns the total area
   dup >rstart @ swap >rlen @ ;    dup >rstart @ swap >rlen @ ;
   
   : dp@ ( region -- dp )
     >rdp @ ;
   
 : mirrored ( -- )                                : mirrored ( -- )                              
 \G mark last defined region as mirrored  \G mark last defined region as mirrored
   mirrored-link    mirrored-link
Line 1346  Variable mirrored-link          \ linked Line 1370  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 1365  T has? rom H Line 1393  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 1390  T has? rom H Line 1433  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 1540  bigendian Line 1570  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 1622  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 1654  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 >ramimage
 DEFER relon  DEFER relon
Line 1698  Ghost (do)      Ghost (?do) Line 1728  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                                     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 1726  Ghost state drop Line 1757  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 1744  Ghost state drop Line 1781  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 2000  variable ResolveFlag Line 2040  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 2029  $20 constant restrict-mask Line 2069  $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 2066  s" kernel.TAGS" r/w create-file throw va Line 2110  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 2147  Defer skip? ' false IS skip? Line 2191  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 2173  NoHeaderFlag off Line 2218  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 2264  Defer setup-prim-semantics Line 2309  Defer setup-prim-semantics
   
 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 2273  Variable prim# Line 2320  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-noforwards 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 2359  T 2 cells H Value xt>body Line 2412  T 2 cells H Value xt>body
   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 cfalign H ;                                       ' (doeshandler,) plugin-of doeshandler,
   
 : (dodoes,) ( does-action-ghost -- )  : (dodoes,) ( does-action-ghost -- )
   ]comp [G'] :dodoes addr, comp[    ]comp [G'] :dodoes addr, comp[
Line 2432  Cond: ALiteral ( n -- )   alit, ;Cond Line 2485  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]
Line 2475  Cond: MAXI Line 2537  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 2527  Cond: MAXI Line 2589  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 2572  Cond: [ ( -- ) interpreting-state ;Cond Line 2634  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? 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 2584  Defer instant-interpret-does>-hook Line 2651  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 2767  by Create Line 2835  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 2790  Builder AUser Line 2881  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 2801  by (Value) Line 2907  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 2837  by (Field) Line 2949  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
   
 \ Input-Methods                                            01py  \ Input-Methods                                            01py
   
 Builder input-method  Builder input-method
Line 2859  DO:  abort" Not in cross mode" ;DO Line 2976  DO:  abort" Not in cross mode" ;DO
 \ optimizer for cross  \ optimizer for cross
   
   
 T has? peephole H [IF]  T has? primcentric H [IF]
   
   \ .( loading peephole optimization) cr
   
 >CROSS  >CROSS
   
Line 2867  T has? peephole H [IF] Line 2986  T has? peephole H [IF]
 : (callcm) T here 0 a, 0 a, H ;                 ' (callcm) plugin-of colonmark,  : (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
   T has? ec H [IF]
   : (pprim) T @ H >signed dup 0< IF  $4000 -  ELSE
       cr ." wrong usage of (prim) "
       dup gdiscover IF  .ghost  ELSE  .  THEN  cr -1 throw  THEN
       T a, H ;                                    ' (pprim) plugin-of prim,
   [ELSE]
 : (pprim) dup 0< IF  $4000 -  ELSE  : (pprim) dup 0< IF  $4000 -  ELSE
     cr ." wrong usage of (prim) "      cr ." wrong usage of (prim) "
     dup gdiscover IF  .ghost  ELSE  .  THEN  cr -1 throw  THEN      dup gdiscover IF  .ghost  ELSE  .  THEN  cr -1 throw  THEN
     T a, H ;                                    ' (pprim) plugin-of prim,      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 2894  Builder Defer Line 3020  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 2923  compile: does-resolved ;compile Line 3049  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 2957  compile: does-resolved ;compile Line 3083  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 3007  Cond: ?LEAVE    ?leave, ;Cond Line 3136  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 3115  Cond: NEXT 1 ncontrols? next, ;Cond Line 3247  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]
   
   X has? rom [IF]
   Cond: IS        T ' >body @ H compile ALiteral compile ! ;Cond
   : IS            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        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 ;
 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 3156  Cond: postpone ( -- ) \ name Line 3308  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 3177  tchar 8 = 78 and or Line 3329  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 3193  magic 7 + c! Line 3346  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 3352  Variable outfile-fd Line 3506  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 3439  Create parsed 20 chars allot \ store wor Line 3593  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 3497  Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond Line 3651  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 3588  previous Line 3742  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 3612  previous Line 3772  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 3631  previous Line 3796  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 3652  previous Line 3817  previous
 : bye           bye ;  : bye           bye ;
   
 \ dummy  \ dummy
 : group 0 word drop ;  
   
 \ turnkey direction  \ turnkey direction
 : H forth ; immediate  : H forth ; immediate

Removed from v.1.125  
changed lines
  Added in v.1.170


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