6502/VolksForth
1
0
Fork 0
mirror of https://github.com/forth-ev/VolksForth.git synced 2024-11-22 20:34:07 +00:00
Code Issues Projects Releases Wiki Activity
4660d4594d
VolksForth/sources/Apple1/6502f83.fth

2245 lines
138 KiB
Forth
Raw Normal View History

Apple 1 sources
2020-08-25 16:55:03 +00:00
\ *** Block No. 0 Hexblock 0
ende 123
\ *** Block No. 1 Hexblock 1
\ volksFORTH Loadscreen cas2013apr05
forth definitions
: (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE
$0300 CONSTANT BASEADDR \ base address of forth image
$7F00 CONSTANT TOPADDR
BASEADDR DISPLACE !
TARGET DEFINITIONS BASEADDR HERE!
hex &01 &126 +THRU
decimal
\ ASSEMBLER NONRELOCATE
.UNRESOLVED \ if this prints unresolved
\ definitions, check code
CR .( SAVE-TARGET 6502-FORTH83)
\ *** Block No. 2 Hexblock 2
\ FORTH PREAMBLE AND ID cas20130405
ASSEMBLER
NOP 0 JMP HERE 2- >LABEL >COLD
NOP 0 JMP HERE 2- >LABEL >RESTART
HERE DUP ORIGIN!
\ *** Block No. 3 Hexblock 3
\ Coldstartvalues and user variables cas2013apr05
\
0 JMP 0 JSR HERE 2- >LABEL >WAKE
END-CODE
0D6 ALLOT
\ Bootlabel
," VolksForth-83 3.8 COMPILED 05apr13CS"
\ *** Block No. 4 Hexblock 4
\ ZERO PAGE VARIABLES & NEXT cas 26jan06
\ adjust this to match your architecture
20 DUP >LABEL RP 2+
DUP >LABEL UP 2+
DUP >LABEL PUTA 1+
DUP >LABEL SP 2+
DUP >LABEL NEXT
DUP 5 + >LABEL IP
13 + >LABEL W
W 8 + >LABEL N
\ *** Block No. 5 Hexblock 5
\ NEXT, MOVED INTO ZERO PAGE 08APR85BP)
LABEL BOOTNEXT
-1 STA \ -1 IS DUMMY SP
IP )Y LDA W 1+ STA
-1 LDA W STA \ -1 IS DUMMY IP
CLC IP LDA 2 # ADC IP STA
CS NOT ?[ LABEL WJMP -1 ) JMP ]?
IP 1+ INC WJMP BCS END-CODE
\ *** Block No. 6 Hexblock 6
\ Bootnext and Endtrace cas 26jan06
HERE BOOTNEXT - >LABEL BOOTNEXTLEN
CODE END-TRACE ( PATCH NEXT FOR TRACE )
0A5 # LDA NEXT 0A + STA
IP # LDA NEXT 0B + STA
069 # LDA NEXT 0C + STA
02 # LDA NEXT 0D + STA
NEXT JMP END-CODE
\ *** Block No. 7 Hexblock 7
\ ;C: NOOP cas 26jan06
CREATE RECOVER ASSEMBLER
PLA W STA PLA W 1+ STA
W WDEC 0 JMP END-CODE
HERE 2- >LABEL >RECOVER
\ manual forward reference for JMP command
COMPILER ASSEMBLER ALSO DEFINITIONS
H : ;C: 0 T RECOVER JSR
END-CODE ] H ;
TARGET
CODE NOOP NEXT HERE 2- ! END-CODE
\ *** Block No. 8 Hexblock 8
\ USER VARIABLES cas2013apr05
CONSTANT ORIGIN 8 UALLOT DROP
\ FOR MULTITASKER
\ Adjust memory values for data stack and return stack here
USER S0 TOPADDR $F00 - S0 ! USER R0 TOPADDR $480 - R0 !
USER DP USER OFFSET 0 OFFSET !
USER BASE &10 BASE ! USER OUTPUT
USER INPUT
USER ERRORHANDLER \ POINTER FOR ABORT" -CODE
USER VOC-LINK
USER UDP \ POINTS TO NEXT FREE ADDR IN USER
\ *** Block No. 9 Hexblock 9
\ MANIPULATE SYSTEM POINTERS 29JAN85BP)
CODE SP@ ( -- ADDR)
SP LDA N STA SP 1+ LDA N 1+ STA
N # LDX
LABEL XPUSH
SP 2DEC 1 ,X LDA SP )Y STA
0 ,X LDA 0 # LDX PUTA JMP END-CODE
CODE SP! ( ADDR --)
SP X) LDA TAX SP )Y LDA
SP 1+ STA SP STX 0 # LDX
NEXT JMP END-CODE
\ *** Block No. 10 Hexblock A
\ UP@ UP! XPULL (XYDROP (DROP cas 26jan06
CODE UP@ ( -- ADDR)
UP # LDX XPUSH JMP END-CODE
CODE UP! ( ADDR --) UP # LDX
LABEL XPULL SP )Y LDA 1 ,X STA
DEY SP )Y LDA 0 ,X STA
LABEL (XYDROP 0 # LDX 1 # LDY
LABEL (DROP SP 2INC NEXT JMP
END-CODE RESTRICT
\ *** Block No. 11 Hexblock B
\ MANIPULATE RETURNSTACK 16FEB85BP/KS)
CODE RP@ ( -- ADDR )
RP # LDX XPUSH JMP END-CODE
CODE RP! ( ADDR -- )
RP # LDX XPULL JMP END-CODE RESTRICT
CODE >R ( 16B -- )
RP 2DEC SP X) LDA RP X) STA
SP )Y LDA RP )Y STA (DROP JMP
END-CODE RESTRICT
\ *** Block No. 12 Hexblock C
\ R> (RDROP (NRDROP cas 26jan06
CODE R> ( -- 16B)
SP 2DEC RP X) LDA SP X) STA
RP )Y LDA SP )Y STA
LABEL (RDROP 2 # LDA
LABEL (NRDROP CLC RP ADC RP STA
CS ?[ RP 1+ INC ]?
NEXT JMP END-CODE RESTRICT
\ *** Block No. 13 Hexblock D
\ R@ RDROP EXIT ?EXIT 08APR85BP)
CODE R@ ( -- 16B)
SP 2DEC RP )Y LDA SP )Y STA
RP X) LDA PUTA JMP
END-CODE
CODE RDROP (RDROP HERE 2- !
END-CODE RESTRICT
CODE EXIT
RP X) LDA IP STA
RP )Y LDA IP 1+ STA
(RDROP JMP END-CODE
\ *** Block No. 14 Hexblock E
\ EXECUTE PERFORM 08APR85BP)
CODE ?EXIT ( FLAG -- )
SP X) LDA SP )Y ORA
PHP SP 2INC PLP
' EXIT @ BNE NEXT JMP
END-CODE
CODE EXECUTE ( ADDR --)
SP X) LDA W STA
SP )Y LDA W 1+ STA
SP 2INC W 1- JMP END-CODE
: PERFORM ( ADDR -- ) @ EXECUTE ;
\ *** Block No. 15 Hexblock F
\ C@ C! CTOGGLE 10JAN85BP)
CODE C@ ( ADDR -- 8B)
SP X) LDA N STA SP )Y LDA N 1+ STA
LABEL (C@ 0 # LDA SP )Y STA
N X) LDA PUTA JMP END-CODE
CODE C! ( 16B ADDR --)
SP X) LDA N STA SP )Y LDA N 1+ STA
INY SP )Y LDA N X) STA DEY
LABEL (2DROP
SP LDA CLC 4 # ADC SP STA
CS ?[ SP 1+ INC ]?
NEXT JMP END-CODE
\ *** Block No. 16 Hexblock 10
\ @ ! +! 08APR85BP) er14dez88
: CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ;
CODE @ ( ADDR -- 16B)
SP X) LDA N STA SP )Y LDA N 1+ STA
N )Y LDA SP )Y STA
N X) LDA PUTA JMP END-CODE
CODE ! ( 16B ADDR --)
SP X) LDA N STA SP )Y LDA N 1+ STA
INY SP )Y LDA N X) STA
INY SP )Y LDA 1 # LDY
LABEL (!
N )Y STA (2DROP JMP END-CODE
\ *** Block No. 17 Hexblock 11
\ +! DROP cas 26jan06
CODE +! ( N ADDR --)
SP X) LDA N STA SP )Y LDA N 1+ STA
INY SP )Y LDA CLC N X) ADC N X) STA
INY SP )Y LDA 1 # LDY N )Y ADC
(! JMP END-CODE
CODE DROP ( 16B --)
(DROP HERE 2- ! END-CODE
\ *** Block No. 18 Hexblock 12
\ SWAP cas 26jan06
CODE SWAP ( 16B1 16B2 -- 16B2 16B1 )
SP )Y LDA TAX
3 # LDY SP )Y LDA N STA
TXA SP )Y STA
N LDA 1 # LDY SP )Y STA
INY 0 # LDX
SP )Y LDA N STA SP X) LDA SP )Y STA
DEY
N LDA PUTA JMP END-CODE
\ *** Block No. 19 Hexblock 13
\ DUP ?DUP 08MAY85BP) cas 26jan06
CODE DUP ( 16B -- 16B 16B)
SP 2DEC
3 # LDY SP )Y LDA 1 # LDY SP )Y STA
INY SP )Y LDA DEY
PUTA JMP END-CODE
CODE ?DUP ( 16B -- 16B 16B / FALSE)
SP X) LDA SP )Y ORA
0= ?[ NEXT JMP ]?
' DUP @ JMP END-CODE
\\ ?DUP and DUP in FORTH
\ : ?DUP ( 16B -- 16B 16B / FALSE)
\ DUP IF DUP THEN ;
\ : DUP SP@ @ ;
\ *** Block No. 20 Hexblock 14
\ OVER ROT 13JUN84KS) cas 26jan06
CODE OVER ( 16B1 16B2 - 16B1 16B3 16B1)
SP 2DEC 4 # LDY SP )Y LDA SP X) STA
INY SP )Y LDA 1 # LDY SP )Y STA
NEXT JMP END-CODE
\\ ROT OVER in FORTH
\ : ROT >R SWAP R> SWAP ;
\ : OVER >R DUP R> SWAP ;
\ *** Block No. 21 Hexblock 15
\ ROT cas 26jan06
CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1)
3 # LDY SP )Y LDA N 1+ STA
1 # LDY SP )Y LDA 3 # LDY SP )Y STA
5 # LDY SP )Y LDA N STA
N 1+ LDA SP )Y STA
1 # LDY N LDA SP )Y STA
INY SP )Y LDA N 1+ STA
SP X) LDA SP )Y STA
4 # LDY SP )Y LDA SP X) STA
N 1+ LDA SP )Y STA
1 # LDY NEXT JMP END-CODE
\ *** Block No. 22 Hexblock 16
\ -ROT NIP UNDER PICK ROLL 24DEC83KS) cas 26jan06
: -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2)
ROT ROT ;
: NIP ( 16B1 16B2 -- 16B2) SWAP DROP ;
: UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ;
: PICK ( N -- 16B.N ) 1+ 2* SP@ + @ ;
: ROLL ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ;
\\ : -ROLL ( N --)
>R DUP SP@ DUP 2+ DUP 2+ SWAP
R@ 2* CMOVE R> 1+ 2* + ! ;
\ *** Block No. 23 Hexblock 17
\ DOUBLE WORD STACK MANIP. 21APR83KS)
: 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ;
CODE 2DROP ( 32B -- )
(2DROP HERE 2- ! END-CODE
: 2DUP ( 32B -- 32B 32B) OVER OVER ;
\ : 2DROP ( 32B -- ) DROP DROP ;
\ *** Block No. 24 Hexblock 18
\ + AND OR XOR 08APR85BP)
COMPILER ASSEMBLER ALSO DEFINITIONS
H : DYADOP ( OPCODE --) T
INY SP X) LDA DUP C, SP C, SP )Y STA
DEY SP )Y LDA 3 # LDY C, SP C, SP )Y STA
(XYDROP JMP H ;
TARGET
CODE + ( N1 N2 -- N3) CLC 071 DYADOP END-CODE
CODE OR ( 16B1 16B2 -- 16B3) 011 DYADOP END-CODE
CODE AND ( 16B1 16B2 -- 16B3) 031 DYADOP END-CODE
CODE XOR ( 16B1 16B2 -- 16B3) 051 DYADOP END-CODE
\ *** Block No. 25 Hexblock 19
\ - NOT NEGATE 24DEC83KS)
CODE - ( N1 N2 -- N3)
INY SP )Y LDA SEC SP X) SBC SP )Y STA INY SP )Y LDA
1 # LDY SP )Y SBC 3 # LDY SP )Y STA (XYDROP JMP END-CODE
CODE NOT ( 16B1 -- 16B2) CLC
LABEL (NOT TXA SP X) SBC SP X) STA TXA SP )Y SBC SP )Y STA
NEXT JMP END-CODE
CODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE
\ : - NEGATE + ;
\ *** Block No. 26 Hexblock 1A
\ DNEGATE SETUP D+ 14JUN84KS)
CODE DNEGATE ( D1 -- -D1)
INY SEC
TXA SP )Y SBC SP )Y STA INY
TXA SP )Y SBC SP )Y STA
TXA SP X) SBC SP X) STA 1 # LDY
TXA SP )Y SBC SP )Y STA
NEXT JMP END-CODE
LABEL SETUP ( QUAN IN A)
.A ASL TAX TAY DEY
[[ SP )Y LDA N ,Y STA DEY 0< ?]
TXA CLC SP ADC SP STA
CS ?[ SP 1+ INC ]?
0 # LDX 1 # LDY RTS END-CODE
\ *** Block No. 27 Hexblock 1B
\ D+ cas 26jan06
CODE D+ ( D1 D2 -- D3)
2 # LDA SETUP JSR INY
SP )Y LDA CLC N 2+ ADC SP )Y STA INY
SP )Y LDA N 3 + ADC SP )Y STA
SP X) LDA N ADC SP X) STA 1 # LDY
SP )Y LDA N 1+ ADC SP )Y STA
NEXT JMP END-CODE
\ *** Block No. 28 Hexblock 1C
\ 1+ 2+ 3+ 1- 2- 08APR85BP)
CODE 1+ ( N1 -- N2) 1 # LDA
LABEL N+ CLC SP X) ADC
CS NOT ?[ PUTA JMP ]?
SP X) STA SP )Y LDA 0 # ADC SP )Y STA
NEXT JMP END-CODE
CODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE
CODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE
| CODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE
| CODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE
\ *** Block No. 29 Hexblock 1D
\ NUMBER CONSTANTS 24DEC83KS)
CODE 1- ( N1 -- N2) SEC
LABEL (1- SP X) LDA 1 # SBC
CS ?[ PUTA JMP ]?
SP X) STA SP )Y LDA 0 # SBC SP )Y STA
NEXT JMP END-CODE
CODE 2- ( N1 -- N2) CLC (1- BCC END-CODE
-1 CONSTANT TRUE 0 CONSTANT FALSE
' TRUE ALIAS -1 ' FALSE ALIAS 0
1 CONSTANT 1 2 CONSTANT 2
3 CONSTANT 3 4 CONSTANT 4
: ON ( ADDR -- ) TRUE SWAP ! ;
: OFF ( ADDR -- ) FALSE SWAP ! ;
\ *** Block No. 30 Hexblock 1E
\ WORDS FOR NUMBER LITERALS 24MAY84KS) cs08aug05
CODE CLIT ( -- 8B)
SP 2DEC IP X) LDA SP X) STA TXA SP )Y STA IP WINC
NEXT JMP END-CODE RESTRICT
CODE LIT ( -- 16B)
SP 2DEC IP )Y LDA SP )Y STA IP X) LDA SP X) STA
LABEL (BUMP IP 2INC NEXT JMP END-CODE RESTRICT
: LITERAL ( 16B --) DUP 0FF00 AND
IF COMPILE LIT , EXIT THEN COMPILE CLIT C, ;
IMMEDIATE RESTRICT
\\ : LIT R> DUP 2+ >R @ ;
: CLIT R> DUP 1+ >R C@ ;
\ *** Block No. 31 Hexblock 1F
\ COMPARISION CODE WORDS 13JUN84KS)
CODE 0< ( N -- FLAG) SP )Y LDA 0< ?[
LABEL PUTTRUE 0FF # LDA 024 C, ]?
LABEL PUTFALSE TXA SP )Y STA
PUTA JMP END-CODE
CODE 0= ( 16B -- FLAG)
SP X) LDA SP )Y ORA PUTTRUE BEQ PUTFALSE BNE END-CODE
CODE UWITHIN ( U1 [LOW UP[ -- FLAG)
2 # LDA SETUP JSR 1 # LDY SP X) LDA N CMP
SP )Y LDA N 1+ SBC
CS NOT ?[ ( N>SP) SP X) LDA N 2+ CMP
SP )Y LDA N 3 + SBC
PUTTRUE BCS ]?
PUTFALSE JMP END-CODE
\ *** Block No. 32 Hexblock 20
\ COMPARISION CODE WORDS 13JUN84KS)
CODE < ( N1 N2 -- FLAG)
SP X) LDA N STA SP )Y LDA N 1+ STA
SP 2INC
N 1+ LDA SP )Y EOR ' 0< @ BMI
SP X) LDA N CMP SP )Y LDA N 1+ SBC
' 0< @ 2+ JMP END-CODE
CODE U< ( U1 U2 -- FLAG)
SP X) LDA N STA SP )Y LDA N 1+ STA
SP 2INC
SP X) LDA N CMP SP )Y LDA N 1+ SBC
CS NOT ?[ PUTTRUE JMP ]?
PUTFALSE JMP END-CODE
\ *** Block No. 33 Hexblock 21
\ COMPARISION WORDS 24DEC83KS)
| : 0< 8000 AND 0<> ;
: > ( N1 N2 -- FLAG) SWAP < ;
: 0> ( N -- FLAG) NEGATE 0< ;
: 0<> ( N -- FLAG) 0= NOT ;
: U> ( U1 U2 -- FLAG) SWAP U< ;
: = ( N1 N2 -- FLAG) - 0= ;
: D0= ( D -- FLAG) OR 0= ;
: D= ( D1 D2 -- FLAG) DNEGATE D+ D0= ;
: D< ( D1 D2 -- FLAG) ROT 2DUP -
IF > NIP NIP ELSE 2DROP U< THEN ;
\ *** Block No. 34 Hexblock 22
\ MIN MAX UMAX UMIN EXTEND DABS ABS cas 26jan06
| : MINIMAX ( N1 N2 FLAG -- N3)
RDROP IF SWAP THEN DROP ;
: MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; -2 ALLOT
: MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; -2 ALLOT
: UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; -2 ALLOT
: UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; -2 ALLOT
: EXTEND ( N -- D) DUP 0< ;
: DABS ( D -- UD) EXTEND IF DNEGATE THEN ;
: ABS ( N -- U) EXTEND IF NEGATE THEN ;
\ *** Block No. 35 Hexblock 23
\ LOOP PRIMITIVES 08FEB85BP/KS)
| : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ;
: (DO ( LIMIT STAR -- ) OVER - DODO ; -2 ALLOT RESTRICT
: (?DO ( LIMIT START -- )
OVER - ?DUP IF DODO THEN R> DUP @ + >R DROP ; RESTRICT
: BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ;
CODE ENDLOOP 6 # LDA (NRDROP JMP END-CODE RESTRICT
\\ DODO PUTS "INDEX \ LIMIT \
ADR.OF.DO" ON RETURN-STACK
\ *** Block No. 36 Hexblock 24
\ (LOOP (+LOOP 08APR85BP)
CODE (LOOP
CLC 1 # LDA RP X) ADC RP X) STA
CS ?[ RP )Y LDA 0 # ADC RP )Y STA
CS ?[ NEXT JMP ]? ]?
LABEL DOLOOP 5 # LDY
RP )Y LDA IP 1+ STA DEY
RP )Y LDA IP STA 1 # LDY
NEXT JMP END-CODE RESTRICT
CODE (+LOOP
CLC SP X) LDA RP X) ADC RP X) STA
SP )Y LDA RP )Y ADC RP )Y STA
.A ROR SP )Y EOR
PHP SP 2INC PLP DOLOOP BPL
NEXT JMP END-CODE RESTRICT
\ *** Block No. 37 Hexblock 25
\ LOOP INDICES 08APR85BP)
CODE I ( -- N) 0 # LDY
LABEL LOOPINDEX SP 2DEC CLC
RP )Y LDA INY INY
RP )Y ADC SP X) STA DEY
RP )Y LDA INY INY
RP )Y ADC 1 # LDY SP )Y STA
NEXT JMP END-CODE RESTRICT
CODE J ( -- N)
6 # LDY LOOPINDEX BNE
END-CODE RESTRICT
\ *** Block No. 38 Hexblock 26
\ BRANCHING 24DEC83KS)
CODE BRANCH
CLC IP LDA IP X) ADC N STA
IP 1+ LDA IP )Y ADC IP 1+ STA N LDA IP STA
NEXT JMP END-CODE RESTRICT
CODE ?BRANCH
SP X) LDA SP )Y ORA PHP SP 2INC PLP
' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT
\\ : BRANCH R> DUP @ + >R ; RESTRICT
: ?BRANCH
0= R> OVER NOT OVER 2+ AND -ROT
DUP @ + AND OR >R ; RESTRICT
\ *** Block No. 39 Hexblock 27
\ RESOLVE LOOPS AND BRANCHES 03FEB85BP)
: >MARK ( -- ADDR) HERE 0 , ;
: >RESOLVE ( ADDR --) HERE OVER - SWAP ! ;
: <MARK ( -- ADDR) HERE ;
: <RESOLVE ( ADDR --) HERE - , ;
: ?PAIRS ( N1 N2 -- ) - ABORT" UNSTRUCTURED" ;
\ *** Block No. 40 Hexblock 28
\ CASE? 04MAY85BP)
LABEL PUSHA
0 # CMP 0< ?[ PHA 0FF # LDA ][
LABEL PUSH0A PHA 0 # LDA ]?
LABEL PUSH TAX SP 2DEC
TXA 1 # LDY SP )Y STA
PLA 0 # LDX PUTA JMP
CODE CASE?
( 16B1 16B2 -- 16B1 FALSE / TRUE )
1 # LDA SETUP JSR N LDA SP X) CMP
0= ?[ N 1+ LDA SP )Y CMP 0= ?[ PUTTRUE JMP ]? ]?
TXA PUSH0A JMP END-CODE
\\ : CASE?
( 16B1 16B2 -- 16B1 FALSE / TRUE ) OVER = DUP IF NIP THEN ;
\ *** Block No. 41 Hexblock 29
\ BRANCHING 03FEB85BP)
: IF COMPILE ?BRANCH >MARK 1 ; IMMEDIATE RESTRICT
: THEN ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT
: ELSE 1 ?PAIRS COMPILE BRANCH >MARK
SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT
: BEGIN <MARK 2 ; IMMEDIATE RESTRICT
: WHILE 2 ?PAIRS 2 COMPILE ?BRANCH
>MARK -2 2SWAP ; IMMEDIATE RESTRICT
| : (REPTIL <RESOLVE BEGIN DUP -2
= WHILE DROP >RESOLVE REPEAT ;
: REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT
: UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT
\ *** Block No. 42 Hexblock 2A
\ LOOPS 29JAN85KS/BP)
: DO COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT
: ?DO COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT
: LOOP 3 ?PAIRS COMPILE (LOOP
COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT
: +LOOP 3 ?PAIRS COMPILE (+LOOP
COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT
: LEAVE ENDLOOP R> 2- DUP @ + >R ; RESTRICT
\\ RETURNSTACK: CALLADR \ INDEX
LIMIT \ ADR OF DO
\ *** Block No. 43 Hexblock 2B
\ UM* BP/KS13.2.85)
CODE UM* ( U1 U2 -- UD)
SP )Y LDA N STA SP X) LDA N 1+ STA
INY N 2 + STX N 3 + STX 010 # LDX
[[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL
CS ?[ CLC SP )Y LDA N 3 + ADC N 3 + STA
INY SP )Y LDA DEY N 2 + ADC N 2 + STA
CS ?[ N 1+ INC 0= ?[ N INC ]? ]? ]?
DEX 0= ?]
N 3 + LDA SP )Y STA INY N 2 + LDA SP )Y STA 1 # LDY
N LDA SP )Y STA N 1+ LDA SP X) STA
NEXT JMP END-CODE
\\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> 010 0
DO DUP 2/ >R 1 AND IF 2OVER D+ THEN
>R >R 2DUP D+ R> R> R> LOOP DROP 2SWAP 2DROP ;
\ *** Block No. 44 Hexblock 2C
\ M* 2* 04JUL84KS)
: M* ( N1 N2 -- D)
DUP 0< DUP >R IF NEGATE THEN
SWAP DUP 0< IF NEGATE R> NOT >R THEN
UM* R> IF DNEGATE THEN ;
: * ( N N -- PROD) UM* DROP ;
CODE 2* ( N1 -- N2)
SP X) LDA .A ASL SP X) STA
SP )Y LDA .A ROL SP )Y STA
NEXT JMP END-CODE
| : 2* DUP + ;
\ *** Block No. 45 Hexblock 2D
\ UM/MOD 04JUL84KS)
| : DIVOVL
TRUE ABORT" DIVISION OVERFLOW" ;
CODE UM/MOD ( UD U -- UREM UQUOT)
SP X) LDA N 5 + STA
SP )Y LDA N 4 + STA SP 2INC
SP X) LDA N 1+ STA
SP )Y LDA N STA INY
SP )Y LDA N 3 + STA INY
SP )Y LDA N 2+ STA 011 # LDX CLC
[[ N 6 + ROR SEC N 1+ LDA N 5 + SBC
TAY N LDA N 4 + SBC
CS NOT ?[ N 6 + ROL ]?
CS ?[ N STA N 1+ STY ]?
\ *** Block No. 46 Hexblock 2E
\
N 3 + ROL N 2+ ROL N 1+ ROL N ROL
DEX 0= ?]
1 # LDY N ROR N 1+ ROR
CS ?[ ;C: DIVOVL ; ASSEMBLER ]?
N 2+ LDA SP )Y STA INY
N 1+ LDA SP )Y STA INY
N LDA SP )Y STA 1 # LDY
N 3 + LDA
PUTA JMP END-CODE
\ *** Block No. 47 Hexblock 2F
\ 2/ M/MOD 24DEC83KS)
: M/MOD ( D N -- MOD QUOT)
DUP >R ABS OVER
0< IF UNDER + SWAP THEN
UM/MOD R@
0< IF NEGATE OVER IF SWAP R@ + SWAP 1-
THEN THEN RDROP ;
CODE 2/ ( N1 -- N2)
SP )Y LDA .A ASL
SP )Y LDA .A ROR SP )Y STA
SP X) LDA .A ROR
PUTA JMP END-CODE
\ *** Block No. 48 Hexblock 30
\ /MOD / MOD */MOD */ U/MOD UD/MOD KS)
: /MOD ( N1 N2 -- REM QUOT) >R EXTEND R> M/MOD ;
: / ( N1 N2 -- QUOT) /MOD NIP ;
: MOD ( N1 N2 -- REM) /MOD DROP ;
: */MOD ( N1 N2 N3 -- REM QUOT) >R M* R> M/MOD ;
: */ ( N1 N2 N3 -- QUOT) */MOD NIP ;
: U/MOD ( U1 U2 -- UREM UQUOT) 0 SWAP UM/MOD ;
: UD/MOD ( UD1 U2 -- UREM UDQUOT)
>R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ;
\ *** Block No. 49 Hexblock 31
\ CMOVE CMOVE> (CMOVE> BP 08APR85)
CODE CMOVE ( FROM TO QUAN --)
3 # LDA SETUP JSR DEY
[[ [[ N CPY 0= ?[ N 1+ DEC 0< ?[
1 # LDY NEXT JMP ]? ]?
N 4 + )Y LDA N 2+ )Y STA INY 0= ?]
N 5 + INC N 3 + INC ]] END-CODE
\ *** Block No. 50 Hexblock 32
\ CMOVE> MOVE cas 26jan06
CODE CMOVE> ( FROM TO QUAN --)
3 # LDA SETUP JSR
CLC N 1+ LDA N 3 + ADC N 3 + STA
CLC N 1+ LDA N 5 + ADC N 5 + STA
N 1+ INC N LDY CLC CS ?[
LABEL (CMOVE>
DEY N 4 + )Y LDA N 2+ )Y STA ]?
TYA (CMOVE> BNE
N 3 + DEC N 5 + DEC N 1+ DEC
(CMOVE> BNE 1 # LDY
NEXT JMP END-CODE
: MOVE ( FROM TO QUAN --) >R 2DUP U< IF R> CMOVE> EXIT THEN
R> CMOVE ;
\ *** Block No. 51 Hexblock 33
\ PLACE COUNT ERASE 16FEB85BP/KS)
: PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ;
CODE COUNT ( ADDR -- ADDR+1 LEN)
SP X) LDA N STA CLC 1 # ADC SP X) STA
SP )Y LDA N 1+ STA 0 # ADC SP )Y STA
SP 2DEC (C@ JMP END-CODE
\ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+ SWAP C@ ;
: ERASE ( ADDR QUAN --) 0 FILL ;
\ *** Block No. 52 Hexblock 34
\ FILL 11JUN85BP)
CODE FILL ( ADDR QUAN 8B -- )
3 # LDA SETUP JSR DEY
N LDA N 3 + LDX
0<> ?[ [[ [[ N 4 + )Y STA INY 0= ?]
N 5 + INC DEX 0= ?]
]? N 2+ LDX
0<> ?[ [[ N 4 + )Y STA INY DEX 0= ?]
]? 1 # LDY
NEXT JMP END-CODE
\\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP
IF >R OVER C! DUP 1+ R> 1- CMOVE EXIT THEN 2DROP ;
\ *** Block No. 53 Hexblock 35
\ HERE PAD ALLOT , C, COMPILE 24DEC83KS)
: HERE ( -- ADDR) DP @ ;
: PAD ( -- ADDR) HERE 042 + ;
: ALLOT ( N --) DP +! ;
: , ( 16B --) HERE ! 2 ALLOT ;
: C, ( 8B --) HERE C! 1 ALLOT ;
: COMPILE R> DUP 2+ >R @ , ; RESTRICT
\ *** Block No. 54 Hexblock 36
\ INPUT STRINGS 24DEC83KS)
VARIABLE #TIB 0 #TIB !
VARIABLE >TIB $100 >TIB ! \ 050 ALLOT
VARIABLE >IN 0 >IN !
VARIABLE BLK 0 BLK !
VARIABLE SPAN 0 SPAN !
: TIB ( -- ADDR ) >TIB @ ;
: QUERY TIB 050 EXPECT SPAN @ #TIB ! >IN OFF BLK OFF ;
\ *** Block No. 55 Hexblock 37
\ SCAN SKIP /STRING 12OCT84BP)
: SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R
BEGIN DUP WHILE OVER C@ R@ -
WHILE 1- SWAP 1+ SWAP REPEAT RDROP ;
: SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R
BEGIN DUP WHILE OVER C@ R@ =
WHILE 1- SWAP 1+ SWAP REPEAT RDROP ;
: /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1)
OVER UMIN ROT OVER + -ROT - ;
\ *** Block No. 56 Hexblock 38
\ CAPITAL 03APR85BP)
(C LABEL (CAPITAL \ FOR COMMODORE ONLY
PHA 0DF # AND \ 2ND UPPER TO LOWER
ASCII A # CMP
CS ?[ ASCII Z 1+ # CMP
CC ?[ PLA CLC ASCII A ASCII A - # ADC RTS
]? ]? PLA RTS END-CODE )
LABEL (CAPITAL \ FOR ASCII ONLY
ASCII a # CMP
CS ?[ ASCII z 1+ # CMP
CC ?[ SEC ASCII a ASCII A - # SBC
]? ]? RTS END-CODE
CODE CAPITAL ( CHAR -- CHAR' )
SP X) LDA (CAPITAL JSR SP X) STA NEXT JMP END-CODE
\ *** Block No. 57 Hexblock 39
\ CAPITALIZE 03APR85BP)
CODE CAPITALIZE ( STRING -- STRING )
SP X) LDA N STA SP )Y LDA N 1+ STA
N X) LDA N 2+ STA DEY
[[ N 2+ CPY 0= ?[ 1 # LDY NEXT JMP ]?
INY N )Y LDA (CAPITAL JSR N )Y STA
]] END-CODE
\\ : CAPITALIZE ( STRING -- STRING )
DUP COUNT BOUNDS ?DO I C@ CAPITAL I C! THEN LOOP ;
\\ CAPITAL ( CHAR -- CHAR )
ASCII A ASCII Z 1+ UWITHIN
IF I C@ [ ASCII A ASCII A - ] LITERAL - ;
\ *** Block No. 58 Hexblock 3A
\ (WORD 08APR85BP)
| CODE (WORD ( CHAR ADR0 LEN0 -- ADR)
\ N : LENGTH OF SOURCE
\ N+2 : PTR IN SOURCE / NEXT CHAR
\ N+4 : STRING START ADRESS
\ N+6 : STRING LENGTH
N 6 + STX \ 0 =: STRING_LENGTH
3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?]
1 # LDY CLC >IN LDA N 2+ ADC N 2+ STA
\ >IN+ADR0 =: N+2
>IN 1+ LDA N 3 + ADC N 3 + STA SEC N LDA >IN SBC N STA
\ LEN0->IN =: N
N 1+ LDA >IN 1+ SBC N 1+ STA
CC ?[ SP X) LDA >IN STA \ STREAM EXHAUSTED
SP )Y LDA >IN 1+ STA
\ *** Block No. 59 Hexblock 3B
\ (WORD 08APR85BP)
][ 4 # LDY [[ N LDA N 1+ ORA \ SKIP CHAR'S
0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0
0= ?[[ N 2+ WINC N WDEC ]]?
N 2+ LDA N 4 + STA \ SAVE STRING_START_ADRESS
N 3 + LDA N 5 + STA
[[ N 2+ X) LDA SP )Y CMP PHP \ SCAN FOR CHAR
N 2+ WINC N WDEC PLP
0= NOT ?[[ N 6 + INC \ COUNT STRING_LENGTH
N LDA N 1+ ORA
0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP)
SEC 2 # LDY
\ ADR_AFTER_STRING - ADR0 =: >IN)
N 2+ LDA SP )Y SBC >IN STA INY
N 3 + LDA SP )Y SBC >IN 1+ STA
\ *** Block No. 60 Hexblock 3C
\ (WORD 08APR85BP)
]? \ FROM 1ST ][, STREAM WAS EXHAUSTED
\ WHEN WORD CALLED)
CLC 4 # LDA SP ADC SP STA
CS ?[ SP 1+ INC ]? \ 2DROP
USER' DP # LDY UP )Y LDA
SP X) STA N STA INY
UP )Y LDA 1 # LDY
SP )Y STA N 1+ STA \ DP @
DEY N 6 + LDA \ STORE COUNT BYTE FIRST
[[ N )Y STA N 4 + )Y LDA INY
N 6 + DEC 0< ?]
020 # LDA N )Y STA \ ADD A BLANK
1 # LDY NEXT JMP END-CODE
\ *** Block No. 61 Hexblock 3D
\ SOURCE WORD PARSE NAME 08APR85BP)
: SOURCE ( -- ADDR LEN)
BLK @ ?DUP IF BLOCK B/BLK EXIT THEN TIB #TIB @ ;
: WORD ( CHAR -- ADDR) SOURCE (WORD ;
: PARSE ( CHAR -- ADDR LEN) >R SOURCE >IN @ /STRING OVER SWAP
R> SCAN >R OVER - DUP R> 0<> - >IN +! ;
: NAME ( -- ADDR) BL WORD CAPITALIZE EXIT ;
\\ : WORD ( CHAR -- ADDR) >R
SOURCE OVER SWAP >IN @ /STRING R@ SKIP OVER SWAP R>
SCAN >R ROT OVER SWAP - R> 0<> - >IN !
OVER - HERE PLACE BL HERE COUNT + C! HERE ;
\ *** Block No. 62 Hexblock 3E
\ STATE ASCII ," (" " 24DEC83KS)
VARIABLE STATE 0 STATE !
: ASCII BL WORD 1+ C@ STATE @
IF [COMPILE] LITERAL THEN ; IMMEDIATE
: ," ASCII " PARSE HERE OVER 1+ ALLOT PLACE ;
: "LIT R> R> UNDER COUNT + >R >R ; RESTRICT
: (" "LIT ; RESTRICT
: " COMPILE (" ," ; IMMEDIATE RESTRICT
\ *** Block No. 63 Hexblock 3F
\ ." ( .( \ \\ HEX DECIMAL 08SEP84KS)
: (." "LIT COUNT TYPE ; RESTRICT
: ." COMPILE (." ," ; IMMEDIATE RESTRICT
: ( ASCII ) PARSE 2DROP ; IMMEDIATE
: .( ASCII ) PARSE TYPE ; IMMEDIATE
: \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE
: \\ B/BLK >IN ! ; IMMEDIATE
: \NEEDS NAME FIND NIP IF [COMPILE] \ THEN ;
: HEX 010 BASE ! ; : DECIMAL 0A BASE ! ;
\ *** Block No. 64 Hexblock 40
\ NUMBER CONV.: DIGIT? ACCUMULATE KS)
: DIGIT? ( CHAR -- DIGIT TRUE/ FALSE )
ASCII 0 - DUP 9 U>
IF [ ASCII A ASCII 9 - 1- ] LITERAL - DUP 9 U>
IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN
BASE @ OVER U> ?DUP ?EXIT THEN DROP FALSE ;
: ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR)
SWAP >R SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> ;
: CONVERT ( +D1 ADDR0 -- +D2 ADDR2)
1+ BEGIN COUNT DIGIT? WHILE ACCUMULATE REPEAT 1- ;
| : END? ( -- FLAG ) PTR @ 0= ;
| : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ;
| : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ;
\ *** Block No. 65 Hexblock 41
\ ?NONUM ?NUM FIXBASE? 13FEB85KS)
VARIABLE DPL -1 DPL !
| : ?NONUM ( FLAG -- EXIT IF TRUE )
IF RDROP 2DROP DROP RDROP FALSE THEN ;
| : ?NUM ( FLAG -- EXIT IF TRUE )
IF RDROP DROP R> IF DNEGATE THEN
ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE THEN ;
| : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE )
ASCII & CASE? IF 0A TRUE EXIT THEN
ASCII $ CASE? IF 10 TRUE EXIT THEN
ASCII H CASE? IF 10 TRUE EXIT THEN
ASCII % CASE? IF 2 TRUE EXIT THEN FALSE ;
\ *** Block No. 66 Hexblock 42
\ 13FEB85KS)
| : PUNCTUATION? ( CHAR -- FLAG)
ASCII , OVER = SWAP ASCII . = OR ;
| : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ;
| VARIABLE PTR \ POINTS INTO STRING
\ *** Block No. 67 Hexblock 43
\ (NUMBER NUMBER 13FEB85KS)
: NUMBER? ( STRING - STRING FALSE / N 0< / D 0> )
BASE PUSH DUP COUNT PTR ! DPL ON
0 >R ( +SIGN)
0.0 ROT END? ?NONUM CHAR
ASCII - CASE?
IF RDROP TRUE >R END? ?NONUM CHAR THEN FIXBASE?
IF BASE ! END? ?NONUM CHAR THEN
BEGIN DIGIT? 0= ?NONUM
BEGIN ACCUMULATE ?DPL END? ?NUM
CHAR DIGIT? 0= UNTIL
PREVIOUS PUNCTUATION? 0= ?NONUM
DPL OFF END? ?NUM CHAR
REPEAT ;
: NUMBER ( STRING -- D )
NUMBER? ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ;
\ *** Block No. 68 Hexblock 44
\ HIDE REVEAL IMMEDIATE RESTRICT KS)
VARIABLE LAST 0 LAST !
| : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ;
: HIDE LAST? IF 2- @ CURRENT @ ! THEN ;
: REVEAL LAST? IF 2- CURRENT @ ! THEN ;
: RECURSIVE REVEAL ; IMMEDIATE RESTRICT
| : FLAG! ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN DROP ;
: IMMEDIATE 040 FLAG! ;
: RESTRICT 080 FLAG! ;
\ *** Block No. 69 Hexblock 45
\ CLEARSTACK HALLOT HEAP HEAP? cas 26jan06
CODE CLEARSTACK USER' S0 # LDY
UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA
1 # LDY NEXT JMP END-CODE
: HALLOT ( QUAN -- ) S0 @ OVER - SWAP
SP@ 2+ DUP ROT - DUP S0 !
2 PICK OVER - MOVE CLEARSTACK S0 ! ;
: HEAP ( -- ADDR) S0 @ 6+ ;
: HEAP? ( ADDR -- FLAG) HEAP UP@ UWITHIN ;
| : HEAPMOVE ( FROM -- FROM) DUP HERE OVER -
DUP HALLOT HEAP SWAP CMOVE HEAP OVER - LAST +! REVEAL ;
\ *** Block No. 70 Hexblock 46
\ DOES> ; 30DEC84KS/BP)
LABEL (DODOES> RP 2DEC
IP 1+ LDA RP )Y STA IP LDA RP X) STA \ PUT IP ON RP
CLC W X) LDA 3 # ADC IP STA
TXA W )Y ADC IP 1+ STA \ W@ + 3 -> IP
LABEL DOCREATE
2 # LDA CLC W ADC PHA TXA W 1+ ADC PUSH JMP END-CODE
| : (;CODE R> LAST @ NAME> ! ;
: DOES> COMPILE (;CODE 04C C,
COMPILE (DODOES> ; IMMEDIATE RESTRICT
\ *** Block No. 71 Hexblock 47
\ 6502-ALIGN ?HEAD \ 08SEP84BP)
| : 6502-ALIGN/1 ( ADR -- ADR' ) DUP 0FF AND 0FF = - ;
| : 6502-ALIGN/2 ( LFA -- LFA )
HERE 0FF AND 0FF =
IF DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID
1 LAST +! 1 ALLOT THEN ;
VARIABLE ?HEAD 0 ?HEAD !
: | ?HEAD @ ?EXIT -1 ?HEAD ! ;
\ *** Block No. 72 Hexblock 48
\ WARNING CREATE 30DEC84BP)
VARIABLE WARNING 0 WARNING !
| : EXISTS?
WARNING @ ?EXIT
LAST @ CURRENT @ (FIND NIP
IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ;
: CREATE HERE BLK @ , CURRENT @ @ ,
NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME"
HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @
IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE
HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP !
ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 ,
;CODE DOCREATE JMP END-CODE
\ *** Block No. 73 Hexblock 49
\ NFA? 30DEC84BP)
| CODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE)
SP X) LDA N 4 + STA SP )Y LDA N 5 + STA SP 2INC
[[ [[ SP X) LDA N 2+ STA SP )Y LDA N 3 + STA
N 2+ ORA 0= ?[ PUTFALSE JMP ]?
N 2+ )Y LDA SP )Y STA N 1+ STA
N 2+ X) LDA SP X) STA N STA
N 1+ ORA 0= ?[ NEXT JMP ]? \ N=LINK
N 2INC N X) LDA PHA SEC 01F # AND
N ADC N STA CS ?[ N 1+ INC ]?
PLA 020 # AND 0= NOT
?[ N )Y LDA PHA
N X) LDA N STA PLA N 1+ STA ]?
N LDA N 4 + CMP 0= ?] \ VOCABTHREAD=0
N 1+ LDA N 5 + CMP 0= ?] \ D.H. LEERES VOCABULARY
' 2+ @ JMP END-CODE \ IN NFA? IST ERLAUBT
\ *** Block No. 74 Hexblock 4A
\ >NAME NAME> >BODY .NAME 03FEB85BP)
: >NAME ( CFA -- NFA / FALSE) VOC-LINK
BEGIN @ DUP WHILE 2DUP 4 - SWAP
NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ;
| : (NAME> ( NFA -- CFA) COUNT 01F AND + ;
: NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ 020 AND IF @ THEN ;
: >BODY ( CFA -- PFA) 2+ ;
: .NAME ( NFA --)
?DUP IF DUP HEAP? IF ." |" THEN COUNT 01F AND TYPE
ELSE ." ???" THEN SPACE ;
\ *** Block No. 75 Hexblock 4B
\ : ; CONSTANT VARIABLE 09JAN85KS/BP)
: : CREATE HIDE CURRENT @ CONTEXT ! ] 0
;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE
RP 2DEC IP LDA RP X) STA IP 1+ LDA RP )Y STA
W LDA CLC 2 # ADC IP STA TXA W 1+ ADC IP 1+ STA
NEXT JMP END-CODE
: ; 0 ?PAIRS COMPILE EXIT
[COMPILE] [ REVEAL ; IMMEDIATE RESTRICT
: CONSTANT ( 16B --) CREATE ,
;CODE SP 2DEC 2 # LDY W )Y LDA SP X) STA INY
W )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE
: VARIABLE CREATE 2 ALLOT ;
\ *** Block No. 76 Hexblock 4C
\ UALLOT USER ALIAS 10JAN85KS/BP)
: UALLOT ( QUAN -- OFFSET)
DUP UDP @ + 0FF U> ABORT" USERAREA FULL"
UDP @ SWAP UDP +! ;
: USER CREATE 2 UALLOT C,
;CODE SP 2DEC 2 # LDY W )Y LDA CLC UP ADC SP X) STA
TXA INY UP 1+ ADC 1 # LDY SP )Y STA NEXT JMP END-CODE
: ALIAS ( CFA --)
CREATE LAST @ DUP C@ 020 AND
IF -2 ALLOT ELSE 020 FLAG! THEN (NAME> ! ;
\ *** Block No. 77 Hexblock 4D
\ VOC-LINK VP CURRENT CONTEXT ALSO BP)
CREATE VP 10 ALLOT
VARIABLE CURRENT
: CONTEXT ( -- ADR ) VP DUP @ + 2+ ;
| : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ;
\ "ONLY FORTH ALSO ASSEMBLER" GIVES VP :
\ COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER
: ALSO VP @
0A > ERROR" VOCABULARY STACK FULL"
CONTEXT @ 2 VP +! CONTEXT ! ;
: TOSS -2 VP +! ;
\ *** Block No. 78 Hexblock 4E
\ VOCABULARY FORTH ONLY FORTH-83 KS/BP)
: VOCABULARY CREATE 0 , 0 ,
HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ;
\ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK
VOCABULARY FORTH
VOCABULARY ONLY
] DOES> [ ONLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ONLY !
: ONLYFORTH ONLY FORTH ALSO DEFINITIONS ;
\ *** Block No. 79 Hexblock 4F
\ DEFINITIONS ORDER WORDS 13JAN84BP/KS)
: DEFINITIONS CONTEXT @ CURRENT ! ;
| : .VOC ( ADR -- ) @ 2- >NAME .NAME ;
: ORDER
THRU.VOCSTACK DO I .VOC -2 +LOOP 2 SPACES CURRENT .VOC ;
: WORDS CONTEXT @
BEGIN @ DUP STOP? 0= AND
WHILE ?CR DUP 2+ .NAME SPACE REPEAT DROP ;
\ *** Block No. 80 Hexblock 50
\ (FIND 08APR85BP)
CODE (FIND ( STRING THREAD
-- STRING FALSE / NAMEFIELD TRUE)
3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?]
N 2+ X) LDA 01F # AND N 4 + STA
LABEL FINDLOOP 0 # LDY
N )Y LDA TAX INY
N )Y LDA N 1+ STA N STX N ORA
0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]?
INY N )Y LDA 01F # AND N 4 + CMP
FINDLOOP BNE \ COUNTBYTE MATCH
CLC 2 # LDA N ADC N 5 + STA
0 # LDA N 1+ ADC N 6 + STA
N 4 + LDY
[[ N 2+ )Y LDA N 5 + )Y CMP
\ *** Block No. 81 Hexblock 51
\
FINDLOOP BNE DEY 0= ?]
3 # LDY N 6 + LDA SP )Y STA DEY
N 5 + LDA SP )Y STA
DEY 0 # LDX PUTTRUE JMP END-CODE
\ *** Block No. 82 Hexblock 52
\ FOUND 29JAN85BP)
| CODE FOUND ( NFA -- CFA N )
SP X) LDA N STA SP )Y LDA N 1+ STA
N X) LDA N 2+ STA 01F # AND SEC N ADC N STA
CS ?[ N 1+ INC ]?
N 2+ LDA 020 # AND
0= ?[ N LDA SP X) STA N 1+ LDA
][ N X) LDA SP X) STA N )Y LDA ]? SP )Y STA
SP 2DEC N 2+ LDA 0< ?[ INY ]?
.A ASL
0< NOT ?[ TYA 0FF # EOR TAY INY ]?
TYA SP X) STA
0< ?[ 0FF # LDA 24 C, ]?
TXA 1 # LDY SP )Y STA
NEXT JMP END-CODE
\ *** Block No. 83 Hexblock 53
\\
| : FOUND ( NFA -- CFA N )
DUP C@ >R (NAME>
R@ 020 AND IF @ THEN
-1 R@ 080 AND IF 1- THEN
R> 040 AND IF NEGATE THEN ;
\ *** Block No. 84 Hexblock 54
\ FIND ' ['] 13JAN85BP) cas2013apr05
: FIND ( STRING -- CFA N / STRING FALSE)
CONTEXT DUP @ OVER 2- @ = IF 2- THEN
BEGIN UNDER @ (FIND IF NIP FOUND EXIT THEN
OVER VP 2+ U>
WHILE SWAP 2- REPEAT NIP FALSE ;
: ' ( -- CFA ) NAME FIND 0= ABORT" WHAT?" ;
: [COMPILE] ' , ; IMMEDIATE RESTRICT
: ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT
: NULLSTRING? ( STRING -- STRING FALSE / TRUE)
DUP C@ 0= DUP IF NIP THEN ;
\ *** Block No. 85 Hexblock 55
\ >INTERPRET 28FEB85BP)
LABEL JUMP
INY CLC W )Y LDA 2 # ADC IP STA
INY W )Y LDA 0 # ADC IP 1+ STA
1 # LDY NEXT JMP END-CODE
VARIABLE >INTERPRET
JUMP ' >INTERPRET !
\\ MAKE VARIABLE >INTERPRET TO SPECIAL
DEFER
\ *** Block No. 86 Hexblock 56
\ INTERPRET INTERACTIVE 31DEC84KS/BP) cas 26jan06
DEFER NOTFOUND
: NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?" ; \ STRING NOT 0
' NO.EXTENSIONS IS NOTFOUND
: INTERPRET >INTERPRET ; -2 ALLOT
| : INTERACTIVE ?STACK NAME FIND ?DUP
IF 1 AND IF EXECUTE >INTERPRET THEN
ABORT" COMPILE ONLY" THEN NULLSTRING? ?EXIT NUMBER?
0= IF NOTFOUND THEN >INTERPRET ; -2 ALLOT
' INTERACTIVE >INTERPRET !
\ *** Block No. 87 Hexblock 57
\ COMPILING [ ] 20DEC84BP)
| : COMPILING
?STACK NAME FIND ?DUP
IF 0> IF EXECUTE >INTERPRET THEN
, >INTERPRET THEN
NULLSTRING? ?EXIT NUMBER? ?DUP
IF 0> IF SWAP [COMPILE] LITERAL THEN
[COMPILE] LITERAL
ELSE NOTFOUND THEN >INTERPRET ; -2 ALLOT
: [ ['] INTERACTIVE IS >INTERPRET STATE OFF ; IMMEDIATE
: ] ['] COMPILING IS >INTERPRET STATE ON ;
\ *** Block No. 88 Hexblock 58
\ PERFOM DEFER IS 03FEB85BP)
| : CRASH TRUE ABORT" CRASH" ;
: DEFER CREATE ['] CRASH ,
;CODE 2 # LDY W )Y LDA PHA INY W )Y LDA
W 1+ STA PLA W STA 1 # LDY W 1- JMP END-CODE
: (IS R> DUP 2+ >R @ ! ;
| : DEF? ( CFA -- ) @ ['] NOTFOUND @ OVER =
SWAP ['] >INTERPRET @ = OR NOT ABORT" NOT DEFERRED" ;
: IS ( ADR -- ) ' DUP DEF? >BODY
STATE @ IF COMPILE (IS , EXIT THEN ! ; IMMEDIATE
\ *** Block No. 89 Hexblock 59
\ ?STACK 08SEP84KS)
| : STACKFULL ( -- )
DEPTH 20 > ABORT" TIGHT STACK"
REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN
(FORGET THEN TRUE ABORT" DICTIONARY FULL" ;
CODE ?STACK USER' DP # LDY
SEC SP LDA UP )Y SBC N STA INY SP 1+ LDA UP )Y SBC
0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]?
USER' S0 # LDY UP )Y LDA SP CMP INY
UP )Y LDA SP 1+ SBC 1 # LDY CS ?[ NEXT JMP ]?
;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT
\\ : ?STACK SP@ HERE - 100 U< IF STACKFULL THEN
SP@ S0 @ U> ABORT" STACK EMPTY" ;
\ *** Block No. 90 Hexblock 5A
\ .STATUS PUSH LOAD 08SEP84KS)
DEFER .STATUS ' NOOP IS .STATUS
| CREATE PULL 0 ] R> R> ! ;
: PUSH ( ADDR -- )
R> SWAP DUP >R @ >R PULL >R >R ; RESTRICT
: LOAD ( BLK --)
?DUP 0= ?EXIT BLK PUSH BLK !
>IN PUSH >IN OFF .STATUS INTERPRET ;
\ *** Block No. 91 Hexblock 5B
\ +LOAD THRU +THRU --> RDEPTH DEPTH KS)
: +LOAD ( OFFSET --) BLK @ + LOAD ;
: THRU ( FROM TO --) 1+ SWAP DO I LOAD LOOP ;
: +THRU ( OFF0 OFF1 --) 1+ SWAP DO I +LOAD LOOP ;
: --> 1 BLK +! >IN OFF .STATUS ; IMMEDIATE
: RDEPTH ( -- +N) R0 @ RP@ 2+ - 2/ ;
: DEPTH ( -- +N) SP@ S0 @ SWAP - 2/ ;
\ *** Block No. 92 Hexblock 5C
\ QUIT (QUIT ABORT 07JUN85BP)
| : PROMPT STATE @ IF ." COMPILING" EXIT THEN ." OK" ;
: (QUIT
BEGIN .STATUS CR QUERY INTERPRET PROMPT REPEAT ; -2 ALLOT
DEFER 'QUIT ' (QUIT IS 'QUIT
: QUIT R0 @ RP! [COMPILE] [ 'QUIT ; -2 ALLOT
: STANDARDI/O [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ;
DEFER 'ABORT ' NOOP IS 'ABORT
: ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT
\ *** Block No. 93 Hexblock 5D
\ (ERROR ABORT" ERROR" 20MAR85BP)
VARIABLE SCR 1 SCR !
VARIABLE R# 0 R# !
: (ERROR ( STRING -- )
STANDARDI/O SPACE HERE .NAME COUNT TYPE SPACE ?CR
BLK @ ?DUP IF SCR ! >IN @ R# ! THEN QUIT ; -2 ALLOT
' (ERROR ERRORHANDLER !
: (ABORT" "LIT SWAP IF
>R CLEARSTACK R> ERRORHANDLER PERFORM
EXIT THEN DROP ; RESTRICT
\ *** Block No. 94 Hexblock 5E
\
| : (ERR" "LIT SWAP
IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT
: ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT
: ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT
\ *** Block No. 95 Hexblock 5F
\ -TRAILING 08APR85BP)
020 CONSTANT BL
CODE -TRAILING ( ADDR N1 -- ADR N2 )
TYA SETUP JSR
SP X) LDA N 2+ STA CLC
SP )Y LDA N 1+ ADC N 3 + STA
N LDY CLC CS ?[
LABEL (-TRAIL
DEY N 2+ )Y LDA BL # CMP
0<> ?[ INY 0= ?[ N 1+ INC ]?
TYA PHA N 1+ LDA PUSH JMP ]?
]? TYA (-TRAIL BNE
N 3 + DEC N 1 + DEC (-TRAIL BPL
TYA PUSH0A JMP END-CODE
\ *** Block No. 96 Hexblock 60
\ SPACE SPACES 29JAN85KS/BP)
: SPACE BL EMIT ;
: SPACES ( U --) 0 ?DO SPACE LOOP ;
\\
: -TRAILING ( ADDR N1 -- ADDR N2)
2DUP BOUNDS
?DO 2DUP + 1- C@ BL -
IF LEAVE THEN 1- LOOP ;
\ *** Block No. 97 Hexblock 61
\ HOLD <# #> SIGN # #S 24DEC83KS)
| : HLD ( -- ADDR) PAD 2- ;
: HOLD ( CHAR -- ) -1 HLD +! HLD @ C! ;
: <# HLD HLD ! ;
: #> ( 32B -- ADDR +N ) 2DROP HLD @ HLD OVER - ;
: SIGN ( N -- ) 0< IF ASCII - HOLD THEN ;
: # ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER <
IF [ ASCII A ASCII 9 - 1- ] LITERAL +
THEN ASCII 0 + HOLD ;
: #S ( +D -- 0 0 ) BEGIN # 2DUP D0= UNTIL ;
\ *** Block No. 98 Hexblock 62
\ PRINT NUMBERS 24DEC83KS)
: D.R -ROT UNDER DABS <# #S ROT SIGN #>
ROT OVER MAX OVER - SPACES TYPE ;
: .R SWAP EXTEND ROT D.R ;
: U.R 0 SWAP D.R ;
: D. 0 D.R SPACE ;
: . EXTEND D. ;
: U. 0 D. ;
\ *** Block No. 99 Hexblock 63
\ .S LIST C/L L/S 24DEC83KS)
: .S SP@ S0 @ OVER - 020 UMIN BOUNDS ?DO I @ U. 2 +LOOP ;
40 CONSTANT C/L \ SCREEN LINE LENGTH
10 CONSTANT L/S \ LINES PER SCREEN
: LIST ( BLK --)
SCR ! ." SCR " SCR @ DUP U.
." DR " DRV? .
L/S 0 DO CR I 2 .R SPACE SCR @ BLOCK
I C/L * + C/L -TRAILING TYPE LOOP CR ;
\ *** Block No. 100 Hexblock 64
\ MULTITASKER PRIMITIVES BP03NOV85)
CODE PAUSE NEXT HERE 2- ! END-CODE
: LOCK ( ADDR --)
DUP @ UP@ = IF DROP EXIT THEN
BEGIN DUP @ WHILE PAUSE REPEAT UP@ SWAP ! ;
: UNLOCK ( ADDR --) DUP LOCK OFF ;
LABEL WAKE WAKE >WAKE !
PLA SEC 5 # SBC UP STA PLA 0 # SBC UP 1+ STA
04C # LDA UP X) STA 6 # LDY UP )Y LDA SP STA
INY UP )Y LDA SP 1+ STA 1 # LDY
SP X) LDA RP STA SP )Y LDA RP 1+ STA SP 2INC
IP # LDX XPULL JMP END-CODE
\ *** Block No. 101 Hexblock 65
\ BUFFER MECHANISM 15DEC83KS) cas 26jan06
USER FILE 0 FILE ! \ ADR OF FILE CONTROL BLOCK
VARIABLE PREV 0 PREV ! \ LISTHEAD
| VARIABLE BUFFERS 0 BUFFERS ! \ SEMAPHOR
0408 CONSTANT B/BUF \ size of buffer
\ *** Block No. 102 Hexblock 66
\\ structure of buffer (same for all volksFORTH ) cas 26jan06
0 : LINK
2 : FILE
6 : BLOCKNR
8 : STATUSFLAGS
0A : DATA .. 1 KB ..
STATUSFLAG BITS: 15 1 -> UPDATED
FILE = -1 EMPTY BUFFER
= 0 NO FCB , DIRECT ACCESS
= ELSE ADR OF FCB
( SYSTEM DEPENDENT )
\ *** Block No. 103 Hexblock 67
\ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP)
LABEL THISBUFFER? 2 # LDY
[[ N 4 + )Y LDA N 2- ,Y CMP
0= ?[[ INY 6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER )
| CODE (CORE? ( BLK FILE -- ADDR / BLK FILE )
\ N-AREA : 0 BLK 2 FILE 4 BUFFER
\ 6 PREDECESSOR
3 # LDY
[[ SP )Y LDA N ,Y STA DEY 0< ?]
USER' OFFSET # LDY CLC UP )Y LDA N 2+ ADC N 2+ STA
INY UP )Y LDA N 3 + ADC N 3 + STA PREV LDA N 4 + STA
PREV 1+ LDA N 5 + STA THISBUFFER? JSR 0= ?[
\ *** Block No. 104 Hexblock 68
\ " 11JUN85BP)
LABEL BLOCKFOUND SP 2INC 1 # LDY
8 # LDA CLC N 4 + ADC SP X) STA
N 5 + LDA 0 # ADC SP )Y STA
' EXIT @ JMP ]?
[[ N 4 + LDA N 6 + STA N 5 + LDA N 7 + STA
N 6 + X) LDA N 4 + STA 1 # LDY
N 6 + )Y LDA N 5 + STA N 4 + ORA
0= ?[ ( LIST EMPTY ) NEXT JMP ]?
THISBUFFER? JSR 0= ?] \ FOUND, RELINK
N 4 + X) LDA N 6 + X) STA 1 # LDY N 4 + )Y LDA N 6 + )Y STA
PREV LDA N 4 + X) STA PREV 1+ LDA N 4 + )Y STA
N 4 + LDA PREV STA N 5 + LDA PREV 1+ STA
BLOCKFOUND JMP END-CODE
\ *** Block No. 105 Hexblock 69
\\ (CORE? 23SEP85BP
| : this? ( blk file bufadr -- flag )
DUP 4+ @ SWAP 2+ @ D= ;
| : (CORE? ( BLK FILE -- DATAADDR / BLK FILE )
BEGIN OVER OFFSET @ + OVER PREV @
THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN
2DUP >R OFFSET @ + >R PREV @
BEGIN DUP @ ?DUP
0= IF RDROP RDROP DROP EXIT THEN
DUP R> R> 2DUP >R >R ROT THIS? 0=
WHILE NIP REPEAT DUP @ ROT ! PREV @ OVER ! PREV !
RDROP RDROP REPEAT ; -2 ALLOT
\ *** Block No. 106 Hexblock 6A
\ (DISKERR 11JUN85BP)
: (DISKERR ." ERROR ! R TO RETRY "
KEY DUP ASCII R = SWAP ASCII R =
OR NOT ABORT" ABORTED" ;
DEFER DISKERR ' (DISKERR IS DISKERR
DEFER R/W
\ *** Block No. 107 Hexblock 6B
\ BACKUP EMPTYBUF READBLK 11JUN85BP)
| : BACKUP ( BUFADDR --)
DUP 6+ @ 0<
IF 2+ DUP @ 1+ \ BUFFER EMPTY IF FILE = -1
IF INPUT PUSH OUTPUT PUSH STANDARDI/O
BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W
WHILE ." WRITE " DISKERR
REPEAT THEN
080 OVER 4+ 1+ CTOGGLE THEN DROP ;
| : EMPTYBUF ( BUFADDR --) 2+ DUP ON 4+ OFF ;
| : READBLK ( BLK FILE ADDR -- BLK FILE ADDR)
DUP EMPTYBUF INPUT PUSH OUTPUT PUSH STANDARDI/O >R
BEGIN OVER OFFSET @ + OVER R@ 8 + -ROT 1 R/W
WHILE ." READ " DISKERR REPEAT R> ;
\ *** Block No. 108 Hexblock 6C
\ TAKE MARK UPDATES? FULL? CORE? BP)
| : TAKE ( -- BUFADDR) PREV
BEGIN DUP @ WHILE @ DUP 2+ @ -1 = UNTIL
BUFFERS LOCK DUP BACKUP ;
| : MARK ( BLK FILE BUFADDR -- BLK FILE )
2+ >R 2DUP R@ ! OFFSET @ + R@ 2+ !
R> 4+ OFF BUFFERS UNLOCK ;
| : UPDATES? ( -- BUFADDR / FLAG)
PREV BEGIN @ DUP WHILE DUP 6+ @ 0< UNTIL ;
| : FULL? ( -- FLAG) PREV BEGIN @ DUP @ 0= UNTIL 6+ @ 0< ;
: CORE? ( BLK FILE -- ADDR /FALSE) (CORE? 2DROP FALSE ;
\ *** Block No. 109 Hexblock 6D
\ BLOCK & BUFFER MANIPULATION 11JUN85BP)
: (BUFFER ( BLK FILE -- ADDR)
BEGIN (CORE? TAKE MARK REPEAT ; -2 ALLOT
: (BLOCK ( BLK FILE -- ADDR)
BEGIN (CORE? TAKE READBLK MARK REPEAT ; -2 ALLOT
| CODE FILE@ ( -- N ) USER' FILE # LDY
UP )Y LDA PHA INY UP )Y LDA PUSH JMP END-CODE
: BUFFER ( BLK -- ADDR ) FILE@ (BUFFER ;
: BLOCK ( BLK -- ADDR ) FILE@ (BLOCK ;
\ *** Block No. 110 Hexblock 6E
\ BLOCK & BUFFER MANIPULATION 09SEP84KS)
: UPDATE 080 PREV @ 6+ 1+ C! ;
: SAVE-BUFFERS
BUFFERS LOCK BEGIN UPDATES? ?DUP WHILE BACKUP REPEAT
BUFFERS UNLOCK ;
: EMPTY-BUFFERS
BUFFERS LOCK PREV
BEGIN @ ?DUP
WHILE DUP EMPTYBUF
REPEAT BUFFERS UNLOCK ;
: FLUSH SAVE-BUFFERS EMPTY-BUFFERS ;
\ *** Block No. 111 Hexblock 6F
\ MOVING BLOCKS 15DEC83KS) cas 26jan06
| : (COPY ( FROM TO --) DUP FILE@
CORE? IF PREV @ EMPTYBUF THEN
FULL? IF SAVE-BUFFERS THEN
OFFSET @ + SWAP BLOCK 2- 2- ! UPDATE ;
| : BLKMOVE ( FROM TO QUAN --) SAVE-BUFFERS >R
OVER R@ + OVER U> >R 2DUP U< R> AND
IF R@ R@ D+ R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP
ELSE R> 0 ?DO 2DUP (COPY 1 1 D+ LOOP
THEN SAVE-BUFFERS 2DROP ;
: COPY ( FROM TO --) 1 BLKMOVE ;
: CONVEY ( [BLK1 BLK2] [TO.BLK --)
SWAP 1+ 2 PICK - DUP 0> NOT ABORT" NO!!" BLKMOVE ;
\ *** Block No. 112 Hexblock 70
\ ALLOCATING BUFFERS 23SEP83KS) cas2013apr04
7F00 CONSTANT LIMIT VARIABLE FIRST
: ALLOTBUFFER ( -- )
FIRST @ R0 @ - B/BUF 2+ U< ?EXIT
B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF
PREV @ OVER ! PREV ! ;
: FREEBUFFER ( -- )
FIRST @ LIMIT B/BUF - U<
IF SAVE-BUFFERS BEGIN DUP @ FIRST @ - WHILE @ REPEAT
FIRST @ @ SWAP ! B/BUF FIRST +! THEN ;
: ALL-BUFFERS BEGIN FIRST @ ALLOTBUFFER FIRST @ = UNTIL ;
\ *** Block No. 113 Hexblock 71
\ ENDPOINTS OF FORGET 04JAN85BP/KS)
| : \? ( NFA -- FLAG ) C@ 020 AND ;
| : FORGET? ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ?
NAME> UNDER 1+ U< SWAP HEAP? OR ;
| : ENDPOINTS ( ADDR -- ADDR SYMB)
HEAP VOC-LINK @ >R
BEGIN R> @ ?DUP \ THROUGH ALL VOCABS
WHILE DUP >R 4 - >R \ LINK ON RETURNST.
BEGIN R> @ >R OVER 1- DUP R@ U< \ UNTIL LINK OR
SWAP R@ 2+ NAME> U< AND \ CODE UNDER ADR
WHILE R@ HEAP? [ 2DUP ] UNTIL \ SEARCH FOR A NAME IN HEAP
R@ 2+ \? IF OVER R@ 2+ FORGET?
IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB
THEN REPEAT RDROP REPEAT ;
\ *** Block No. 114 Hexblock 72
\ REMOVE 23JUL85WE
| CODE REMOVE ( DIC SYMB THR - DIC SYMB)
5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY
CLC UP )Y LDA 6 # ADC N 6 + STA
INY UP )Y LDA 0 # ADC N 7 + STA 1 # LDY
[[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA 0<>
?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS
?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC
][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC
]? CC
?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA
][ N 8 + LDA N STA N 9 + LDA N 1+ STA ]?
]]? (DROP JMP END-CODE
\ *** Block No. 115 Hexblock 73
\ REMOVE- FORGET-WORDS 29APR85BP)
| : REMOVE-WORDS ( DIC SYMB -- DIC SYMB)
VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT ;
| : REMOVE-TASKS ( DIC --)
UP@ BEGIN 1+ DUP @ UP@ - WHILE 2DUP @ SWAP HERE UWITHIN
IF DUP @ 1+ @ OVER ! 1- ELSE @ THEN REPEAT 2DROP ;
| : REMOVE-VOCS ( DIC SYMB -- DIC SYMB)
VOC-LINK REMOVE THRU.VOCSTACK
DO 2DUP I @ -ROT UWITHIN
IF [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP
2DUP CURRENT @ -ROT UWITHIN
IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ;
\ *** Block No. 116 Hexblock 74
\ FORGET-WORDS cas 26jan06
| : FORGET-WORDS ( DIC SYMB --)
OVER REMOVE-TASKS REMOVE-VOCS
REMOVE-WORDS
HEAP SWAP - HALLOT DP ! 0 LAST ! ;
\ *** Block No. 117 Hexblock 75
\ DELETING WORDS FROM DICT. 13JAN83KS)
: CLEAR HERE DUP UP@ FORGET-WORDS DP ! ;
: (FORGET ( ADR --) DUP HEAP? ABORT" IS SYMBOL"
ENDPOINTS FORGET-WORDS ;
: FORGET ' DUP [ DP ] LITERAL @ U< ABORT" PROTECTED"
>NAME DUP HEAP? IF NAME> ELSE 2- 2- THEN (FORGET ;
: EMPTY [ DP ] LITERAL @
UP@ FORGET-WORDS [ UDP ] LITERAL @ UDP ! ;
\ *** Block No. 118 Hexblock 76
\ SAVE BYE STOP? ?CR 20OCT84KS/BP)
: SAVE
HERE UP@ FORGET-WORDS VOC-LINK @
BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL
UP@ ORIGIN 0100 CMOVE ;
: BYE FLUSH EMPTY (BYE ;
| : END? KEY #CR (C 3 ) = IF TRUE RDROP THEN ;
: STOP? ( -- FLAG) KEY? IF END? END? THEN FALSE ;
: ?CR COL C/L 0A - U> IF CR THEN ;
\ *** Block No. 119 Hexblock 77
\ IN/OUTPUT STRUCTURE 02MAR85BP)
| : OUT: CREATE DUP C, 2+ DOES> C@ OUTPUT @ + PERFORM ;
: OUTPUT: CREATE ] DOES> OUTPUT ! ;
0 OUT: EMIT OUT: CR OUT: TYPE
OUT: DEL OUT: PAGE OUT: AT OUT: AT? DROP
: ROW ( -- ROW) AT? DROP ;
: COL ( -- COL) AT? NIP ;
| : IN: CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ;
: INPUT: CREATE ] DOES> INPUT ! ;
0 IN: KEY IN: KEY? IN: DECODE IN: EXPECT DROP
\ *** Block No. 120 Hexblock 78
\ ALIAS ONLY DEFINITIONEN 29JAN85BP)
ONLY DEFINITIONS FORTH
: SEAL 0 ['] ONLY >BODY ! ; \ KILL ALL WORDS IN ONLY)
' ONLY ALIAS ONLY
' FORTH ALIAS FORTH
' WORDS ALIAS WORDS
' ALSO ALIAS ALSO
' DEFINITIONS ALIAS DEFINITIONS
HOST TARGET
\ *** Block No. 121 Hexblock 79
\ 'COLD 07JUN85BP) cas2013apr05
| : INIT-VOCABULARYS VOC-LINK @
BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ;
| : INIT-BUFFERS 0 PREV ! LIMIT FIRST ! ALL-BUFFERS ;
DEFER 'COLD ' NOOP IS 'COLD
| : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH
." volksFORTH-83 3.8.7 05apr13 CS" CR RESTART ; -2 ALLOT
DEFER 'RESTART ' NOOP IS 'RESTART
| : (RESTART ['] (QUIT IS 'QUIT
DRVINIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER !
['] NOOP IS 'ABORT ABORT ; -2 ALLOT
\ *** Block No. 122 Hexblock 7A
\ COLD BOOTSYSTEM RESTART 09JUL85WE)
CODE COLD HERE >COLD !
' (COLD >BODY 100 U/MOD # LDA PHA # LDA PHA
LABEL BOOTSYSTEM CLI 0 # LDY
CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA
[[ ORIGIN ,Y LDA N )Y STA INY 0= ?]
LABEL WARMBOOT BOOTNEXTLEN 1- # LDY
[[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?]
CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA
USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA
USER' R0 # LDY UP )Y LDA RP STA INY UP )Y LDA RP 1+ STA
0 # LDX 1 # LDY TXA RP X) STA RP )Y STA
PLA IP STA PLA IP 1+ STA
LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE
\ *** Block No. 123 Hexblock 7B
\ ( RESTART PARAM.-PASSING TO FORTH BP)
CODE RESTART HERE >RESTART !
' (RESTART >BODY 100 U/MOD
# LDA PHA # LDA PHA WARMBOOT JMP END-CODE
\ *** Block No. 124 Hexblock 7C
\ CODE FOR PARAMETER-PASSING TO FORTH cas 26jan06
\ Include system dependent Input / Output code
\ (Keyboard and Screen)
include systemio.fb
HOST ' TRANSIENT 8 + @
TRANSIENT FORTH CONTEXT @ 6 + !
TARGET
FORTH ALSO DEFINITIONS
: FORTH-83 ; \ LAST WORD IN DICTIONARY
\ *** Block No. 125 Hexblock 7D
\ SYSTEM DEPENDENT CONSTANTS BP/KS)
VOCABULARY ASSEMBLER
ASSEMBLER DEFINITIONS
TRANSIENT ASSEMBLER
PUSHA CONSTANT PUSHA \ PUT A SIGN-EXTENDED ON STACK
PUSH0A CONSTANT PUSH0A \ PUT A ON STACK
PUSH CONSTANT PUSH \ MSB IN A AND LSB ON JSR-STACK
RP CONSTANT RP
UP CONSTANT UP
SP CONSTANT SP
IP CONSTANT IP
N CONSTANT N
PUTA CONSTANT PUTA
W CONSTANT W
SETUP CONSTANT SETUP
\ *** Block No. 126 Hexblock 7E
\
NEXT CONSTANT NEXT
XYNEXT CONSTANT XYNEXT
(2DROP CONSTANT POPTWO
(DROP CONSTANT POP
\ *** Block No. 127 Hexblock 7F
\ SYSTEM PATCHUP 05JAN85BP) cas2013apr05
FORTH DEFINITIONS
\ change memory layout for stacks and buffers here
TOPADDR ' LIMIT >BODY !
TOPADDR $F00 - S0 ! TOPADDR $480 - R0 !
S0 @ DUP S0 2- ! 6 + S0 7 - !
HERE DP !
HOST TUDP @ TARGET UDP !
HOST TVOC-LINK @ TARGET VOC-LINK !
HOST MOVE-THREADS
)
\ *** Block No. 128 Hexblock 80
\ *** Block No. 129 Hexblock 81
\ *** Block No. 130 Hexblock 82
\ *** Block No. 131 Hexblock 83
Reference in New Issue Copy Permalink