mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-14 00:29:45 +00:00
1 line
171 KiB
Plaintext
1 line
171 KiB
Plaintext
\\ ÄIRECTORY VOLKSÆÏÒÔÈ 2OF4 26OCT87RE . 0 .. 0 MISC $08 Ã64/Ã16 $09 ÓYSTEM $0Æ Ã64INTERFACE $7D Ã16INIT $94 \\ ÃONTENT VOLKSÆÏÒÔÈ 2OF4 26OCT87RE ÄIRECTORY 0 ÃONTENT 1 MISC $08 Ã64 OR Ã16 $09 ÓYSTEM $0Æ Ã64/Ã16INTERFACE $7D $95-A9 FREE \ RAM ROM JSR ÎORMÊSR F.Ã16+ CLV12.4.87) ÁSSEMBLER ALSO DEFINITIONS (C16+ \ Ã16+ÍACROS FOR ÂANKSWITCHING : RAM $FF3F STA ; : ROM $FF3E STA ; ' ÊSR ÁLIAS ÎORMÊSR ÄEFER ÊSR : Ã16+ÊSR DUP $C000 U> ÉÆ ROM ÎORMÊSR RAM ÅÌÓÅ ÎORMÊSR ÔÈÅÎ ; ' Ã16+ÊSR ÉS ÊSR ) \ ÔARGET-ÍACHINE CLV06DEC88 ÏNLYFORTH CR .( ÈOST IS: ) (64 .( Ã64) Ã) (16 .( Ã16) Ã) : ) ; IMMEDIATE : (à ; IMMEDIATE : (Ã64 ; IMMEDIATE \ : (Ã16 ; IMMEDIATE \ : (Ã16+ ; IMMEDIATE \ : (Ã16- ; IMMEDIATE \ : (Ã64 [COMPILE] ( ; IMMEDIATE : (Ã16 [COMPILE] ( ; IMMEDIATE : (Ã16+ [COMPILE] ( ; IMMEDIATE : (Ã16- [COMPILE] ( ; IMMEDIATE \ LOAD/REMOVE ÊÓÒ-ÍACROS CLV14.4.87) ÁSSEMBLER ALSO DEFINITIONS (Ã16+ \NEEDS Ã16+ÊSR -2 +LOAD ) (Ã16+ ' Ã16+ÊSR ÉS ÊSR .( ÊÓÒ ÉS:Ã16+ ) (Ã16+ \\ SKIPS REST OF SCREEN \ ALL OTHER PLATFORMS DON'T NEED \ MACROS, SO WE SKIP THE REST: \ \NEEDS Ã16+ÊSR \\ \ IF MACRO EXIST, REDEFINE IT: ' ÎORMÊSR ÉS ÊSR .( ÊÓÒ ÉS:ÎORM ) CR .( ÔARGET IS: ) \ CLV14.4.87) (à .( ÃÂÍ ) (Ã64 .( Ã64 ) (Ã16 .( Ã16 WITH ) (Ã16+ .( 64KB ) (Ã16- .( 32KB ) CR .( ÔARGET IS NOT: ) (à \ ) .( ÃÂÍ, ) (Ã64 \ ) .( Ã64, ) (Ã16 \ ) .( Ã16, ) (Ã16+ \ ) .( Ã16+64KB, ) (Ã16- \ ) .( Ã16-32KB, ) \ RAMFILL 3: ÏNLYFORTH ÃODE RAMFILL ( ADR N 8B -) SEI 34 # LDA 1 STA 3 # LDA SETUP JSR Î 3 + LDX TXA Î 2+ ORA 0<> ?[ Î LDA 0 # LDY [[ 0 # CPX 0<> ?[[ [[ Î 4 + )Ù STA INY 0= ?] Î 5 + INC DEX ]]? Î 2+ LDX 0<> ?[ [[ Î 4 + )Ù STA INY Î 2+ CPY ÃÓ ?] ]? ]? 36 # LDA 1 STA CLI 0 # LDX 1 # LDY ÎEXT JMP END-CODE $Ã000 $4000 (16 $300 - Ã) 0 RAMFILL FORGET RAMFILL ( ÄELETING ÁSSEMBLER ÌABELS BP27JUN85WE) : DELETE ÁSSEMBLER NAME FIND ÉÆ >NAME COUNT $1Æ AND BOUNDS ?ÄÏ $1Æ É C! ÌÏÏÐ ÅÌÓÅ COUNT TYPE SPACE ÔÈÅÎ ; DELETE SETUP DELETE XYÎEXT DELETE ÐUTA DELETE ÓÐ DELETE ÐOP DELETE ÎEXT DELETE Î DELETE ÕÐ DELETE ÐOPTWO DELETE × DELETE ÉÐ DELETE ÒÐ DELETE ÐUSH DELETE ÐUSH0Á DELETE ÐUSHÁ DELETE ;C: FORGET DELETE ÏNLYFORTH ( ÄEFINITION FOR .STATUS 28JUN85WE) : STATUS BLK @ ?DUP ÉÆ ." BLK " U. ." HERE " HERE U. ." THERE " THERE U. ." HEAP " HEAP U. CR ÔÈÅÎ ; ' STATUS IS .STATUS \ Ã64 ÆORTH LOADSCREEN CLV14OCT87 ÏNLYFORTH HEX -3 +LOAD \ CLEAR MEMORY AND -2 -1 +THRU \ CLR LABELS .STATUS -6 -4 +THRU \ ÔARGET-ÍACHINE ÏNLYFORTH (Ã64 $801 ) (Ã16 $1001 ) DUP DISPLACE ! ÔARGET DEFINITIONS HERE! $1 $6Å +THRU ÁSSEMBLER NONRELOCATE .UNRESOLVED ' .BLK IS .STATUS -4 +LOAD \ ÐRINT ÔARGET-ÍACHINE CR .( SAVE-TARGET VOLKSFORTH83) 91 CON! ( ÃURSOR UP) QUIT \ ÆÏÒÔÈ ÐREAMBLE AND ÉÄ CLV06AUG87 (Ã64 $Ä C, $8 C, $Á C, 00 C, 9Å C, 28 C, 32 C, 30 C, 36 C, 34 C, 29 C, 00 C, 00 C, 00 C, 00 C, ) \ ÓÙÓ(2064) (Ã16 $Ä C, 10 C, $Á C, 00 C, 9Å C, 28 C, 34 C, 31 C, 31 C, 32 C, 29 C, 00 C, 00 C, 00 C, 00 C, ) \ ÓÙÓ(4112) ÁSSEMBLER NOP 0 JMP HERE 2- >LABEL >COLD NOP 0 JMP HERE 2- >LABEL >RESTART HERE DUP ORIGIN! \ ÈERE ARE COLDSTART- AND ÕSERVARIABLES \ 0 JMP 0 JSR HERE 2- >LABEL >WAKE END-CODE $100 ALLOT ÃREATE LOGO (Ã64 ," VOLKSÆÏÒÔÈ-83 3.80.1-Ã64 " ) (Ã16+ ," VOLKSÆÏÒÔÈ-83 3.80.1-Ã16+ " ) (Ã16- ," VOLKSÆÏÒÔÈ-83 3.80.1-Ã16- " ) ( ÚERO PAGE ÖARIABLES & ÎEXT 03APR85BP) 02 DUP >LABEL ÒÐ 2+ DUP >LABEL ÕÐ 2+ DUP >LABEL ÐUTA 1+ DUP >LABEL ÓÐ 2+ DUP >LABEL ÎEXT DUP 5 + >LABEL ÉÐ 13 + >LABEL × × 8 + >LABEL Î ( ÎEXT, MOVED INTO ÚERO PAGE 08APR85BP) ÌABEL ÂOOTNEXT -1 STA \ -1 IS DUMMY ÓÐ ÉÐ )Ù LDA × 1+ STA -1 LDA × STA \ -1 IS DUMMY ÉÐ CLC ÉÐ LDA 2 # ADC ÉÐ STA ÃÓ NOT ?[ ÌABEL ×JMP -1 ) JMP ]? ÉÐ 1+ INC ×JMP BCS END-CODE HERE ÂOOTNEXT - >LABEL ÂOOTNEXTLEN ÃODE END-TRACE ( ÐATCH ÎEXT FOR TRACE ) $Á5 # LDA ÎEXT $Á + STA ÉÐ # LDA ÎEXT $ + STA $69 # LDA ÎEXT $à + STA 2 # LDA ÎEXT $Ä + STA ÎEXT JMP END-CODE \ ;C: NOOP 02NOV87RE ÃREATE RECOVER ( -- ADR ) ÁSSEMBLER PLA × STA PLA × 1+ STA × WDEC 0 JMP END-CODE HERE 2- >LABEL >RECOVER \ HANDCRAFTED FORWARD REFERENCE FOR \ JMP COMMAND ÃOMPILER ÁSSEMBLER ALSO DEFINITIONS È : ;C: 0 Ô RECOVER JSR END-CODE ] È ; ÔARGET ÃODE NOOP ÎEXT HERE 2- ! END-CODE \ ÕSER VARIABLES CLV14OCT87 ÃONSTANT ORIGIN 8 UALLOT DROP \ ÆOR MULTITASKER ÕSER S0 $7ÃÆÁ S0 ! ÕSER R0 $7ÆÆÅ R0 ! ÕSER DP ÕSER OFFSET 0 OFFSET ! ÕSER BASE &10 BASE ! ÕSER OUTPUT ÕSER INPUT ÕSER ERRORHANDLER \ POINTER FOR ÁBORT" -CODE ÕSER VOC-LINK ÕSER UDP \ POINTS TO NEXT FREE ADDR IN ÕSER ( MANIPULATE SYSTEM POINTERS 29JAN85BP) ÃODE SP@ ( -- ADDR) ÓÐ LDA Î STA ÓÐ 1+ LDA Î 1+ STA Î # LDX ÌABEL ØPUSH ÓÐ 2DEC 1 ,Ø LDA ÓÐ )Ù STA 0 ,Ø LDA 0 # LDX ÐUTA JMP END-CODE ÃODE SP! ( ADDR --) ÓÐ Ø) LDA TAX ÓÐ )Ù LDA ÓÐ 1+ STA ÓÐ STX 0 # LDX ÎEXT JMP END-CODE ÃODE UP@ ( -- ADDR) ÕÐ # LDX ØPUSH JMP END-CODE ÃODE UP! ( ADDR --) ÕÐ # LDX ÌABEL ØPULL ÓÐ )Ù LDA 1 ,Ø STA DEY ÓÐ )Ù LDA 0 ,Ø STA ÌABEL (XYDROP 0 # LDX 1 # LDY ÌABEL (DROP ÓÐ 2INC ÎEXT JMP END-CODE RESTRICT ( MANIPULATE RETURNSTACK 16FEB85BP/KS) ÃODE RP@ ( -- ADDR ) ÒÐ # LDX ØPUSH JMP END-CODE ÃODE RP! ( ADDR -- ) ÒÐ # LDX ØPULL JMP END-CODE RESTRICT ÃODE >R ( 16B -- ) ÒÐ 2DEC ÓÐ Ø) LDA ÒÐ Ø) STA ÓÐ )Ù LDA ÒÐ )Ù STA (DROP JMP END-CODE RESTRICT ÃODE R> ( -- 16B) ÓÐ 2DEC ÒÐ Ø) LDA ÓÐ Ø) STA ÒÐ )Ù LDA ÓÐ )Ù STA ÌABEL (RDROP 2 # LDA ÌABEL (NRDROP CLC ÒÐ ADC ÒÐ STA ÃÓ ?[ ÒÐ 1+ INC ]? ÎEXT JMP END-CODE RESTRICT \ R@ RDROP EXIT ?EXIT CLV12JUL87 ÃODE R@ ( -- 16B) ÓÐ 2DEC ÒÐ )Ù LDA ÓÐ )Ù STA ÒÐ Ø) LDA ÐUTA JMP END-CODE ÃODE RDROP (RDROP HERE 2- ! END-CODE RESTRICT ÃODE EXIT ÒÐ Ø) LDA ÉÐ STA ÒÐ )Ù LDA ÉÐ 1+ STA (RDROP JMP END-CODE ÃODE UNNEST ÒÐ Ø) LDA ÉÐ STA ÒÐ )Ù LDA ÉÐ 1+ STA (RDROP JMP END-CODE ÃODE ?EXIT ( FLAG -- ) ÓÐ Ø) LDA ÓÐ )Ù ORA PHP ÓÐ 2INC PLP ' EXIT @ BNE ÎEXT JMP END-CODE ( EXECUTE PERFORM 08APR85BP) ÃODE EXECUTE ( ADDR --) ÓÐ Ø) LDA × STA ÓÐ )Ù LDA × 1+ STA ÓÐ 2INC × 1- JMP END-CODE : PERFORM ( ADDR -- ) @ EXECUTE ; ( C@ C! CTOGGLE 10JAN85BP) ÃODE C@ ( ADDR -- 8B) ÓÐ Ø) LDA Î STA ÓÐ )Ù LDA Î 1+ STA ÌABEL (C@ 0 # LDA ÓÐ )Ù STA Î Ø) LDA ÐUTA JMP END-CODE ÃODE C! ( 16B ADDR --) ÓÐ Ø) LDA Î STA ÓÐ )Ù LDA Î 1+ STA INY ÓÐ )Ù LDA Î Ø) STA DEY ÌABEL (2DROP ÓÐ LDA CLC 4 # ADC ÓÐ STA ÃÓ ?[ ÓÐ 1+ INC ]? ÎEXT JMP END-CODE : CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ; ( @ ! +! 08APR85BP) ÃODE @ ( ADDR -- 16B) ÓÐ Ø) LDA Î STA ÓÐ )Ù LDA Î 1+ STA Î )Ù LDA ÓÐ )Ù STA Î Ø) LDA ÐUTA JMP END-CODE ÃODE ! ( 16B ADDR --) ÓÐ Ø) LDA Î STA ÓÐ )Ù LDA Î 1+ STA INY ÓÐ )Ù LDA Î Ø) STA INY ÓÐ )Ù LDA 1 # LDY ÌABEL (! Î )Ù STA (2DROP JMP END-CODE ÃODE +! ( N ADDR --) ÓÐ Ø) LDA Î STA ÓÐ )Ù LDA Î 1+ STA INY ÓÐ )Ù LDA CLC Î Ø) ADC Î Ø) STA INY ÓÐ )Ù LDA 1 # LDY Î )Ù ADC (! JMP END-CODE ( DROP SWAP 24MAY84KS) ÃODE DROP ( 16B --) (DROP HERE 2- ! END-CODE ÃODE SWAP ( 16B1 16B2 -- 16B2 16B1 ) ÓÐ )Ù LDA TAX 3 # LDY ÓÐ )Ù LDA Î STA TXA ÓÐ )Ù STA Î LDA 1 # LDY ÓÐ )Ù STA INY 0 # LDX ÓÐ )Ù LDA Î STA ÓÐ Ø) LDA ÓÐ )Ù STA DEY Î LDA ÐUTA JMP END-CODE ( DUP ?DUP 08MAY85BP) ÃODE DUP ( 16B -- 16B 16B) ÓÐ 2DEC 3 # LDY ÓÐ )Ù LDA 1 # LDY ÓÐ )Ù STA INY ÓÐ )Ù LDA DEY ÐUTA JMP END-CODE ÃODE ?DUP ( 16B -- 16B 16B / FALSE) ÓÐ Ø) LDA ÓÐ )Ù ORA 0= ?[ ÎEXT JMP ]? ' DUP @ JMP END-CODE \\ : ?DUP ( 16B -- 16B 16B / FALSE) DUP ÉÆ DUP ÔÈÅÎ ; : DUP ÓP@ @ ; ( OVER ROT 13JUN84KS) ÃODE OVER ( 16B1 16B2 - 16B1 16B3 16B1) ÓÐ 2DEC 4 # LDY ÓÐ )Ù LDA ÓÐ Ø) STA INY ÓÐ )Ù LDA 1 # LDY ÓÐ )Ù STA ÎEXT JMP END-CODE ÃODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1) 3 # LDY ÓÐ )Ù LDA Î 1+ STA 1 # LDY ÓÐ )Ù LDA 3 # LDY ÓÐ )Ù STA 5 # LDY ÓÐ )Ù LDA Î STA Î 1+ LDA ÓÐ )Ù STA 1 # LDY Î LDA ÓÐ )Ù STA INY ÓÐ )Ù LDA Î 1+ STA ÓÐ Ø) LDA ÓÐ )Ù STA 4 # LDY ÓÐ )Ù LDA ÓÐ Ø) STA Î 1+ LDA ÓÐ )Ù STA 1 # LDY ÎEXT JMP END-CODE \\ : ROT >R SWAP R> SWAP ; : OVER >R DUP R> SWAP ; ( -ROT NIP UNDER PICK ROLL 24DEC83KS) : -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* + ! ; ( DOUBLE WORD STACK MANIP. 21APR83KS) : 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ; ÃODE 2DROP ( 32B -- ) (2DROP HERE 2- ! END-CODE \ : 2DROP ( 32B -- ) DROP DROP ; : 2DUP ( 32B -- 32B 32B) OVER OVER ; ( + AND OR XOR 08APR85BP) ÃOMPILER ÁSSEMBLER ALSO DEFINITIONS È : ÄYADOP ( OPCODE --) Ô INY ÓÐ Ø) LDA DUP C, ÓÐ C, ÓÐ )Ù STA DEY ÓÐ )Ù LDA 3 # LDY C, ÓÐ C, ÓÐ )Ù STA (XYDROP JMP È ; ÔARGET ÃODE + ( N1 N2 -- N3) CLC $71 ÄYADOP END-CODE ÃODE OR ( 16B1 16B2 -- 16B3) $11 ÄYADOP END-CODE ÃODE AND ( 16B1 16B2 -- 16B3) $31 ÄYADOP END-CODE ÃODE XOR ( 16B1 16B2 -- 16B3) $51 ÄYADOP END-CODE ( - NOT NEGATE 24DEC83KS) ÃODE - ( N1 N2 -- N3) INY ÓÐ )Ù LDA SEC ÓÐ Ø) SBC ÓÐ )Ù STA INY ÓÐ )Ù LDA 1 # LDY ÓÐ )Ù SBC 3 # LDY ÓÐ )Ù STA (XYDROP JMP END-CODE ÃODE NOT ( 16B1 -- 16B2) CLC ÌABEL (NOT TXA ÓÐ Ø) SBC ÓÐ Ø) STA TXA ÓÐ )Ù SBC ÓÐ )Ù STA ÎEXT JMP END-CODE ÃODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE \ : - NEGATE + ; ( DNEGATE SETUP D+ 14JUN84KS) ÃODE DNEGATE ( D1 -- -D1) INY SEC TXA ÓÐ )Ù SBC ÓÐ )Ù STA INY TXA ÓÐ )Ù SBC ÓÐ )Ù STA TXA ÓÐ Ø) SBC ÓÐ Ø) STA 1 # LDY TXA ÓÐ )Ù SBC ÓÐ )Ù STA ÎEXT JMP END-CODE ÌABEL ÓETUP ( QUAN IN Á) .Á ASL TAX TAY DEY [[ ÓÐ )Ù LDA Î ,Ù STA DEY 0< ?] TXA CLC ÓÐ ADC ÓÐ STA ÃÓ ?[ ÓÐ 1+ INC ]? 0 # LDX 1 # LDY RTS END-CODE ÃODE D+ ( D1 D2 -- D3) 2 # LDA ÓETUP JSR INY ÓÐ )Ù LDA CLC Î 2+ ADC ÓÐ )Ù STA INY ÓÐ )Ù LDA Î 3 + ADC ÓÐ )Ù STA ÓÐ Ø) LDA Î ADC ÓÐ Ø) STA 1 # LDY ÓÐ )Ù LDA Î 1+ ADC ÓÐ )Ù STA ÎEXT JMP END-CODE ( 1+ 2+ 3+ 1- 2- 08APR85BP) ÃODE 1+ ( N1 -- N2) 1 # LDA ÌABEL N+ CLC ÓÐ Ø) ADC ÃÓ NOT ?[ ÐUTA JMP ]? ÓÐ Ø) STA ÓÐ )Ù LDA 0 # ADC ÓÐ )Ù STA ÎEXT JMP END-CODE ÃODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE ÃODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE Ü ÃODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE Ü ÃODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE ÃODE 1- ( N1 -- N2) SEC ÌABEL (1- ÓÐ Ø) LDA 1 # SBC ÃÓ ?[ ÐUTA JMP ]? ÓÐ Ø) STA ÓÐ )Ù LDA 0 # SBC ÓÐ )Ù STA ÎEXT JMP END-CODE ÃODE 2- ( N1 -- N2) CLC (1- BCC END-CODE ( NUMBER ÃONSTANTS 24DEC83KS) -1 ÃONSTANT TRUE 0 ÃONSTANT FALSE ' TRUE ÁLIAS -1 ' FALSE ÁLIAS 0 1 ÃONSTANT 1 2 ÃONSTANT 2 3 ÃONSTANT 3 4 ÃONSTANT 4 : ON ( ADDR -- ) TRUE SWAP ! ; : OFF ( ADDR -- ) FALSE SWAP ! ; ( WORDS FOR NUMBER LITERALS 24MAY84KS) ÃODE CLIT ( -- 8B) ÓÐ 2DEC ÉÐ Ø) LDA ÓÐ Ø) STA TXA ÓÐ )Ù STA ÉÐ WINC ÎEXT JMP END-CODE RESTRICT ÃODE LIT ( -- 16B) ÓÐ 2DEC ÉÐ )Ù LDA ÓÐ )Ù STA ÉÐ Ø) LDA ÓÐ Ø) STA ÌABEL (BUMP ÉÐ 2INC ÎEXT JMP END-CODE RESTRICT : ÌITERAL ( 16B --) DUP $ÆÆ00 AND ÉÆ COMPILE LIT , EXIT ÔÈÅÎ COMPILE CLIT C, ; IMMEDIATE RESTRICT \\ : LIT R> DUP 2+ >R @ ; : CLIT R> DUP 1+ >R C@ ; ( COMPARISION CODE WORDS 13JUN84KS) ÃODE 0< ( N -- FLAG) ÓÐ )Ù LDA 0< ?[ ÌABEL PUTÔRUE $ÆÆ # LDA $24 C, ]? ÌABEL PUTÆALSE TXA ÓÐ )Ù STA ÐUTA JMP END-CODE ÃODE 0= ( 16B -- FLAG) ÓÐ Ø) LDA ÓÐ )Ù ORA PUTÔRUE BEQ PUTÆALSE BNE END-CODE ÃODE UWITHIN ( U1 [LOW UP[ -- FLAG) 2 # LDA ÓETUP JSR 1 # LDY ÓÐ Ø) LDA Î CMP ÓÐ )Ù LDA Î 1+ SBC ÃÓ NOT ?[ ( Î>ÓÐ) ÓÐ Ø) LDA Î 2+ CMP ÓÐ )Ù LDA Î 3 + SBC PUTÔRUE BCS ]? PUTÆALSE JMP END-CODE ( COMPARISION CODE WORDS 13JUN84KS) ÃODE < ( N1 N2 -- FLAG) ÓÐ Ø) LDA Î STA ÓÐ )Ù LDA Î 1+ STA ÓÐ 2INC Î 1+ LDA ÓÐ )Ù EOR ' 0< @ BMI ÓÐ Ø) LDA Î CMP ÓÐ )Ù LDA Î 1+ SBC ' 0< @ 2+ JMP END-CODE ÃODE U< ( U1 U2 -- FLAG) ÓÐ Ø) LDA Î STA ÓÐ )Ù LDA Î 1+ STA ÓÐ 2INC ÓÐ Ø) LDA Î CMP ÓÐ )Ù LDA Î 1+ SBC ÃÓ NOT ?[ PUTÔRUE JMP ]? PUTÆALSE JMP END-CODE ( 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 - ÉÆ > NIP NIP ÅÌÓÅ 2DROP U< ÔÈÅÎ ; ( MIN MAX UMAX UMIN EXTEND DABS ABS KS) Ü : MINIMAX ( N1 N2 FLAG -- N3) RDROP ÉÆ SWAP ÔÈÅÎ DROP ; : MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; : MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; : UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; : UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; : EXTEND ( N -- D) DUP 0< ; : DABS ( D -- UD) EXTEND ÉÆ DNEGATE ÔÈÅÎ ; : ABS ( N -- U) EXTEND ÉÆ NEGATE ÔÈÅÎ ; \ LOOP PRIMITIVES 02NOV87RE Ü : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ; : (DO ( LIMIT STAR -- ) OVER - DODO ; RESTRICT : (?DO ( LIMIT START -- ) OVER - ?DUP ÉÆ DODO ÔÈÅÎ R> DUP @ + >R DROP ; RESTRICT : BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ; ÃODE ENDLOOP ( -- ) 6 # LDA (NRDROP JMP END-CODE RESTRICT \\ DODO PUTS "INDEX Ü LIMIT Ü ADR.OF.ÄÏ" ON RETURN-STACK \ (LOOP (+LOOP 02NOV87RE ÃODE (LOOP CLC 1 # LDA ÒÐ Ø) ADC ÒÐ Ø) STA ÃÓ ?[ ÒÐ )Ù LDA 0 # ADC ÒÐ )Ù STA ÃÓ ?[ ÎEXT JMP ]? ]? ÌABEL DOLOOP 5 # LDY ÒÐ )Ù LDA ÉÐ 1+ STA DEY ÒÐ )Ù LDA ÉÐ STA 1 # LDY ÎEXT JMP END-CODE RESTRICT ÃODE (+LOOP ( N -- ) CLC ÓÐ Ø) LDA ÒÐ Ø) ADC ÒÐ Ø) STA ÓÐ )Ù LDA ÒÐ )Ù ADC ÒÐ )Ù STA .Á ROR ÓÐ )Ù EOR PHP ÓÐ 2INC PLP DOLOOP BPL ÎEXT JMP END-CODE RESTRICT ( LOOP INDICES 08APR85BP) ÃODE É ( -- N) 0 # LDY ÌABEL LOOPINDEX ÓÐ 2DEC CLC ÒÐ )Ù LDA INY INY ÒÐ )Ù ADC ÓÐ Ø) STA DEY ÒÐ )Ù LDA INY INY ÒÐ )Ù ADC 1 # LDY ÓÐ )Ù STA ÎEXT JMP END-CODE RESTRICT ÃODE Ê ( -- N) 6 # LDY LOOPINDEX BNE END-CODE RESTRICT \ BRANCHING 02NOV87RE ÃODE BRANCH CLC ÉÐ LDA ÉÐ Ø) ADC Î STA ÉÐ 1+ LDA ÉÐ )Ù ADC ÉÐ 1+ STA Î LDA ÉÐ STA ÎEXT JMP END-CODE RESTRICT ÃODE ?BRANCH ( FLAG -- ) ÓÐ Ø) LDA ÓÐ )Ù ORA PHP ÓÐ 2INC PLP ' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT \\ : BRANCH R> DUP @ + >R ; RESTRICT : ?BRANCH ( FLAG -- ) 0= R> OVER NOT OVER 2+ AND -ROT DUP @ + AND OR >R ; RESTRICT ( RESOLVE LOOPS AND BRANCHES 03FEB85BP) : >MARK ( -- ADDR) HERE 0 , ; : >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; : <MARK ( -- ADDR) HERE ; : <RESOLVE ( ADDR --) HERE - , ; : ?PAIRS ( N1 N2 -- ) - ÁBORT" UNSTRUCTURED" ; ( CASE? 04MAY85BP) ÌABEL ÐUSHÁ 0 # CMP 0< ?[ PHA $ÆÆ # LDA ][ ÌABEL ÐUSH0Á PHA 0 # LDA ]? ÌABEL ÐUSH TAX ÓÐ 2DEC TXA 1 # LDY ÓÐ )Ù STA PLA 0 # LDX ÐUTA JMP ÃODE CASE? ( 16B1 16B2 -- 16B1 FALSE / TRUE ) 1 # LDA ÓETUP JSR Î LDA ÓÐ Ø) CMP 0= ?[ Î 1+ LDA ÓÐ )Ù CMP 0= ?[ PUTÔRUE JMP ]? ]? TXA ÐUSH0Á JMP END-CODE \\ : CASE? ( 16B1 16B2 -- 16B1 FALSE / TRUE ) OVER = DUP ÉÆ NIP ÔÈÅÎ ; ( ÂRANCHING 03FEB85BP) : ÉÆ COMPILE ?BRANCH >MARK 1 ; IMMEDIATE RESTRICT : ÔÈÅÎ ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT : ÅÌÓÅ 1 ?PAIRS COMPILE BRANCH >MARK SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT : ÂÅÇÉÎ <MARK 2 ; IMMEDIATE RESTRICT : ×ÈÉÌÅ 2 ?PAIRS 2 COMPILE ?BRANCH >MARK -2 2SWAP ; IMMEDIATE RESTRICT Ü : (REPTIL <RESOLVE ÂÅÇÉÎ DUP -2 = ×ÈÉÌÅ DROP >RESOLVE ÒÅÐÅÁÔ ; : ÒÅÐÅÁÔ 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT : ÕÎÔÉÌ 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT ( ÌOOPS 29JAN85KS/BP) : ÄÏ COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT : ?ÄÏ COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT : ÌÏÏÐ 3 ?PAIRS COMPILE (LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : +ÌÏÏÐ 3 ?PAIRS COMPILE (+LOOP COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT : ÌÅÁÖÅ ENDLOOP R> 2- DUP @ + >R ; RESTRICT \\ ÒETURNSTACK: CALLADR Ü INDEX LIMIT Ü ADR OF ÄÏ ( UM* BP/KS13.2.85) ÃODE UM* ( U1 U2 -- UD) ÓÐ )Ù LDA Î STA ÓÐ Ø) LDA Î 1+ STA INY Î 2 + STX Î 3 + STX $10 # LDX [[ Î 3 + ASL Î 2+ ROL Î 1+ ROL Î ROL ÃÓ ?[ CLC ÓÐ )Ù LDA Î 3 + ADC Î 3 + STA INY ÓÐ )Ù LDA DEY Î 2 + ADC Î 2 + STA ÃÓ ?[ Î 1+ INC 0= ?[ Î INC ]? ]? ]? DEX 0= ?] Î 3 + LDA ÓÐ )Ù STA INY Î 2 + LDA ÓÐ )Ù STA 1 # LDY Î LDA ÓÐ )Ù STA Î 1+ LDA ÓÐ Ø) STA ÎEXT JMP END-CODE \\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> $10 0 ÄÏ DUP 2/ >R 1 AND ÉÆ 2OVER D+ ÔÈÅÎ >R >R 2DUP D+ R> R> R> ÌÏÏÐ DROP 2SWAP 2DROP ; ( M* 2* 04JUL84KS) : M* ( N1 N2 -- D) DUP 0< DUP >R ÉÆ NEGATE ÔÈÅÎ SWAP DUP 0< ÉÆ NEGATE R> NOT >R ÔÈÅÎ UM* R> ÉÆ DNEGATE ÔÈÅÎ ; : * ( N N -- PROD) UM* DROP ; ÃODE 2* ( N1 -- N2) ÓÐ Ø) LDA .Á ASL ÓÐ Ø) STA ÓÐ )Ù LDA .Á ROL ÓÐ )Ù STA ÎEXT JMP END-CODE \ : 2* DUP + ; ( UM/MOD 04JUL84KS) Ü : DIVOVL TRUE ÁBORT" DIVISION OVERFLOW" ; ÃODE UM/MOD ( UD U -- UREM UQUOT) ÓÐ Ø) LDA Î 5 + STA ÓÐ )Ù LDA Î 4 + STA ÓÐ 2INC ÓÐ Ø) LDA Î 1+ STA ÓÐ )Ù LDA Î STA INY ÓÐ )Ù LDA Î 3 + STA INY ÓÐ )Ù LDA Î 2+ STA $11 # LDX CLC [[ Î 6 + ROR SEC Î 1+ LDA Î 5 + SBC TAY Î LDA Î 4 + SBC ÃÓ NOT ?[ Î 6 + ROL ]? ÃÓ ?[ Î STA Î 1+ STY ]? Î 3 + ROL Î 2+ ROL Î 1+ ROL Î ROL DEX 0= ?] 1 # LDY Î ROR Î 1+ ROR ÃÓ ?[ ;C: DIVOVL ; ÁSSEMBLER ]? Î 2+ LDA ÓÐ )Ù STA INY Î 1+ LDA ÓÐ )Ù STA INY Î LDA ÓÐ )Ù STA 1 # LDY Î 3 + LDA ÐUTA JMP END-CODE ( 2/ M/MOD 24DEC83KS) : M/MOD ( D N -- MOD QUOT) DUP >R ABS OVER 0< ÉÆ UNDER + SWAP ÔÈÅÎ UM/MOD R@ 0< ÉÆ NEGATE OVER ÉÆ SWAP R@ + SWAP 1- ÔÈÅÎ ÔÈÅÎ RDROP ; ÃODE 2/ ( N1 -- N2) ÓÐ )Ù LDA .Á ASL ÓÐ )Ù LDA .Á ROR ÓÐ )Ù STA ÓÐ Ø) LDA .Á ROR ÐUTA JMP END-CODE ( /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> ; ( CMOVE CMOVE> (CMOVE> BP 08APR85) ÃODE CMOVE ( FROM TO QUAN --) 3 # LDA ÓETUP JSR DEY [[ [[ Î CPY 0= ?[ Î 1+ DEC 0< ?[ 1 # LDY ÎEXT JMP ]? ]? Î 4 + )Ù LDA Î 2+ )Ù STA INY 0= ?] Î 5 + INC Î 3 + INC ]] END-CODE ÃODE CMOVE> ( FROM TO QUAN --) 3 # LDA ÓETUP JSR CLC Î 1+ LDA Î 3 + ADC Î 3 + STA CLC Î 1+ LDA Î 5 + ADC Î 5 + STA Î 1+ INC Î LDY CLC ÃÓ ?[ ÌABEL (CMOVE> DEY Î 4 + )Ù LDA Î 2+ )Ù STA ]? TYA (CMOVE> BNE Î 3 + DEC Î 5 + DEC Î 1+ DEC (CMOVE> BNE 1 # LDY ÎEXT JMP END-CODE : MOVE ( FROM TO QUAN --) >R 2DUP U< ÉÆ R> CMOVE> EXIT ÔÈÅÎ R> CMOVE ; ( PLACE COUNT ERASE 16FEB85BP/KS) : PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ; ÃODE COUNT ( ADDR -- ADDR+1 LEN) ÓÐ Ø) LDA Î STA CLC 1 # ADC ÓÐ Ø) STA ÓÐ )Ù LDA Î 1+ STA 0 # ADC ÓÐ )Ù STA ÓÐ 2DEC (C@ JMP END-CODE \ : COUNT ( ADR -- ADR+1 LEN ) \ DUP 1+ SWAP C@ ; : ERASE ( ADDR QUAN --) 0 FILL ; ( FILL 11JUN85BP) ÃODE FILL ( ADDR QUAN 8B -- ) 3 # LDA ÓETUP JSR DEY Î LDA Î 3 + LDX 0<> ?[ [[ [[ Î 4 + )Ù STA INY 0= ?] Î 5 + INC DEX 0= ?] ]? Î 2+ LDX 0<> ?[ [[ Î 4 + )Ù STA INY DEX 0= ?] ]? 1 # LDY ÎEXT JMP END-CODE \\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP ÉÆ >R OVER C! DUP 1+ R> 1- CMOVE EXIT ÔÈÅÎ 2DROP ; ( HERE ÐAD ALLOT , C, COMPILE 24DEC83KS) : HERE ( -- ADDR) DP @ ; : PAD ( -- ADDR) HERE $42 + ; : ALLOT ( N --) DP +! ; : , ( 16B --) HERE ! 2 ALLOT ; : C, ( 8B --) HERE C! 1 ALLOT ; : COMPILE R> DUP 2+ >R @ , ; RESTRICT ( INPUT STRINGS 24DEC83KS) ÖARIABLE #TIB 0 #TIB ! ÖARIABLE >TIB HERE >TIB ! $50 ALLOT ÖARIABLE >IN 0 >IN ! ÖARIABLE BLK 0 BLK ! ÖARIABLE SPAN 0 SPAN ! : TIB ( -- ADDR ) >TIB @ ; : QUERY TIB $50 EXPECT SPAN @ #TIB ! >IN OFF BLK OFF ; ( SCAN SKIP /STRING 12OCT84BP) : SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R ÂÅÇÉÎ DUP ×ÈÉÌÅ OVER C@ R@ - ×ÈÉÌÅ 1- SWAP 1+ SWAP ÒÅÐÅÁÔ RDROP ; : SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R ÂÅÇÉÎ DUP ×ÈÉÌÅ OVER C@ R@ = ×ÈÉÌÅ 1- SWAP 1+ SWAP ÒÅÐÅÁÔ RDROP ; : /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1) OVER UMIN ROT OVER + -ROT - ; \ CAPITAL CLV06AUG87 ÌABEL (CAPITAL \ FOR COMMODORE ONLY \ FOR ÁSCII: NEXT SCR ÁSCII A # CMP ÃÓ ?[ ÁSCII Z $21 + # CMP Ãà ?[ ÁSCII A $21 + # CMP ÃÓ ?[ $DF # AND ]? \ 2ND UP TO LOW ÁSCII Z 1+ # CMP Ãà ?[ $80 # ORA \ LOW TO UP ]? ]? ]? RTS END-CODE ÃODE CAPITAL ( CHAR -- CHAR' ) ÓÐ Ø) LDA (CAPITAL JSR ÓÐ Ø) STA ÎEXT JMP END-CODE \\ ÔHE NEW (CAPITAL DOES: ÎO 00-40,5B-60,7B-C1-DA-DC-FF NO CHANGE == -@ , [-À , -Á -Ú -| - .. ÎO 41-5A,61-7A CHANGES TO:C1-DA == A-Z , Á-Ú Á-Ú \ CAPITALIZE CLV06AUG87 ÃODE CAPITALIZE ( STRING -- STRING ) ÓÐ Ø) LDA Î STA ÓÐ )Ù LDA Î 1+ STA Î Ø) LDA Î 2+ STA DEY [[ Î 2+ CPY 0= ?[ 1 # LDY ÎEXT JMP ]? INY Î )Ù LDA (CAPITAL JSR Î )Ù STA ]] END-CODE \\ : CAPITALIZE ( STRING -- STRING ) DUP COUNT BOUNDS ?ÄÏ É C@ CAPITAL É C! ÔÈÅÎ ÌÏÏÐ ; \\ CAPITAL ( CHAR -- CHAR ) ÁSCII A ÁSCII Z 1+ UWITHIN ÉÆ É C@ [ ÁSCII A ÁSCII Á - ] ÌITERAL - ; \\ ÌABEL (CAPITAL \ FOR ÁSCII ONLY ÁSCII A # CMP ÃÓ ?[ ÁSCII Z 1+ # CMP Ãà ?[ SEC ÁSCII A ÁSCII Á - # SBC ]? ]? RTS END-CODE ( (WORD 08APR85BP) Ü ÃODE (WORD ( CHAR ADR0 LEN0 -- ADR) \ Î : LENGTH OF SOURCE \ Î+2 : PTR IN SOURCE / NEXT CHAR \ Î+4 : STRING START ADRESS \ Î+6 : STRING LENGTH Î 6 + STX \ 0 =: STRING_LENGTH 3 # LDY [[ ÓÐ )Ù LDA Î ,Ù STA DEY 0< ?] 1 # LDY CLC >IN LDA Î 2+ ADC Î 2+ STA \ >IN+ADR0 =: Î+2 >IN 1+ LDA Î 3 + ADC Î 3 + STA SEC Î LDA >IN SBC Î STA \ LEN0->IN =: Î Î 1+ LDA >IN 1+ SBC Î 1+ STA Ãà ?[ ÓÐ Ø) LDA >IN STA \ STREAM EXHAUSTED ÓÐ )Ù LDA >IN 1+ STA ( (WORD 08APR85BP) ][ 4 # LDY [[ Î LDA Î 1+ ORA \ SKIP CHAR'S 0= NOT ?[[ Î 2+ Ø) LDA ÓÐ )Ù CMP \ WHILE COUNT <>0 0= ?[[ Î 2+ WINC Î WDEC ]]? Î 2+ LDA Î 4 + STA \ SAVE STRING_START_ADRESS Î 3 + LDA Î 5 + STA [[ Î 2+ Ø) LDA ÓÐ )Ù CMP PHP \ SCAN FOR CHAR Î 2+ WINC Î WDEC PLP 0= NOT ?[[ Î 6 + INC \ COUNT STRING_LENGTH Î LDA Î 1+ ORA 0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP) SEC 2 # LDY \ ADR_AFTER_STRING - ADR0 =: >IN) Î 2+ LDA ÓÐ )Ù SBC >IN STA INY Î 3 + LDA ÓÐ )Ù SBC >IN 1+ STA ( (WORD 08APR85BP) ]? \ FROM 1ST ][, STREAM WAS EXHAUSTED \ WHEN WORD CALLED) CLC 4 # LDA ÓÐ ADC ÓÐ STA ÃÓ ?[ ÓÐ 1+ INC ]? \ 2DROP USER' DP # LDY ÕÐ )Ù LDA ÓÐ Ø) STA Î STA INY ÕÐ )Ù LDA 1 # LDY ÓÐ )Ù STA Î 1+ STA \ DP @ DEY Î 6 + LDA \ STORE COUNT BYTE FIRST [[ Î )Ù STA Î 4 + )Ù LDA INY Î 6 + DEC 0< ?] $20 # LDA Î )Ù STA \ ADD A BLANK 1 # LDY ÎEXT JMP END-CODE ( SOURCE WORD PARSE NAME 08APR85BP) : SOURCE ( -- ADDR LEN) BLK @ ?DUP ÉÆ BLOCK B/BLK EXIT ÔÈÅÎ 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 ; \ STATE ÁSCII ," (" " 02NOV87RE ÖARIABLE STATE 0 STATE ! : ÁSCII ( -- CHAR ) ( -- ) BL WORD 1+ C@ STATE @ ÉÆ [COMPILE] ÌITERAL ÔÈÅÎ ; IMMEDIATE : ," ÁSCII " PARSE HERE OVER 1+ ALLOT PLACE ; : "LIT ( -- ADR ) R> R> UNDER COUNT + >R >R ; RESTRICT : (" ( -- ADR ) "LIT ; RESTRICT : " COMPILE (" ," ; IMMEDIATE RESTRICT ( ." ( .( \ \\ HEX DECIMAL 08SEP84KS) : (." "LIT COUNT TYPE ; RESTRICT : ." COMPILE (." ," ; IMMEDIATE RESTRICT : ( ÁSCII ) PARSE 2DROP ; IMMEDIATE : .( ÁSCII ) PARSE TYPE ; IMMEDIATE : \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE : \\ B/BLK >IN ! ; IMMEDIATE : \NEEDS NAME FIND NIP ÉÆ [COMPILE] \ ÔÈÅÎ ; : HEX $10 BASE ! ; : DECIMAL $Á BASE ! ; ( NUMBER CONV.: DIGIT? ACCUMULATE KS) : DIGIT? ( CHAR -- DIGIT TRUE/ FALSE ) ÁSCII 0 - DUP 9 U> ÉÆ [ ÁSCII Á ÁSCII 9 - 1- ] ÌITERAL - DUP 9 U> ÉÆ [ 2SWAP ( UNSTRUCTURED ) ] ÔÈÅÎ BASE @ OVER U> ?DUP ?EXIT ÔÈÅÎ 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+ ÂÅÇÉÎ COUNT DIGIT? ×ÈÉÌÅ ACCUMULATE ÒÅÐÅÁÔ 1- ; : END? ( -- FLAG ) PTR @ 0= ; : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ; : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ; ( ?NONUM ?NUM FIXBASE? 13FEB85KS) ÖARIABLE DPL -1 DPL ! Ü : ?NONUM ( FLAG -- EXIT IF TRUE ) ÉÆ RDROP 2DROP DROP RDROP FALSE ÔÈÅÎ ; Ü : ?NUM ( FLAG -- EXIT IF TRUE ) ÉÆ RDROP DROP R> ÉÆ DNEGATE ÔÈÅÎ ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE ÔÈÅÎ ; Ü : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE ) ÁSCII & CASE? ÉÆ $Á TRUE EXIT ÔÈÅÎ ÁSCII $ CASE? ÉÆ 10 TRUE EXIT ÔÈÅÎ ÁSCII È CASE? ÉÆ 10 TRUE EXIT ÔÈÅÎ ÁSCII % CASE? ÉÆ 2 TRUE EXIT ÔÈÅÎ FALSE ; Ü : PUNCTUATION? ( CHAR -- FLAG) ÁSCII , OVER = SWAP ÁSCII . = OR ; Ü : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; ( NUMBER? NUMBER 'NUMBER 01OCT87CLV/RE) Ü ÖARIABLE PTR \ POINTS INTO STRING : NUMBER? ( STRING - STRING FALSE / N 0< / D 0> ) BASE PUSH DUP COUNT PTR ! DPL ON 0 >R ( +SIGN) 0 0 ROT END? ?NONUM CHAR ÁSCII - CASE? ÉÆ RDROP TRUE >R END? ?NONUM CHAR ÔÈÅÎ FIXBASE? ÉÆ BASE ! END? ?NONUM CHAR ÔÈÅÎ ÂÅÇÉÎ DIGIT? 0= ?NONUM ÂÅÇÉÎ ACCUMULATE ?DPL END? ?NUM CHAR DIGIT? 0= ÕÎÔÉÌ PREVIOUS PUNCTUATION? 0= ?NONUM DPL OFF END? ?NUM CHAR ÒÅÐÅÁÔ ; ÄEFER 'NUMBER? ' NUMBER? ÉS 'NUMBER? : NUMBER ( STRING -- D ) 'NUMBER? ?DUP 0= ÁBORT" ?" 0< ÉÆ EXTEND ÔÈÅÎ ; ( HIDE REVEAL IMMEDIATE RESTRICT KS) ÖARIABLE LAST 0 LAST ! Ü : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ; : HIDE LAST? ÉÆ 2- @ CURRENT @ ! ÔÈÅÎ ; : REVEAL LAST? ÉÆ 2- CURRENT @ ! ÔÈÅÎ ; : ÒECURSIVE REVEAL ; IMMEDIATE RESTRICT Ü : FLAG! ( 8B --) LAST? ÉÆ UNDER C@ OR OVER C! ÔÈÅÎ DROP ; : IMMEDIATE $40 FLAG! ; : RESTRICT $80 FLAG! ; ( CLEARSTACK HALLOT HEAP HEAP?11FEB85BP) ÃODE CLEARSTACK USER' S0 # LDY ÕÐ )Ù LDA ÓÐ STA INY ÕÐ )Ù LDA ÓÐ 1+ STA 1 # LDY ÎEXT 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 ; ( ÄOES> ; 30DEC84KS/BP) ÌABEL (DODOES> ÒÐ 2DEC ÉÐ 1+ LDA ÒÐ )Ù STA ÉÐ LDA ÒÐ Ø) STA \ PUT ÉÐ ON ÒÐ CLC × Ø) LDA 3 # ADC ÉÐ STA TXA × )Ù ADC ÉÐ 1+ STA \ ×@ + 3 -> ÉÐ ÌABEL DOCREATE 2 # LDA CLC × ADC PHA TXA × 1+ ADC ÐUSH JMP END-CODE Ü : (;CODE R> LAST @ NAME> ! ; : ÄOES> COMPILE (;CODE $4à C, COMPILE (DODOES> ; IMMEDIATE RESTRICT ( 6502-ALIGN ?HEAD Ü 08SEP84BP) Ü : 6502-ALIGN/1 ( ADR -- ADR' ) DUP $ÆÆ AND $ÆÆ = - ; Ü : 6502-ALIGN/2 ( LFA -- LFA ) HERE $ÆÆ AND $ÆÆ = ÉÆ DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID 1 LAST +! 1 ALLOT ÔÈÅÎ ; ÖARIABLE ?HEAD 0 ?HEAD ! : Ü ?HEAD @ ?EXIT -1 ?HEAD ! ; ( WARNING ÃREATE 30DEC84BP) ÖARIABLE WARNING 0 WARNING ! Ü : EXISTS? WARNING @ ?EXIT LAST @ CURRENT @ (FIND NIP ÉÆ SPACE LAST @ .NAME ." EXISTS " ?CR ÔÈÅÎ ; : ÃREATE HERE BLK @ , CURRENT @ @ , NAME C@ DUP 1 $20 UWITHIN NOT ÁBORT" INVALID NAME" HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ ÉÆ 1 ?HEAD +! DUP 6502-ALIGN/1 , \ ÐOINTER TO CODE HEAPMOVE $20 FLAG! 6502-ALIGN/1 DP ! ÅÌÓÅ 6502-ALIGN/2 DROP ÔÈÅÎ REVEAL 0 , ;ÃODE DOCREATE JMP END-CODE ( NFA? 30DEC84BP) ÃODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE) ÓÐ Ø) LDA Î 4 + STA ÓÐ )Ù LDA Î 5 + STA ÓÐ 2INC [[ [[ ÓÐ Ø) LDA Î 2+ STA ÓÐ )Ù LDA Î 3 + STA Î 2+ ORA 0= ?[ PUTÆALSE JMP ]? Î 2+ )Ù LDA ÓÐ )Ù STA Î 1+ STA Î 2+ Ø) LDA ÓÐ Ø) STA Î STA Î 1+ ORA 0= ?[ ÎEXT JMP ]? \ Î=LINK Î 2INC Î Ø) LDA PHA SEC $1Æ # AND Î ADC Î STA ÃÓ ?[ Î 1+ INC ]? PLA $20 # AND 0= NOT ?[ Î )Ù LDA PHA Î Ø) LDA Î STA PLA Î 1+ STA ]? Î LDA Î 4 + CMP 0= ?] Î 1+ LDA Î 5 + CMP 0= ?] ' 2+ @ JMP END-CODE \\ VOCABTHREAD=0 THAT IS EMPTY ÖOCABUL- ARY IN NFA? IS NOT ALLOWED ( >NAME NAME> >BODY .NAME 03FEB85BP) : >NAME ( CFA -- NFA / FALSE) VOC-LINK ÂÅÇÉÎ @ DUP ×ÈÉÌÅ 2DUP 4 - SWAP NFA? ?DUP ÉÆ -ROT 2DROP EXIT ÔÈÅÎ ÒÅÐÅÁÔ NIP ; Ü : (NAME> ( NFA -- CFA) COUNT $1Æ AND + ; : NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ $20 AND ÉÆ @ ÔÈÅÎ ; : >BODY ( CFA -- PFA) 2+ ; : .NAME ( NFA --) ?DUP ÉÆ DUP HEAP? ÉÆ ." |" ÔÈÅÎ COUNT $1Æ AND TYPE ÅÌÓÅ ." ???" ÔÈÅÎ SPACE ; \ : ; ÃONSTANT ÖARIABLE CLV16JUL87 : ÃREATE: ÃREATE HIDE CURRENT @ CONTEXT ! ] 0 ; : : ÃREATE: ;ÃODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE ÒÐ 2DEC ÉÐ LDA ÒÐ Ø) STA ÉÐ 1+ LDA ÒÐ )Ù STA × LDA CLC 2 # ADC ÉÐ STA TXA × 1+ ADC ÉÐ 1+ STA ÎEXT JMP END-CODE : ; 0 ?PAIRS COMPILE UNNEST [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT : ÃONSTANT ( 16B --) ÃREATE , ;ÃODE ÓÐ 2DEC 2 # LDY × )Ù LDA ÓÐ Ø) STA INY × )Ù LDA 1 # LDY ÓÐ )Ù STA ÎEXT JMP END-CODE : ÖARIABLE ÃREATE 2 ALLOT ; ( UALLOT ÕSER ÁLIAS 10JAN85KS/BP) : UALLOT ( QUAN -- OFFSET) DUP UDP @ + $ÆÆ U> ÁBORT" ÕSERAREA FULL" UDP @ SWAP UDP +! ; : ÕSER ÃREATE 2 UALLOT C, ;ÃODE ÓÐ 2DEC 2 # LDY × )Ù LDA CLC ÕÐ ADC ÓÐ Ø) STA TXA INY ÕÐ 1+ ADC 1 # LDY ÓÐ )Ù STA ÎEXT JMP END-CODE : ÁLIAS ( CFA --) ÃREATE LAST @ DUP C@ $20 AND ÉÆ -2 ALLOT ÅÌÓÅ $20 FLAG! ÔÈÅÎ (NAME> ! ; ( VOC-LINK VP CURRENT CONTEXT ALSO BP) ÃREATE VP $10 ALLOT ÖARIABLE CURRENT : CONTEXT ( -- ADR ) VP DUP @ + 2+ ; Ü : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ; \ "ÏNLY ÆORTH ALSO ÁSSEMBLER" GIVES VP : \ COUNTWORD = 6 |ÏNLY|ÆORTH|ÁSSEMBLER : ALSO VP @ $Á > ÅRROR" ÖOCABULARY STACK FULL" CONTEXT @ 2 VP +! CONTEXT ! ; : TOSS -2 VP +! ; ( ÖOCABULARY ÆORTH ÏNLY ÆORTH-83 KS/BP) : ÖOCABULARY ÃREATE 0 , 0 , HERE VOC-LINK @ , VOC-LINK ! ÄOES> CONTEXT ! ; \ ÎAME Ü ÃODE Ü ÔHREAD Ü ÃOLDTHREAD Ü \ ÖOC-LINK ÖOCABULARY ÆORTH ÖOCABULARY ÏNLY ] ÄOES> [ ÏNLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ÏNLY ! : ÏNLYFORTH ÏNLY ÆORTH ALSO DEFINITIONS ; ( DEFINITIONS ORDER WORDS 13JAN84BP/KS) : DEFINITIONS CONTEXT @ CURRENT ! ; Ü : .VOC ( ADR -- ) @ 2- >NAME .NAME ; : ORDER THRU.VOCSTACK ÄÏ É .VOC -2 +ÌÏÏÐ 2 SPACES CURRENT .VOC ; : WORDS CONTEXT @ ÂÅÇÉÎ @ DUP STOP? 0= AND ×ÈÉÌÅ ?CR DUP 2+ .NAME SPACE ÒÅÐÅÁÔ DROP ; ( (FIND 08APR85BP) ÃODE (FIND ( STRING THREAD -- STRING FALSE / NAMEFIELD TRUE) 3 # LDY [[ ÓÐ )Ù LDA Î ,Ù STA DEY 0< ?] Î 2+ Ø) LDA $1Æ # AND Î 4 + STA ÌABEL FINDLOOP 0 # LDY Î )Ù LDA TAX INY Î )Ù LDA Î 1+ STA Î STX Î ORA 0= ?[ 1 # LDY 0 # LDX PUTÆALSE JMP ]? INY Î )Ù LDA $1Æ # AND Î 4 + CMP FINDLOOP BNE \ COUNTBYTE MATCH CLC 2 # LDA Î ADC Î 5 + STA 0 # LDA Î 1+ ADC Î 6 + STA Î 4 + LDY [[ Î 2+ )Ù LDA Î 5 + )Ù CMP FINDLOOP BNE DEY 0= ?] 3 # LDY Î 6 + LDA ÓÐ )Ù STA DEY Î 5 + LDA ÓÐ )Ù STA DEY 0 # LDX PUTÔRUE JMP END-CODE ( FOUND 29JAN85BP) Ü ÃODE FOUND ( NFA -- CFA N ) ÓÐ Ø) LDA Î STA ÓÐ )Ù LDA Î 1+ STA Î Ø) LDA Î 2+ STA $1Æ # AND SEC Î ADC Î STA ÃÓ ?[ Î 1+ INC ]? Î 2+ LDA $20 # AND 0= ?[ Î LDA ÓÐ Ø) STA Î 1+ LDA ][ Î Ø) LDA ÓÐ Ø) STA Î )Ù LDA ]? ÓÐ )Ù STA ÓÐ 2DEC Î 2+ LDA 0< ?[ INY ]? .Á ASL 0< NOT ?[ TYA $ÆÆ # EOR TAY INY ]? TYA ÓÐ Ø) STA 0< ?[ $ÆÆ # LDA 24 C, ]? TXA 1 # LDY ÓÐ )Ù STA ÎEXT JMP END-CODE \\ Ü : FOUND ( NFA -- CFA N ) DUP C@ >R (NAME> R@ $20 AND ÉÆ @ ÔÈÅÎ -1 R@ $80 AND ÉÆ 1- ÔÈÅÎ R> $40 AND ÉÆ NEGATE ÔÈÅÎ ; ( FIND ' ['] 13JAN85BP) : FIND ( STRING -- CFA N / STRING FALSE) CONTEXT DUP @ OVER 2- @ = ÉÆ 2- ÔÈÅÎ ÂÅÇÉÎ UNDER @ (FIND ÉÆ NIP FOUND EXIT ÔÈÅÎ OVER VP 2+ U> ×ÈÉÌÅ SWAP 2- ÒÅÐÅÁÔ NIP FALSE ; : ' ( -- CFA ) NAME FIND 0= ÁBORT" ×HAT?" ; : [COMPILE] ' , ; IMMEDIATE RESTRICT : ['] ' [COMPILE] ÌITERAL ; IMMEDIATE RESTRICT : NULLSTRING? ( STRING -- STRING FALSE / TRUE) DUP C@ 0= DUP ÉÆ NIP ÔÈÅÎ ; ( >INTERPRET 28FEB85BP) ÌABEL JUMP INY CLC × )Ù LDA 2 # ADC ÉÐ STA INY × )Ù LDA 0 # ADC ÉÐ 1+ STA 1 # LDY ÎEXT JMP END-CODE ÖARIABLE >INTERPRET JUMP ' >INTERPRET ! \\ MAKE ÖARIABLE >INTERPRET TO SPECIAL ÄEFER ( INTERPRET INTERACTIVE 01OCT87CLV/RE) ÄEFER NOTFOUND : NO.EXTENSIONS ( STRING -- ) ÅRROR" ÈAEH?" ; \ STRING NOT 0 ' NO.EXTENSIONS ÉS NOTFOUND : INTERPRET >INTERPRET ; Ü : INTERACTIVE ?STACK NAME FIND ?DUP ÉÆ 1 AND ÉÆ EXECUTE >INTERPRET ÔÈÅÎ ÁBORT" COMPILE ONLY" ÔÈÅÎ NULLSTRING? ?EXIT 'NUMBER? 0= ÉÆ NOTFOUND ÔÈÅÎ >INTERPRET ; ' INTERACTIVE >INTERPRET ! ( COMPILING [ ] 01OCT87CLV/RE) Ü : COMPILING ?STACK NAME FIND ?DUP ÉÆ 0> ÉÆ EXECUTE >INTERPRET ÔÈÅÎ , >INTERPRET ÔÈÅÎ NULLSTRINA |