version 1.2, 1994/05/03 15:24:11
|
version 1.9, 1994/07/21 10:52:37
|
Line 21
|
Line 21
|
\ targets 09jun93jaw |
\ targets 09jun93jaw |
\ added: 2user and value 11jun93jaw |
\ added: 2user and value 11jun93jaw |
|
|
include other.fs \ ansforth extentions for cross |
\ include other.fs \ ansforth extentions for cross |
|
|
decimal |
|
|
|
\ number? 11may93jaw |
|
|
|
\ checks for +, -, $, & ... |
|
: leading? ( c-addr u -- c-addr u doubleflag negflag base ) |
|
2dup 1- chars + c@ [char] . = \ process double |
|
IF dup 1 chars = IF over 1 swap c! false ELSE 1 chars - true THEN |
|
\ only if more than only . ( may be number output! ) |
|
\ if only . => store garbage |
|
ELSE false THEN >r \ numbers |
|
false -rot base @ -rot |
|
BEGIN over c@ |
|
dup [char] - = |
|
IF drop >r >r >r |
|
drop true r> r> r> 0 THEN |
|
dup [char] + = |
|
IF drop 0 THEN |
|
dup [char] $ = |
|
IF drop >r >r drop 16 r> r> 0 THEN |
|
dup [char] & = |
|
IF drop >r >r drop 10 r> r> 0 THEN |
|
0= IF 1 chars - swap char+ swap false ELSE true THEN |
|
over 0= or |
|
UNTIL |
|
rot >r rot r> r> -rot ; |
|
|
|
: number? ( c-addr -- n/d flag ) |
|
\ return -1 if cell 1 if double 0 if garbage |
|
0 swap 0 swap \ create double number |
|
count leading? |
|
base @ >r base ! |
|
>r >r |
|
>number IF 2drop false r> r> 2drop |
|
r> base ! EXIT THEN |
|
drop r> r> |
|
IF IF dnegate 1 |
|
ELSE drop negate -1 THEN |
|
ELSE IF 1 ELSE drop -1 THEN |
|
THEN r> base ! ; |
|
|
|
|
: comment? ( c-addr u -- c-addr u ) |
|
2dup s" (" compare 0= |
|
IF postpone ( |
|
ELSE 2dup s" \" compare 0= IF postpone \ THEN |
|
THEN ; |
|
|
|
decimal |
|
|
\ Begin CROSS COMPILER: |
\ Begin CROSS COMPILER: |
|
|
Line 117 Variable bit$
|
Line 82 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 135 include machine.fs
|
Line 93 include machine.fs
|
: cell+ cell + ; |
: cell+ cell + ; |
: cells cell<< lshift ; |
: cells cell<< lshift ; |
: chars ; |
: chars ; |
|
: floats float * ; |
|
|
>CROSS |
>CROSS |
: cell/ cell<< rshift ; |
: cell/ cell<< rshift ; |
>TARGET |
>TARGET |
Line 144 include machine.fs
|
Line 103 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 121 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 147 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 204 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 167 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
: ! ( w taddr -- ) >r bswap r> >image ! ; |
: ! ( w taddr -- ) >r bswap r> >image ! ; |
: c@ ( taddr -- char ) >image c@ ; |
: c@ ( taddr -- char ) >image c@ ; |
: c! ( char taddr -- ) >image c! ; |
: c! ( char taddr -- ) >image c! ; |
|
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; |
|
: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ; |
|
|
\ Target compilation primitives 06oct92py |
\ Target compilation primitives 06oct92py |
\ included A! 16may93jaw |
\ included A! 16may93jaw |
Line 228 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 193 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 231 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 342 VARIABLE ^imm
|
Line 309 VARIABLE ^imm
|
^imm @ @ dup <imm> = ?EXIT |
^imm @ @ dup <imm> = ?EXIT |
<res> <> ABORT" CROSS: Cannot immediate a unresolved word" |
<res> <> ABORT" CROSS: Cannot immediate a unresolved word" |
<imm> ^imm @ ! ; |
<imm> ^imm @ ! ; |
: restrict ; |
: restrict 40 flag! ; |
>CROSS |
>CROSS |
|
|
\ ALIAS2 ansforth conform alias 9may93jaw |
\ ALIAS2 ansforth conform alias 9may93jaw |
Line 416 ghost unloop ghost ;S
|
Line 383 ghost unloop ghost ;S
|
ghost lit ghost (compile) ghost ! 2drop drop |
ghost lit ghost (compile) ghost ! 2drop drop |
ghost (;code) ghost noop 2drop |
ghost (;code) ghost noop 2drop |
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
|
ghost ' |
|
|
\ compile 10may93jaw |
\ compile 10may93jaw |
|
|
Line 483 Cond: [Char] ( "<char>" -- ) restrict
|
Line 451 Cond: [Char] ( "<char>" -- ) restrict
|
|
|
Cond: EXIT ( -- ) restrict? compile ;S ;Cond |
Cond: EXIT ( -- ) restrict? compile ;S ;Cond |
|
|
|
Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond |
|
|
Cond: ; ( -- ) restrict? |
Cond: ; ( -- ) restrict? |
depth ?dup IF 1- <> ABORT" CROSS: Stack changed" |
depth ?dup IF 1- <> ABORT" CROSS: Stack changed" |
ELSE true ABORT" CROSS: Stack empty" THEN |
ELSE true ABORT" CROSS: Stack empty" THEN |
Line 515 Cond: DOES> restrict?
|
Line 485 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 532 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 658 Cond: ABORT" restrict? compile (ABORT
|
Line 642 Cond: ABORT" restrict? compile (ABORT
|
|
|
Cond: IS T ' >body H compile ALiteral compile ! ;Cond |
Cond: IS T ' >body H compile ALiteral compile ! ;Cond |
: IS T ' >body ! H ; |
: IS T ' >body ! H ; |
|
Cond: TO T ' >body H compile ALiteral compile ! ;Cond |
|
: TO T ' >body ! H ; |
|
|
\ LINKED ERR" ENV" 2ENV" 18may93jaw |
\ LINKED ERR" ENV" 2ENV" 18may93jaw |
|
|
Line 771 only forth also minimal definitions
|
Line 757 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 ; |