version 1.2, 1994/05/03 15:24:11
|
version 1.5, 1994/06/01 10:05:14
|
Line 23
|
Line 23
|
|
|
include other.fs \ ansforth extentions for cross |
include other.fs \ ansforth extentions for cross |
|
|
|
: comment? ( c-addr u -- c-addr u ) |
|
2dup s" (" compare 0= |
|
IF postpone ( |
|
ELSE 2dup s" \" compare 0= IF postpone \ THEN |
|
THEN ; |
|
|
decimal |
decimal |
|
|
\ number? 11may93jaw |
\ number? 11may93jaw |
Line 117 Variable bit$
|
Line 123 Variable bit$
|
Variable tdp |
Variable tdp |
: there tdp @ ; |
: there tdp @ ; |
|
|
\ Constants 06apr93py |
|
|
|
-2 Constant :docol |
|
-3 Constant :docon |
|
-4 Constant :dovar |
|
-5 Constant :dodoes |
|
|
|
\ Parameter for target systems 06oct92py |
\ Parameter for target systems 06oct92py |
|
|
include machine.fs |
include machine.fs |
Line 144 include machine.fs
|
Line 143 include machine.fs
|
-2 Constant :docol |
-2 Constant :docol |
-3 Constant :docon |
-3 Constant :docon |
-4 Constant :dovar |
-4 Constant :dovar |
-5 Constant :dodoes |
-5 Constant :douser |
|
-6 Constant :dodoes |
|
-7 Constant :doesjump |
|
|
>CROSS |
>CROSS |
|
|
Line 160 endian 0 pad ! -1 pad c! pad @ 0<
|
Line 161 endian 0 pad ! -1 pad c! pad @ 0<
|
\ Fixed bug in else part 11may93jaw |
\ Fixed bug in else part 11may93jaw |
|
|
[IFDEF] Memory \ Memory is a bigFORTH feature |
[IFDEF] Memory \ Memory is a bigFORTH feature |
Memory |
also Memory |
: initmem ( var len -- ) |
: initmem ( var len -- ) |
2dup swap handle! >r @ r> erase ; |
2dup swap handle! >r @ r> erase ; |
Target |
toss |
[ELSE] |
[ELSE] |
: initmem ( var len -- ) |
: initmem ( var len -- ) |
tuck allocate abort" CROSS: No memory for target" |
tuck allocate abort" CROSS: No memory for target" |
Line 186 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 187 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
|
|
: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; |
: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; |
: +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! ; |
: relon ( taddr -- ) bit$ @ swap cell/ +bit ; |
: relon ( taddr -- ) bit$ @ swap cell/ +bit ; |
|
: reloff ( taddr -- ) bit$ @ swap cell/ -bit ; |
|
|
\ Target memory access 06oct92py |
\ Target memory access 06oct92py |
|
|
Line 228 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 231 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
: >body ( cfa -- pfa ) T cell+ cell+ H ; |
: >body ( cfa -- pfa ) T cell+ cell+ H ; |
>CROSS |
>CROSS |
|
|
: dodoes, ( -- ) T 0 , 0 , H ; |
: dodoes, ( -- ) T :doesjump A, 0 , H ; |
|
|
\ Ghost Builder 06oct92py |
\ Ghost Builder 06oct92py |
|
|
Line 266 Variable atonce atonce off
|
Line 269 Variable atonce atonce off
|
: gfind ( string -- ghost true/1 / string false ) |
: gfind ( string -- ghost true/1 / string false ) |
\ searches for string in word-list ghosts |
\ searches for string in word-list ghosts |
\ !! wouldn't it be simpler to just use search-wordlist ? ae |
\ !! wouldn't it be simpler to just use search-wordlist ? ae |
>r get-order 0 set-order also ghosts r> find >r >r |
dup count [ ' ghosts >body ] ALiteral search-wordlist |
set-order r> r@ IF >body THEN r> ; |
\ >r get-order 0 set-order also ghosts r> find >r >r |
|
>r r@ IF >body nip THEN r> ; |
|
\ set-order r> r@ IF >body THEN r> ; |
|
|
VARIABLE Already |
VARIABLE Already |
|
|
Line 515 Cond: DOES> restrict?
|
Line 520 Cond: DOES> restrict?
|
|
|
: gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <> |
: gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <> |
IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN |
IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN |
:dodoes T A, H gexecute ; |
:dodoes T A, H gexecute T here H cell - reloff ; |
|
|
: TCreate ( ghost -- ) |
: TCreate ( ghost -- ) |
CreateFlag on |
CreateFlag on |
Line 562 Build: T 0 A, H ;
|
Line 567 Build: T 0 A, H ;
|
by Create |
by Create |
Builder AVariable |
Builder AVariable |
|
|
Build: T 0 , H ; |
\ User variables 04may94py |
by Create |
|
|
>CROSS |
|
Variable tup 0 tup ! |
|
Variable tudp 0 tudp ! |
|
: u, ( n -- udp ) |
|
tup @ tudp @ + T ! H |
|
tudp @ dup cell+ tudp ! ; |
|
: au, ( n -- udp ) |
|
tup @ tudp @ + T A! H |
|
tudp @ dup cell+ tudp ! ; |
|
>TARGET |
|
|
|
Build: T 0 u, , H ; |
|
DO: ( ghost -- up-addr ) T @ H tup @ + ;DO |
Builder User |
Builder User |
|
by User :douser resolve |
|
|
Build: T 0 , 0 , H ; |
Build: T 0 u, , 0 u, drop H ; |
by Create |
by User |
Builder 2User |
Builder 2User |
|
|
Build: T 0 A, H ; |
Build: T 0 au, , H ; |
by Create |
by User |
Builder AUser |
Builder AUser |
|
|
Build: ( n -- ) T , H ; |
Build: ( n -- ) T , H ; |
Line 771 only forth also minimal definitions
|
Line 790 only forth also minimal definitions
|
: decimal decimal ; |
: decimal decimal ; |
: hex hex ; |
: hex hex ; |
|
|
|
: tudp T tudp H ; |
|
: tup T tup H ; minimal |
|
|
\ for debugging... |
\ for debugging... |
: order order ; |
: order order ; |