Diff for /gforth/cross.fs between versions 1.150 and 1.167

version 1.150, 2005/12/31 15:46:08 version 1.167, 2009/03/24 08:55:29
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,2003,2004,2005 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006,2007 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  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 200  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 1175  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  false DefaultValue abranch
 true DefaultValue f83headerstring  true DefaultValue f83headerstring
 true DefaultValue control-rack  true DefaultValue control-rack
Line 1184  true DefaultValue gforthcross Line 1186  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  \ ANSForth environment  stuff
Line 1242  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
   
Line 1751  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 ;
Line 1771  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 2057  $20 constant restrict-mask Line 2070  $20 constant restrict-mask
   
 >TARGET  >TARGET
 X has? f83headerstring [IF]  X has? f83headerstring [IF]
 : name,  ( "name" -- )  bl word count ht-string, X cfalign ;  : name,  ( "name" -- )  bl word count ht-header, X cfalign ;
 [ELSE]  [ELSE]
 : name,  ( "name" -- )  bl word count ht-lstring, X cfalign ;  : name,  ( "name" -- )  bl word count ht-lstring, X cfalign ;
 [THEN]  [THEN]
Line 2307  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 2518  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 2570  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 2617  Cond: [ ( -- ) interpreting-state ;Cond Line 2636  Cond: [ ( -- ) interpreting-state ;Cond
   
 Defer instant-interpret-does>-hook  ' noop IS instant-interpret-does>-hook  Defer instant-interpret-does>-hook  ' noop IS instant-interpret-does>-hook
   
 T has? peephole H [IF]  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]  [ELSE]
Line 2632  T has? peephole H [IF] Line 2651  T has? peephole H [IF]
   
 >TARGET  >TARGET
 Cond: DOES>  Cond: DOES>
         T here 5 cells H + alit, compile (does>2) compile ;s          T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells
           H + alit, compile (does>2) compile ;s
         doeshandler, resolve-does>-part          doeshandler, resolve-does>-part
         ;Cond          ;Cond
   
Line 2822  by Create Line 2842  by Create
   
 : u,  ( n -- udp )  : u,  ( n -- udp )
   current-region >r user-region activate    current-region >r user-region activate
   X here swap X , tup@ -     X here swap X , tup@ -
   r> activate ;    r> activate ;
   
 : au, ( n -- udp )  : au, ( n -- udp )
Line 2863  by User Line 2883  by User
   
 [THEN]  [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 2874  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 2932  DO:  abort" Not in cross mode" ;DO Line 2971  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  \ .( loading peephole optimization) cr
   
Line 2942  T has? peephole H [IF] Line 2981  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 2969  Builder Defer Line 3015  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 3212  Cond: ABORT"    if, ahead, there [char] Line 3258  Cond: ABORT"    if, ahead, there [char]
                 >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 3269  tchar 8 = 78 and or Line 3324  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 3285  magic 7 + c! Line 3341  magic 7 + c!
   ELSE    ELSE
       bl parse 2drop        bl parse 2drop
   THEN    THEN
   dictionary >rmem @ 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
       dictionary >rbm @ there 1- tcell>bit rshift 1+        dictionary >rbm @ there 1- tcell>bit rshift 1+
Line 3693  previous Line 3750  previous
 : 2/ 2/ ;  : 2/ 2/ ;
 : hex. base @ $10 base ! swap . base ! ;  : hex. base @ $10 base ! swap . base ! ;
 : invert invert ;  : 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? ;

Removed from v.1.150  
changed lines
  Added in v.1.167


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