Re: Fleet Forth design considerations
Posted: Thu Apr 11, 2019 1:56 am
Add a vote for the "comment style" from me as well.
Code: Select all
: IS ( -- )
' DUP @
DUP [ ' #BUF @ ] LITERAL <>
SWAP [ ' TYPE @ ] LITERAL <> AND
ABORT" CAN'T SET"
STATE @
IF COMPILE (IS) , EXIT THEN
>BODY ! ; IMMEDIATE
Code: Select all
SCR# 41
// DJIFFIES
HEX
// TAKES POSITIVE DOUBLE NUMBER
// AND DELAYS THAT MANY JIFFIES
: DJIFFIES ( D+ -- )
JIFFY@ DROP
BEGIN
PAUSE
JIFFY@ DROP DUP>R -
// COMPENSATE FOR RESET AT 24 HOURS
0 MIN
S>D D+ R> OVER 0<
UNTIL
DROP 2DROP ;
SCR# 42
// JIFFIES
HEX
: JIFFIES ( U -- )
0 DJIFFIES ;
Code: Select all
OK
VARIABLE COUNTER OK
CODE UPCOUNT OK
COUNTER INC, OK
0= IF, COUNTER 1+ INC, THEN, OK
NEXT JMP, END-CODE OK
SEE UPCOUNT
UPCOUNT
22473 22457 INC ' COUNTER >BODY
22476 22481 BNE
22478 22458 INC ' COUNTER >BODY 1 +
22481 2111 JMP NEXT
OK
: TEST
COUNTER OFF
['] UPCOUNT IS PAUSE
100 JIFFIES
SINGLE ; OK
TEST COUNTER ? 1604 OK
CONSOLE
Code: Select all
: (TYPE) ( ADR CNT -- )
<TYPE> PAUSE ;
Code: Select all
: (PTYPE) ( ADR CNT -- )
#LP (CHKOUT) IOERR // SEND TO PRINTER
(TYPE) ;
Code: Select all
SCR# 29
// SYSTEM DEFERRED WORDS & KIN
HEX
// MULTITASKING
DEFER PAUSE ' NOOP IS PAUSE
DEFER ?KEY
DEFER EXPECT
DEFER EMIT
: TYPE (TYPE) PAUSE ;
// QUOTE TYPE
: QTYPE (QTYPE) PAUSE ;
// INITIAL CODE TO BE EXECUTED
DEFER INITIAL ' NOOP IS INITIAL
DEFER ERR ' NOOP IS ERR
DEFER VALID?
DEFER DR/W
DEFER RR/W
Code: Select all
SCR# 38
// CONSOLE PRINTER
HEX
: CONSOLE ( -- )
#LP CLOSE CLRCHN
['] (EMIT) IS EMIT
['] (TYPE) (IS) TYPE
['] (QTYPE) (IS) QTYPE
[ HERE >A ]
['] (EXPECT) IS EXPECT ;
: PRINTER ( -- )
#LP CLOSE
0 0 #LP DUP #LP2 (OPEN) IOERR
['] (PEMIT) IS EMIT
['] (PTYPE) (IS) TYPE
['] (PQTYPE) (IS) QTYPE
BRANCH [ A> , ] ; -2 ALLOT
SCR# 39
// LOGGER
HEX
: LOGGER ( -- )
PRINTER
['] (LEMIT) IS EMIT
['] (LTYPE) (IS) TYPE
['] (LQTYPE) (IS) QTYPE
['] (LEXPECT) IS EXPECT ;
Code: Select all
: DEFER: ( -- COLON-SYS )
: COMPILE -SET ;CODE
DO-COLON JMP, END-CODE
Code: Select all
: -SET2
R> // REMOVE ONE LEVEL OF NESTING
BRANCH [ ' -SET >BODY , ] ; // AND BRANCH TO THE BODY OF -SET
-2 ALLOT // RECLAIM MEMORY USED BY UNNEEDED EXIT
: DEFER: ( -- SYS )
: COMPILE -SET2 ;CODE
' : @ JMP, END-CODE
Code: Select all
: DEFER: ( -- SYS )
: COMPILE -SET2 ;
Code: Select all
// TRUNCATING
SQRT ( UD -- U )
DSQRT ( UQ -- UD )
// ROUNDING
SQRT ( UD -- U )
DSQRT ( UQ -- UD )
Code: Select all
// TRUNCATING
SQRT ( UD -- U )
DSQRT ( UQ -- UD )
// ROUNDING
SQRT ( UD -- UD )
DSQRT ( UQ -- UQ )
Code: Select all
// TRUNCATING
SQRT ( UD -- UD )
DSQRT ( UQ -- UQ )
// ROUNDING
SQRT ( UD -- UD )
DSQRT ( UQ -- UQ )
Code: Select all
HEX
CODE SQRT ( UD -- U )
TYA, 5 # LDY,
BEGIN, N ,Y STA, DEY,
0< UNTIL,
10 # LDY,
BEGIN,
2 ,X ASL, 3 ,X ROL,
0 ,X ROL, 1 ,X ROL,
N ROL, N 1+ ROL,
N 2+ ROL,
2 ,X ASL, 3 ,X ROL,
0 ,X ROL, 1 ,X ROL,
N ROL, N 1+ ROL,
N 2+ ROL,
N 3 + ASL, N 4 + ROL,
N 5 + ROL, SEC,
N 3 + ROL, N 4 + ROL,
N 5 + ROL, SEC,
N LDA, N 3 + SBC,
N 1+ LDA, N 4 + SBC,
N 2+ LDA, N 5 + SBC,
CS IF,
N LDA, N 3 + SBC, N STA,
N 1+ LDA, N 4 + SBC, N 1+ STA,
N 2+ LDA, N 5 + SBC, N 2+ STA,
N 3 + LDA, 2 # ORA, N 3 + STA,
THEN,
N 5 + LSR,
N 4 + ROR, N 3 + ROR,
DEY,
0= UNTIL,
N 3 + LDA, 2 ,X STA,
N 4 + LDA, 3 ,X STA,
POP JMP,
END-CODE
Code: Select all
HEX
CODE SQRTR ( UD -- U )
TYA, 5 # LDY,
BEGIN, N ,Y STA, DEY,
0< UNTIL,
11 # LDY,
BEGIN,
2 ,X ASL, 3 ,X ROL,
0 ,X ROL, 1 ,X ROL,
N ROL, N 1+ ROL,
N 2+ ROL,
2 ,X ASL, 3 ,X ROL,
0 ,X ROL, 1 ,X ROL,
N ROL, N 1+ ROL,
N 2+ ROL,
N 3 + ASL, N 4 + ROL,
N 5 + ROL, SEC,
N 3 + ROL, N 4 + ROL,
N 5 + ROL, SEC,
N LDA, N 3 + SBC,
N 1+ LDA, N 4 + SBC,
N 2+ LDA, N 5 + SBC,
CS IF,
N LDA, N 3 + SBC, N STA,
N 1+ LDA, N 4 + SBC, N 1+ STA,
N 2+ LDA, N 5 + SBC, N 2+ STA,
N 3 + LDA, 2 # ORA, N 3 + STA,
THEN,
N 5 + LSR,
N 4 + ROR, N 3 + ROR,
DEY,
0= UNTIL,
N 5 + LSR,
N 4 + ROR, N 3 + ROR,
N 3 + LDA, 0 # ADC,
2 ,X STA,
N 4 + LDA, 0 # ADC,
3 ,X STA,
POP JMP,
END-CODE
Code: Select all
HEX
CODE SQRTR ( UD -- UD2 )
TYA, 5 # LDY,
BEGIN, N ,Y STA, DEY,
0< UNTIL,
11 # LDY,
BEGIN,
2 ,X ASL, 3 ,X ROL,
0 ,X ROL, 1 ,X ROL,
N ROL, N 1+ ROL,
N 2+ ROL,
2 ,X ASL, 3 ,X ROL,
0 ,X ROL, 1 ,X ROL,
N ROL, N 1+ ROL,
N 2+ ROL,
N 3 + ASL, N 4 + ROL,
N 5 + ROL, SEC,
N 3 + ROL, N 4 + ROL,
N 5 + ROL, SEC,
N LDA, N 3 + SBC,
N 1+ LDA, N 4 + SBC,
N 2+ LDA, N 5 + SBC,
CS IF,
N LDA, N 3 + SBC, N STA,
N 1+ LDA, N 4 + SBC, N 1+ STA,
N 2+ LDA, N 5 + SBC, N 2+ STA,
N 3 + LDA, 2 # ORA, N 3 + STA,
THEN,
N 5 + LSR,
N 4 + ROR, N 3 + ROR,
DEY,
0= UNTIL,
N 5 + LSR,
N 4 + ROR, N 3 + ROR,
N 3 + LDA, 0 # ADC,
2 ,X STA,
N 4 + LDA, 0 # ADC,
3 ,X STA,
N 5 + LDA, 0 # ADC,
0 ,X STA,
0 # LDA, 1 ,X STA,
NEXT JMP,
END-CODE