version 1.54, 1998/05/02 21:28:41
|
version 1.61, 1998/12/22 13:41:18
|
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 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 52 Warnings off
|
Line 52 Warnings off
|
|
|
\ words that are generaly useful |
\ words that are generaly useful |
|
|
|
: KB 400 * ; |
: >wordlist ( vocabulary-xt -- wordlist-struct ) |
: >wordlist ( vocabulary-xt -- wordlist-struct ) |
also execute get-order swap >r 1- set-order r> ; |
also execute get-order swap >r 1- set-order r> ; |
|
|
Line 68 Warnings off
|
Line 69 Warnings off
|
\G SetValue searches in the current vocabulary |
\G SetValue searches in the current vocabulary |
save-input bl word >r restore-input throw r> count |
save-input bl word >r restore-input throw r> count |
get-current search-wordlist |
get-current search-wordlist |
IF bl word drop >body ! ELSE Value THEN ; |
IF ['] to execute ELSE Value THEN ; |
|
|
: DefaultValue ( n -- <name> ) |
: DefaultValue ( n -- <name> ) |
\G Same behaviour as "Value" if the <name> is not defined |
\G Same behaviour as "Value" if the <name> is not defined |
\G DefaultValue searches in the current vocabulary |
\G DefaultValue searches in the current vocabulary |
save-input bl word >r restore-input throw r> count |
save-input bl word >r restore-input throw r> count |
get-current search-wordlist |
get-current search-wordlist |
IF bl word drop drop drop ELSE Value THEN ; |
IF bl word drop 2drop ELSE Value THEN ; |
|
|
hex |
hex |
|
|
Line 302 true SetValue cross
|
Line 303 true SetValue cross
|
true SetValue standard-threading |
true SetValue standard-threading |
>TARGET previous |
>TARGET previous |
|
|
|
|
mach-file count included hex |
mach-file count included hex |
|
|
>ENVIRON |
>ENVIRON |
Line 334 s" relocate" T environment? H
|
Line 336 s" relocate" T environment? H
|
|
|
\ \ Create additional parameters 19jan95py |
\ \ Create additional parameters 19jan95py |
|
|
|
1 8 lshift Constant maxbyte |
T |
T |
NIL Constant TNIL |
NIL Constant TNIL |
cell Constant tcell |
cell Constant tcell |
cell<< Constant tcell<< |
cell<< Constant tcell<< |
cell>bit Constant tcell>bit |
cell>bit Constant tcell>bit |
bits/byte Constant tbits/byte |
bits/byte Constant tbits/byte |
|
bits/byte 8 / Constant tchar |
float Constant tfloat |
float Constant tfloat |
1 bits/byte lshift Constant maxbyte |
1 bits/byte lshift Constant tmaxbyte |
H |
H |
|
|
\ Variables 06oct92py |
\ Variables 06oct92py |
Line 589 bigendian
|
Line 593 bigendian
|
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; |
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; |
: S@ ( addr -- n ) >r 0 0 r> tcell bounds |
: S@ ( addr -- n ) >r 0 0 r> tcell bounds |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; |
|
: Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1- |
|
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; |
|
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds |
|
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; |
[ELSE] |
[ELSE] |
: S! ( n addr -- ) >r s>d r> tcell bounds |
: S! ( n addr -- ) >r s>d r> tcell bounds |
DO maxbyte ud/mod rot I c! LOOP 2drop ; |
DO maxbyte ud/mod rot I c! LOOP 2drop ; |
: S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- |
: S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; |
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; |
|
: Sc! ( n addr -- ) >r s>d r> tchar bounds |
|
DO maxbyte ud/mod rot I c! LOOP 2drop ; |
|
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1- |
|
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; |
[THEN] |
[THEN] |
|
|
>CROSS |
>CROSS |
Line 629 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 641 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
>TARGET |
>TARGET |
: @ ( taddr -- w ) >image S@ ; |
: @ ( taddr -- w ) >image S@ ; |
: ! ( w taddr -- ) >image S! ; |
: ! ( w taddr -- ) >image S! ; |
: c@ ( taddr -- char ) >image c@ ; |
: c@ ( taddr -- char ) >image Sc@ ; |
: c! ( char taddr -- ) >image c! ; |
: 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 swap over ! cell+ ! H ; |
|
|
Line 640 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 652 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
: here ( -- there ) there ; |
: here ( -- there ) there ; |
: allot ( n -- ) tdp +! ; |
: allot ( n -- ) tdp +! ; |
: , ( w -- ) T here H tcell T allot ! H T here drop H ; |
: , ( w -- ) T here H tcell T allot ! H T here drop H ; |
: c, ( char -- ) T here 1 allot c! H ; |
: c, ( char -- ) T here tchar allot c! H ; |
: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; |
: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; |
: cfalign ( -- ) |
: cfalign ( -- ) |
T here H cfalign+ 0 ?DO bl T c, H LOOP ; |
T here H cfalign+ 0 ?DO bl T c, tchar H +LOOP ; |
|
|
: A! dup relon T ! H ; |
: >address dup 0>= IF tchar / THEN ; |
: A, ( w -- ) T here H relon T , H ; |
: A! swap >address swap dup relon T ! H ; |
|
: A, ( w -- ) >address T here H relon T , H ; |
|
|
>CROSS |
>CROSS |
|
|
: tcmove ( source dest len -- ) |
: tcmove ( source dest len -- ) |
\G cmove in target memory |
\G cmove in target memory |
bounds |
tchar * bounds |
?DO dup T c@ H I T c! H 1+ |
?DO dup T c@ H I T c! H 1+ |
LOOP drop ; |
tchar +LOOP drop ; |
|
|
>TARGET |
>TARGET |
H also Forth definitions \ ." asm: " order |
H also Forth definitions \ ." asm: " order |
Line 992 VARIABLE ^imm
|
Line 1005 VARIABLE ^imm
|
|
|
\ Target Document Creation (goes to crossdoc.fd) 05jul95py |
\ Target Document Creation (goes to crossdoc.fd) 05jul95py |
|
|
s" doc/crossdoc.fd" r/w create-file throw value doc-file-id |
s" ./doc/crossdoc.fd" r/w create-file throw value doc-file-id |
\ contains the file-id of the documentation file |
\ contains the file-id of the documentation file |
|
|
: T-\G ( -- ) |
: T-\G ( -- ) |
Line 1105 NoHeaderFlag off
|
Line 1118 NoHeaderFlag off
|
IF NoHeaderFlag off |
IF NoHeaderFlag off |
ELSE |
ELSE |
T align H view, |
T align H view, |
tlast @ dup 0> IF T 1 cells - THEN A, H there tlast ! |
tlast @ dup 0> IF T 1 cells - H THEN T A, H there tlast ! |
1 headers-named +! \ Statistic |
1 headers-named +! \ Statistic |
>in @ T name, H >in ! |
>in @ T name, H >in ! |
THEN |
THEN |
Line 1213 Cond: ['] T ' H alit, ;Cond
|
Line 1226 Cond: ['] T ' H alit, ;Cond
|
\ modularized 14jun97jaw |
\ modularized 14jun97jaw |
|
|
: fillcfa ( usedcells -- ) |
: fillcfa ( usedcells -- ) |
T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ; |
T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ; |
|
|
: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H |
: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H |
|
|
Line 1263 Defer (end-code)
|
Line 1276 Defer (end-code)
|
ELSE true ABORT" CROSS: Stack empty" THEN |
ELSE true ABORT" CROSS: Stack empty" THEN |
; |
; |
|
|
Cond: chars ;Cond |
( Cond ) : chars tchar * ; ( Cond ) |
|
|
>CROSS |
>CROSS |
|
|
Line 1621 Builder Field
|
Line 1634 Builder Field
|
: sys? ( sys -- sys ) dup 0= ?struc ; |
: sys? ( sys -- sys ) dup 0= ?struc ; |
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; |
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; |
|
|
: branchoffset ( src dest -- ) - ; |
: branchoffset ( src dest -- ) - tchar / ; |
|
|
: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; |
: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; |
|
|
Line 1993 bigendian Constant bigendian
|
Line 2006 bigendian Constant bigendian
|
: tempdp> tempdp> ; |
: tempdp> tempdp> ; |
: const constflag on ; |
: const constflag on ; |
: warnings name 3 = 0= twarnings ! drop ; |
: warnings name 3 = 0= twarnings ! drop ; |
: | NoHeaderFlag on ; |
: | ; |
|
\ : | NoHeaderFlag on ; \ This is broken (damages the last word) |
|
|
: save-cross save-cross ; |
: save-cross save-cross ; |
: save-region save-region ; |
: save-region save-region ; |