Diff for /gforth/cross.fs between versions 1.145 and 1.158

version 1.145, 2004/05/16 21:16:35 version 1.158, 2006/03/05 14:10:51
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 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 1184  true DefaultValue gforthcross Line 1184  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 1722  Ghost (do)      Ghost (?do) Line 1723  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 (does>1)  Ghost compile,  2drop drop  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 1750  Ghost state drop Line 1752  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 1761  Ghost state drop Line 1767  Ghost state drop
   
 : 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 1770  Ghost state drop Line 1776  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 2056  $20 constant restrict-mask Line 2065  $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 2204  NoHeaderFlag off Line 2213  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 2569  Cond: MAXI Line 2578  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 2614  Cond: [ ( -- ) interpreting-state ;Cond Line 2623  Cond: [ ( -- ) interpreting-state ;Cond
     r@ created >do:ghost ! r@ swap resolve      r@ created >do:ghost ! r@ swap resolve
     r> tlastcfa @ >tempdp dodoes, tempdp> ;      r> tlastcfa @ >tempdp dodoes, tempdp> ;
   
 Defer instant-interpret-does>-hook  Defer instant-interpret-does>-hook  ' noop IS instant-interpret-does>-hook
   
 T has? peephole H [IF]  T has? peephole H [IF]
 : does-resolved ( ghost -- )  : does-resolved ( ghost -- )
Line 2631  T has? peephole H [IF] Line 2640  T has? peephole H [IF]
   
 >TARGET  >TARGET
 Cond: DOES>  Cond: DOES>
         T here 4 cells H + alit, compile (does>1)          T here H [ T has? peephole 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 2821  by Create Line 2831  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 2862  by User Line 2872  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 2873  by (Value) Line 2896  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 3211  Cond: ABORT"    if, ahead, there [char] Line 3240  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 ;
   [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 3268  tchar 8 = 78 and or Line 3304  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 3284  magic 7 + c! Line 3321  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+

Removed from v.1.145  
changed lines
  Added in v.1.158


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