6502/VolksForth
1
0
Fork 0
mirror of https://github.com/forth-ev/VolksForth.git synced 2025-01-11 13:29:47 +00:00
Code Issues Projects Releases Wiki Activity
VolksForth/sources/Apple1/6502f83.fb.src
Carsten Strotmann 0478a47a95 Convert Apple 1 blocks to stream files
2020-07-15 11:24:43 +02:00

2245 lines
144 KiB
Plaintext
Raw Blame History

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