version 1.79, 1999/05/20 13:28:20
|
version 1.90, 2001/01/28 22:43:39
|
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 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 17
|
Line 17
|
|
|
\ 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, write to the Free Software |
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
0 |
0 |
[IF] |
[IF] |
Line 474 Create tfile 0 c, 255 chars allot
|
Line 474 Create tfile 0 c, 255 chars allot
|
THEN ; |
THEN ; |
|
|
: compact.. ( adr len -- adr2 len2 ) |
: compact.. ( adr len -- adr2 len2 ) |
\ deletes phrases like "xy/.." out of our directory name 2dec97jaw |
\ deletes phrases like "xy/.." out of our directory name 2dec97jaw |
over >r -1 >r |
over swap |
BEGIN dup WHILE |
BEGIN dup WHILE |
over c@ pathsep? |
dup >r '/ scan 2dup 4 min s" /../" compare 0= |
IF r@ -1 = |
IF |
IF r> drop dup >r |
dup r> - >r 4 /string over r> + 4 - |
ELSE 2dup 1 /string |
swap 2dup + >r move dup r> over - |
3 min s" ../" compare |
ELSE |
0= |
rdrop dup 1 min /string |
IF r@ over - ( diff ) |
THEN |
2 pick swap - ( dest-adr ) |
REPEAT drop over - ; |
>r 3 /string r> swap 2dup >r >r |
|
move r> r> |
|
ELSE r> drop dup >r |
|
THEN |
|
THEN |
|
THEN |
|
1 /string |
|
REPEAT |
|
r> drop |
|
drop r> tuck - ; |
|
|
|
: reworkdir ( -- ) |
: reworkdir ( -- ) |
remove~+ |
remove~+ |
Line 787 VARIABLE env-current \ save information
|
Line 777 VARIABLE env-current \ save information
|
|
|
>ENVIRON get-order get-current swap 1+ set-order |
>ENVIRON get-order get-current swap 1+ set-order |
true SetValue compiler |
true SetValue compiler |
true SetValue cross |
true SetValue cross |
true SetValue standard-threading |
true SetValue standard-threading |
>TARGET previous |
>TARGET previous |
|
|
Line 812 false DefaultValue dcomps
|
Line 802 false DefaultValue dcomps
|
false DefaultValue hash |
false DefaultValue hash |
false DefaultValue xconds |
false DefaultValue xconds |
false DefaultValue header |
false DefaultValue header |
|
false DefaultValue new-input |
[THEN] |
[THEN] |
|
|
true DefaultValue interpreter |
true DefaultValue interpreter |
Line 864 float Constant tfloat
|
Line 855 float Constant tfloat
|
bits/byte Constant tbits/byte |
bits/byte Constant tbits/byte |
[THEN] |
[THEN] |
H |
H |
tbits/byte bits/byte / Constant tbyte |
tbits/char bits/byte / Constant tbyte |
|
|
|
|
\ Variables 06oct92py |
\ Variables 06oct92py |
Line 1180 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 1171 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
: +bit ( addr n -- ) >bit over c@ or swap c! ; |
: +bit ( addr n -- ) >bit over c@ or swap c! ; |
: -bit ( addr n -- ) >bit invert over c@ and swap c! ; |
: -bit ( addr n -- ) >bit invert over c@ and swap c! ; |
|
|
: (relon) ( taddr -- ) bit$ @ swap cell/ +bit ; |
: (relon) ( taddr -- ) |
: (reloff) ( taddr -- ) bit$ @ swap cell/ -bit ; |
[ [IFDEF] fd-relocation-table ] |
|
s" +" fd-relocation-table write-file throw |
|
dup s>d <# #s #> fd-relocation-table write-line throw |
|
[ [THEN] ] |
|
bit$ @ swap cell/ +bit ; |
|
|
|
: (reloff) ( taddr -- ) |
|
[ [IFDEF] fd-relocation-table ] |
|
s" -" fd-relocation-table write-file throw |
|
dup s>d <# #s #> fd-relocation-table write-line throw |
|
[ [THEN] ] |
|
bit$ @ swap cell/ -bit ; |
|
|
: (>image) ( taddr -- absaddr ) image @ + ; |
: (>image) ( taddr -- absaddr ) image @ + ; |
|
|
Line 1222 T has? relocate H
|
Line 1224 T has? relocate H
|
: c@ ( taddr -- char ) >image Sc@ ; |
: c@ ( taddr -- char ) >image Sc@ ; |
: c! ( char taddr -- ) >image Sc! ; |
: c! ( char taddr -- ) >image Sc! ; |
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; |
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; |
: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ; |
: 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ; |
|
|
\ Target compilation primitives 06oct92py |
\ Target compilation primitives 06oct92py |
\ included A! 16may93jaw |
\ included A! 16may93jaw |
Line 1514 variable ResolveFlag
|
Line 1516 variable ResolveFlag
|
>CROSS |
>CROSS |
\ Header states 12dec92py |
\ Header states 12dec92py |
|
|
: flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; |
bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+ |
|
: flag! ( w -- ) tlast @ flag+ + dup >r T c@ xor r> c! H ; |
|
|
VARIABLE ^imm |
VARIABLE ^imm |
|
|
|
\ !! should be target wordsize specific |
|
$80 constant alias-mask |
|
$40 constant immediate-mask |
|
$20 constant restrict-mask |
|
|
>TARGET |
>TARGET |
: immediate 40 flag! |
: immediate immediate-mask flag! |
^imm @ @ dup <imm> = IF drop EXIT THEN |
^imm @ @ dup <imm> = IF drop EXIT THEN |
<res> <> ABORT" CROSS: Cannot immediate a unresolved word" |
<res> <> ABORT" CROSS: Cannot immediate a unresolved word" |
<imm> ^imm @ ! ; |
<imm> ^imm @ ! ; |
: restrict 20 flag! ; |
: restrict restrict-mask flag! ; |
|
|
: isdoer |
: isdoer |
\G define a forth word as doer, this makes obviously only sence on |
\G define a forth word as doer, this makes obviously only sence on |
Line 1535 VARIABLE ^imm
|
Line 1543 VARIABLE ^imm
|
|
|
>TARGET |
>TARGET |
: string, ( addr count -- ) |
: string, ( addr count -- ) |
dup T c, H bounds ?DO I c@ T c, H LOOP ; |
dup T c, H bounds ?DO I c@ T c, H LOOP ; |
: name, ( "name" -- ) bl word count T string, cfalign H ; |
: lstring, ( addr count -- ) |
|
dup T , H bounds ?DO I c@ T c, H LOOP ; |
|
: name, ( "name" -- ) bl word count T lstring, cfalign H ; |
: view, ( -- ) ( dummy ) ; |
: view, ( -- ) ( dummy ) ; |
>CROSS |
>CROSS |
|
|
Line 1651 NoHeaderFlag off
|
Line 1661 NoHeaderFlag off
|
base @ >r hex |
base @ >r hex |
0 swap <# 0 ?DO # LOOP #> type |
0 swap <# 0 ?DO # LOOP #> type |
r> base ! ; |
r> base ! ; |
: .sym |
|
|
: .sym ( adr len -- ) |
|
\G escapes / and \ to produce sed output |
bounds |
bounds |
DO I c@ dup |
DO I c@ dup |
CASE [char] / OF drop ." \/" ENDOF |
CASE [char] / OF drop ." \/" ENDOF |
Line 1674 NoHeaderFlag off
|
Line 1686 NoHeaderFlag off
|
>in @ T name, H >in ! |
>in @ T name, H >in ! |
THEN |
THEN |
T cfalign here H tlastcfa ! |
T cfalign here H tlastcfa ! |
\ Symbol table |
\ Old Symbol table sed-script |
\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! |
\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! |
ghost |
ghost |
|
\ output symbol table to extra file |
|
[ [IFDEF] fd-symbol-table ] |
|
base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base ! |
|
s" :" fd-symbol-table write-file throw |
|
dup >ghostname fd-symbol-table write-line throw |
|
[ [THEN] ] |
dup Last-Header-Ghost ! |
dup Last-Header-Ghost ! |
dup >magic ^imm ! \ a pointer for immediate |
dup >magic ^imm ! \ a pointer for immediate |
Already @ |
Already @ |
IF dup >end tdoes ! |
IF dup >end tdoes ! |
ELSE 0 tdoes ! |
ELSE 0 tdoes ! |
THEN |
THEN |
80 flag! |
alias-mask flag! |
cross-doc-entry cross-tag-entry ; |
cross-doc-entry cross-tag-entry ; |
|
|
VARIABLE ;Resolve 1 cells allot |
VARIABLE ;Resolve 1 cells allot |
Line 1700 VARIABLE ;Resolve 1 cells allot
|
Line 1718 VARIABLE ;Resolve 1 cells allot
|
IF |
IF |
.sourcepos ." needs prim: " >in @ bl word count type >in ! cr |
.sourcepos ." needs prim: " >in @ bl word count type >in ! cr |
THEN |
THEN |
(THeader over resolve T A, H 80 flag! ; |
(THeader over resolve T A, H alias-mask flag! ; |
: Alias: ( cfa -- ) \ name |
: Alias: ( cfa -- ) \ name |
>in @ skip? IF 2drop EXIT THEN >in ! |
>in @ skip? IF 2drop EXIT THEN >in ! |
dup 0< s" prims" T $has? H 0= and |
dup 0< s" prims" T $has? H 0= and |
Line 1797 Cond: ['] T ' H alit, ;Cond
|
Line 1815 Cond: ['] T ' H alit, ;Cond
|
: (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit, |
: (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit, |
|
|
\ if we dont produce relocatable code alit, defaults to lit, jaw |
\ if we dont produce relocatable code alit, defaults to lit, jaw |
has? relocate |
\ this is just for convenience, so we don't have to define alit, |
|
\ seperately for embedded systems.... |
|
T has? relocate H |
[IF] |
[IF] |
: (alit,) ( n -- ) compile lit T a, H ; ' (alit,) IS alit, |
: (alit,) ( n -- ) compile lit T a, H ; ' (alit,) IS alit, |
[ELSE] |
[ELSE] |
Line 2022 Cond: DOES> restrict?
|
Line 2042 Cond: DOES> restrict?
|
create-forward-warn |
create-forward-warn |
IF ['] reswarn-forward IS resolve-warning THEN |
IF ['] reswarn-forward IS resolve-warning THEN |
\ make Alias |
\ make Alias |
(THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost ) |
(THeader there 0 T a, H alias-mask flag! ( S executed-ghost new-ghost ) |
\ store poiter to code-field |
\ store poiter to code-field |
switchram T cfalign H |
switchram T cfalign H |
there swap T ! H |
there swap T ! H |
Line 2191 Builder Field
|
Line 2211 Builder Field
|
: cell% ( n -- size align ) |
: cell% ( n -- size align ) |
T 1 cells H dup ; |
T 1 cells H dup ; |
|
|
|
Build: ( m v -- m' v ) dup T , H cell+ ; |
|
DO: abort" Not in cross mode" ;DO |
|
Builder input-method |
|
|
|
Build: ( m v size -- m v' ) over T , H + ; |
|
DO: abort" Not in cross mode" ;DO |
|
Builder input-var |
|
|
\ structural conditionals 17dec92py |
\ structural conditionals 17dec92py |
|
|
>CROSS |
>CROSS |
Line 2406 magic 7 + c!
|
Line 2434 magic 7 + c!
|
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 |
TNIL IF |
TNIL IF |
s" #! " r@ write-file throw |
s" #! " r@ write-file throw |
bl parse r@ write-file throw |
bl parse r@ write-file throw |
s" -i" r@ write-file throw |
s" --image-file" r@ write-file throw |
#lf r@ emit-file throw |
#lf r@ emit-file throw |
r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) |
r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) |
?do |
?do |