[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs

Diff for /gforth/cross.fs between version 1.150 and 1.163

version 1.150, Sat Dec 31 15:46:08 2005 UTC version 1.163, Sat Mar 31 21:43:18 2007 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,2003,2004,2005 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 1175 
Line 1175 
 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 
Line 1185 
 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 1751 
Line 1753 
   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 
Line 1777 
   ?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 
Line 2066 
   
 >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 
Line 2316 
   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!    over resolve-noforwards T A, H
     s" EC" T $has? H 0=
     IF
         alias-mask flag!
     THEN
   -1 prim# +! ;    -1 prim# +! ;
 >CROSS  >CROSS
   
Line 2570 
Line 2583 
   (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 
Line 2630 
   
 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 
Line 2645 
   
 >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 2863 
Line 2877 
   
 [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 
Line 2901 
 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 2932 
Line 2965 
 \ 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 3212 
Line 3245 
                 >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 
Line 3311 
 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 
Line 3328 
   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 
Line 3737 
 : 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? ;

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help