Diff for /gforth/cross.fs between versions 1.143 and 1.155

version 1.143, 2003/11/09 20:47:49 version 1.155, 2006/02/18 22:58:04
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 447  sourcepath value fpath Line 447  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 456  sourcepath value fpath Line 456  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 546  Create tfile 0 c, 255 chars allot Line 546  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 1722  Ghost (do)      Ghost (?do) Line 1722  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>)   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 1761  Ghost state drop Line 1762  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 1771  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 2204  NoHeaderFlag off Line 2208  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 2573  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 2618  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 2635  T has? peephole H [IF]
   
 >TARGET  >TARGET
 Cond: DOES>  Cond: DOES>
         compile (does>) doeshandler,          T here 5 cells H + alit, compile (does>2) compile ;s
         resolve-does>-part          doeshandler, resolve-does>-part
         ;Cond          ;Cond
   
 : DOES>  : DOES>
Line 2821  by Create Line 2825  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 2866  by User
   
 [THEN]  [THEN]
   
   T has? rom H [IF]
   Builder (Value)
   Build:  ( n -- ) ;Build
   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)  Builder (Value)
 Build:  ( n -- ) ;Build  Build:  ( n -- ) ;Build
 by: :docon ( target-body-addr -- n ) T @ H ;DO  by: :docon ( target-body-addr -- n ) T @ H ;DO
Line 2873  by (Value) Line 2890  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 3234  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 3298  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 3315  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.143  
changed lines
  Added in v.1.155


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