version 1.149, 2005/08/21 22:09:14
|
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,2004 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 1751 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 1771 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 2057 $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 2570 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 2632 T has? peephole H [IF]
|
Line 2640 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? 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 2822 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 2863 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 2874 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 3212 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 3269 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 3285 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+ |