version 1.78, 1999/05/18 14:38:49
|
version 1.84, 2000/05/04 09:31:16
|
Line 646 VARIABLE GhostNames
|
Line 646 VARIABLE GhostNames
|
0 GhostNames ! |
0 GhostNames ! |
|
|
: GhostName ( -- addr ) |
: GhostName ( -- addr ) |
here GhostNames @ , GhostNames ! here 0 , |
align here GhostNames @ , GhostNames ! here 0 , |
bl word count |
bl word count |
\ 2dup type space |
\ 2dup type space |
string, \ !! cfalign ? |
string, \ !! cfalign ? |
Line 787 VARIABLE env-current \ save information
|
Line 787 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 864 float Constant tfloat
|
Line 864 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 927 Variable mirrored-link \ linked
|
Line 927 Variable mirrored-link \ linked
|
dup >rstart @ swap >rdp @ over - ; |
dup >rstart @ swap >rdp @ over - ; |
|
|
: area ( region -- startaddr totallen ) \G returns the total area |
: area ( region -- startaddr totallen ) \G returns the total area |
dup >rstart swap >rlen @ ; |
dup >rstart @ swap >rlen @ ; |
|
|
: mirrored \G mark a region as mirrored |
: mirrored \G mark a region as mirrored |
mirrored-link |
mirrored-link |
Line 1180 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 1180 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 1233 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 1489 variable ResolveFlag
|
Line 1500 variable ResolveFlag
|
ELSE drop |
ELSE drop |
THEN ; |
THEN ; |
|
|
>MINIMAL |
|
: .unresolved ( -- ) |
: .unresolved ( -- ) |
ResolveFlag off cr ." Unresolved: " |
ResolveFlag off cr ." Unresolved: " |
Ghostnames |
Ghostnames |
Line 1508 variable ResolveFlag
|
Line 1518 variable ResolveFlag
|
cr ." named Headers: " headers-named @ . |
cr ." named Headers: " headers-named @ . |
r> base ! ; |
r> base ! ; |
|
|
|
>MINIMAL |
|
|
|
: .unresolved .unresolved ; |
|
|
>CROSS |
>CROSS |
\ Header states 12dec92py |
\ Header states 12dec92py |
|
|
Line 1604 Create tag-bof 1 c, 0C c,
|
Line 1618 Create tag-bof 1 c, 0C c,
|
Defer skip? ' false IS skip? |
Defer skip? ' false IS skip? |
|
|
: skipdef ( <name> -- ) |
: skipdef ( <name> -- ) |
\G skip definition of an undefined word in undef-words mode |
\G skip definition of an undefined word in undef-words and |
|
\G all-words mode |
ghost dup forward? |
ghost dup forward? |
IF >magic <skip> swap ! |
IF >magic <skip> swap ! |
ELSE drop THEN ; |
ELSE drop THEN ; |
Line 1617 Defer skip? ' false IS skip?
|
Line 1632 Defer skip? ' false IS skip?
|
\G that's what we want |
\G that's what we want |
ghost forward? 0= ; |
ghost forward? 0= ; |
|
|
|
: forced? ( -- flag ) \ name |
|
\G return ture if it is a foreced skip with defskip |
|
ghost >magic @ <skip> = ; |
|
|
: needed? ( -- flag ) \ name |
: needed? ( -- flag ) \ name |
\G returns a false flag when |
\G returns a false flag when |
\G a word is not defined |
\G a word is not defined |
Line 1643 NoHeaderFlag off
|
Line 1662 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 1666 NoHeaderFlag off
|
Line 1687 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 @ |
Line 1789 Cond: ['] T ' H alit, ;Cond
|
Line 1816 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 2347 Cond: defers T ' >body @ compile, H ;Con
|
Line 2376 Cond: defers T ' >body @ compile, H ;Con
|
\ LINKED ERR" ENV" 2ENV" 18may93jaw |
\ LINKED ERR" ENV" 2ENV" 18may93jaw |
|
|
\ linked list primitive |
\ linked list primitive |
: linked T here over @ A, swap ! H ; |
: linked X here over X @ X A, swap X ! ; |
: chained T linked A, H ; |
: chained T linked A, H ; |
|
|
: err" s" ErrLink linked" evaluate T , H |
: err" s" ErrLink linked" evaluate T , H |
Line 2398 magic 7 + c!
|
Line 2427 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 |
Line 2587 previous
|
Line 2616 previous
|
: 2/ 2/ ; |
: 2/ 2/ ; |
: . . ; |
: . . ; |
|
|
: all-words ['] false IS skip? ; |
: all-words ['] forced? IS skip? ; |
: needed-words ['] needed? IS skip? ; |
: needed-words ['] needed? IS skip? ; |
: undef-words ['] defined2? IS skip? ; |
: undef-words ['] defined2? IS skip? ; |
: skipdef skipdef ; |
: skipdef skipdef ; |