[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.132 and 1.169

version 1.132, Sat Dec 28 17:18:26 2002 UTC version 1.169, Mon Apr 5 22:17:56 2010 UTC
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 192 
Line 191 
         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 200 
Line 199 
     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 447 
Line 448 
     \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 456 
Line 457 
   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 546 
Line 547 
   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 662 
Line 663 
 : defempty? empty? ;  : defempty? empty? ;
 [ELSE]  [ELSE]
 : defempty? ; immediate  : defempty? ; immediate
   \ : defempty? .sourcepos ;
 [THEN]  [THEN]
   
 \ \ --------------------        Compiler Plug Ins               01aug97jaw  \ \ --------------------        Compiler Plug Ins               01aug97jaw
Line 1174 
Line 1176 
 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  false DefaultValue abranch
   true DefaultValue f83headerstring
 true  DefaultValue control-rack  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 1234 
Line 1245 
 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 1263 
Line 1275 
 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 1278 
Line 1291 
   >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 1287 
Line 1302 
         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 1305 
Line 1322 
 \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 1350 
Line 1370 
 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 1369 
Line 1393 
   
 ' 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 1394 
Line 1433 
   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 1544 
Line 1570 
         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 1626 
Line 1654 
   [ [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 1702 
Line 1728 
 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")      Ghost c(abort") Ghost type      2drop drop  Ghost (C")      Ghost c(abort") Ghost type      2drop drop
 Ghost '                                         drop  Ghost '                                         drop
Line 1730 
Line 1757 
   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 ;
Line 1741 
Line 1772 
   
 : 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 1750 
Line 1781 
   ?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 2006 
Line 2040 
 \ 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 2035 
Line 2069 
   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 2072 
Line 2110 
 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 2153 
Line 2191 
         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 2179 
Line 2218 
         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 2271 
Line 2310 
 Variable prim#  Variable prim#
 : first-primitive ( n -- )  prim# ! ;  : first-primitive ( n -- )  prim# ! ;
 : group 0 word drop prim# @ 1- -$200 and 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 2280 
Line 2320 
   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 2439 
Line 2485 
 : 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 2482 
Line 2537 
         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 2534 
Line 2589 
   (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 2579 
Line 2634 
     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 2591 
Line 2651 
   
 >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>2) compile ;s
           doeshandler, resolve-does>-part
         ;Cond          ;Cond
   
 : DOES>  : DOES>
Line 2774 
Line 2835 
   
 \ 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
Line 2797 
Line 2881 
 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 2808 
Line 2907 
 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
   T has? rom H [IF]
       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  BuildSmart:  ( -- ) [T'] noop T A, H ;Build
 by: :dodefer ( ghost -- ) X @ texecute ;DO  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 2844 
Line 2949 
     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 2866 
Line 2976 
 \ optimizer for cross  \ optimizer for cross
   
   
 T has? peephole H [IF]  T has? primcentric H [IF]
   
   \ .( loading peephole optimization) cr
   
 >CROSS  >CROSS
   
Line 2874 
Line 2986 
 : (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 2901 
Line 3020 
 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 2930 
Line 3049 
   
 : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;  : >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;
   
   X has? abranch [IF]
       : branchoffset ( src dest -- )  drop ;
       : offset, ( n -- )  X A, ;
   [ELSE]
 : branchoffset ( src dest -- )  - tchar / ; \ ?? jaw  : 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 3013 
Line 3138 
   
 : loop] ( target-addr -- )  : loop] ( target-addr -- )
   branchto,    branchto,
   dup   X here branchoffset X ,    dup   X here branchoffset offset,
   tcell - (done) ;    tcell - (done) ;
   
 : skiploop] ?dup IF branchto, branchtoresolve, THEN ;  : skiploop] ?dup IF branchto, branchtoresolve, THEN ;
Line 3118 
Line 3243 
 Cond: +LOOP     1 ncontrols? +loop, ;Cond  Cond: +LOOP     1 ncontrols? +loop, ;Cond
 Cond: NEXT      1 ncontrols? next, ;Cond  Cond: NEXT      1 ncontrols? next, ;Cond
   
 \ Absoulte branches                                     26sep02jaw  
   
 \ This section defined different semantics for  
 \ conditionals, using and compiling absolute branches  
   
 X has? abranch [IF]  
   
 Ghost abranch drop  
 Ghost a?branch drop  
 Ghost a(?do) drop  
 Ghost a(do) drop  
 Ghost a(next) drop  
 Ghost a(+loop) drop  
 Ghost a(loop) drop  
   
 :noname compile abranch X a, ;             plugin-of branch,  
   
 :noname compile a?branch X a, ;            plugin-of ?branch,  
   
 :noname compile abranch T here 0  a, H ;   plugin-of branchmark,  
   
 :noname compile a?branch T here 0 a, H ;   plugin-of ?branchmark,  
   
 :noname  
   dup X @ ABORT" CROSS: branch already resolved"  
   X here swap X a! ;                       plugin-of branchtoresolve,  
   
 :noname  
   0 compile a(?do) ?domark, (leave)  
   branchtomark, 2 to1 ;                    plugin-of ?do,  
   
 : aloop] ( target-addr -- )  
   branchto,  
   dup X a,  
   tcell - (done) ;  
   
 :noname  
   1to compile a(loop) aloop]  
   compile unloop skiploop] ;               plugin-of loop,  
   
 :noname  
   1to compile a(+loop) aloop]  
   compile unloop skiploop] ;               plugin-of +loop,  
   
 :noname  
   compile a(next) aloop] compile unloop ;   plugin-of next,  
   
 [THEN]  
   
 \ String words                                         23feb93py  \ String words                                         23feb93py
   
 : ,"            [char] " parse ht-string, X align ;  : ,"            [char] " parse ht-string, X align ;
Line 3187 
Line 3263 
                 >r then, r> compile ALiteral compile c(abort") then, ;Cond                  >r then, r> compile ALiteral compile c(abort") then, ;Cond
 [THEN]  [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 3223 
Line 3308 
       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
   
Line 3244 
Line 3329 
 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 3260 
Line 3346 
   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 3655 
Line 3742 
 : * * ;  : * * ;
 : / / ;  : / / ;
 : 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 3679 
Line 3772 
 : 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 ;
   

Generate output suitable for use with a patch program
Legend:
Removed from v.1.132  
changed lines
  Added in v.1.169
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help