From 1c51dae7d8e272e3569a662754668ad7eda96b81 Mon Sep 17 00:00:00 2001 From: Joel Matthew Rees Date: Tue, 22 Jan 2019 15:43:40 +0900 Subject: [PATCH] Early start on hand-translating the 6800 model by Dave Lion, et. al. --- fig-forth_6809.asm | 3673 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 3673 insertions(+) create mode 100644 fig-forth_6809.asm diff --git a/fig-forth_6809.asm b/fig-forth_6809.asm new file mode 100644 index 0000000..2bda3af --- /dev/null +++ b/fig-forth_6809.asm @@ -0,0 +1,3673 @@ +* OPT PRT + +* fig-FORTH FOR 6800 -- converted mechanically to 6809 +* ASSEMBLY SOURCE LISTING + +* RELEASE 1 +* MAY 1979 +* WITH COMPILER SECURITY +* AND VARIABLE LENGTH NAMES + +* RELEASE 1.00.01 +* April 2018 +* Modified for TRS-80/Tandy Color Computer, Dragon, etc., JMR + +* This public domain publication is provided +* through the courtesy of: +* FORTH +* INTEREST +* GROUP +* fig + +* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668 +* Further distribution must include this notice. + PAGE + NAM Copyright:FORTH Interest Group + OPT GEN,PAG +* filename FTH7.21 +* === FORTH-6800 06-06-79 21:OO + + +* The following constitutes the original license: +*=====================LICENSE==================== +* This listing is in the PUBLIC DOMAIN and +* may be freely copied or published with the +* restriction that a credit line is printed +* with the material, crediting the +* authors and the FORTH INTEREST GROUP. + +* === by Dave Lion, +* === with help from +* === Bob Smith, +* === LaFarr Stuart, +* === The Forth Interest Group +* === PO Box 1105 +* === San Carlos, CA 94070 +* === and +* === Unbounded Computing +* === 1134-K Aster Ave. +* === Sunnyvale, CA 94086 +*===================END-LICENSE================== +* Note that the assertion of attribution terms contradicts with a +* pure assignment to the public domain. +* Because of the terms, copyright should be understood +* to be asserted by the authors. +* Attribution, according to the above, should be understood +* to be required. +* +* === Conversion to 6809 +* === and modifications for Color Computer, etc., by Joel Rees, Reiisi Kenkyuu +* Conversions and modifications copyright Joel Rees, 2018. +* Permission to use, modify, distribute, and publish the modifications +* is extended under the attribution terms given above, +* with the explicitly affirmed obligation to retain intact +* all authorship and copyright notices, and license notices. +* +* Note that, under my (Joel Rees) recollection and understanding of the +* legal/political context of the original context of publication, +* right to use source code in one's possession was not considered +* deniable in any practical or meaningful sense. +* (Laws such as the DMCA had been proposed by certain advocates for +* the concept of intellectual property under other names, +* but were considered unenforceable and impracticable, +* thus contrary to the purpose of law, +* a waste of resources, and the height of discourtesy +* by the general community of software practicioners at the time, +* to the best of my understanding and recollection.) +* Thus, the lack of explicit mention of a right to use in the terms of +* the effective license should in no wise be considered to imply a +* witholding thereof. +* === +* +* This version was developed on an AMI EVK 300 PROTO +* system using an ACIA for the I/O. All terminal 1/0 +* is done in three subroutines: +* PEMIT ( word # 182 ) +* PKEY ( 183 ) +* PQTERM ( 184 ) +* =6809= See the above routines for Color Computer calls. JMR +* +* The FORTH words for disc related I/O follow the model +* of the FORTH Interest Group, but have not been +* tested using a real disc. +* === True disk I/O not implemented in v. 1.00.01. JMR +* +* Addresses in this implementation reflect the fact that, +* on the development system, it was convenient to +* write-protect memory at hex 1000, and leave the first +* 4K bytes write-enabled. As a consequence, code from +* location $1000 to lable ZZZZ could be put in ROM. +* Minor deviations from the model were made in the +* initialization and words ?STACK and FORGET +* in order to do this. +* =6809= Note that there is no write-protect on stock Color Computer, +* =6809= and other addresses will be adjusted, rather, for the Color Computer hardware. +* + + +* +NBLK EQU 4 # of disc buffer blocks for virtual memory +* MEMEND EQU 132*NBLK+$3000 end of ram +MEMEND EQU 132*NBLK+$4000+132 end of ram with some breathing room +* each block is 132 bytes in size, +* holding 128 characters +* +* MEMTOP EQU $3FFF absolute end of all ram +MEMTOP EQU $7FFF putative absolute end of all ram +* ACIAC EQU $FBCE the ACIA control address and +ACIAC EQU $FCF4 the ACIA control address and +ACIAD EQU ACIAC+1 data address for PROTO +* =6809= There is no ACIA (darn it!), but we need the addresses until we redefine the I/O routines. + PAGE +* MEMORY MAP for this (not) 16K system: +* ( (*not*) positioned so that systems with 4k byte write- +* protected segments can write protect FORTH ) +* +* addr. contents pointer init by +* **** ******************************* ******* ****** +* 3FFF (6FFF) HI +* substitute for disc mass memory +* 3210 (5294) LO,MEMEND +* 320F (5293) +* 4 buffer sectors of VIRTUAL MEMORY +* 3000 (5084) FIRST +* >>>>>> memory from here up must be RAM <<<<<< +* +* 27FF (37FF, but 38XX, with debugging code included the the "ROMable" image.) +* 6k of romable "FORTH" <== IP ABORT +* <== W +* the VIRTUAL FORTH MACHINE +* +* 1004 <<< WARM START ENTRY >>> (4004) +* 1000 <<< COLD START ENTRY >>> (4000) +* +* >>>>>> memory from here down must be RAM <<<<<< +* FFE (3FF0) RETURN STACK base <== RP RINIT +* +* FB4 (less than 3EB4) +* INPUT LINE BUFFER +* holds up to 132 characters +* and is scanned upward by IN +* starting at TIB +* F30 (3E00) <== IN TIB +* F2F (3DF0) DATA STACK <== SP SP0,SINIT +* | grows downward from F2F +* v +* - - +* | +* I DICTIONARY grows upward +* +* 183 (1483) end of ram-dictionary. <== DP DPINIT +* "TASK" +* +* 150 (1450) "FORTH" ( a word ) <=, <== CONTEXT +* `==== CURRENT +* 148 (1448) start of ram-dictionary. +* +* 100 (1400) user #l table of variables <= UP DPINIT +* F0 (13B0) registers & pointers for the virtual machine +* scratch area used by various words +* E0 (13A0) lowest address used by FORTH +* +* 0000 + PAGE +*** +* +* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS : +* +* IP points to the current instruction ( pre-increment mode ) +* RP points to second free byte (first free word) in return stack +* =6809= S stack will be the return/flow-of-control stack. +* SP (hardware SP) points to first free byte in data stack += =6809= U stack will be the parameter stack. +* +* when A and B hold one 16 bit FORTH data word, +* A contains the high byte, B, the low byte. +*** + + + + +* ORG $E0 variables + ORG $13A0 variables + + +* N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY, +* SP@,SWAP,DOES>,COLD +* =6809= All these will use scratch space on stack, to the extent they need it. + + +* These locations are used by the TRACE routine : + +TRLIM RMB 1 the count for tracing without user intervention +TRACEM RMB 1 non-zero = trace mode +BRKPT RMB 2 the breakpoint address at which +* the program will go into trace mode +VECT RMB 2 vector to machine code +* (only needed if the TRACE routine is resident) + + +* Registers used by the FORTH virtual machine: +* Starting at $OOFO ($00B0): + + +W RMB 2 the instruction register points to 6800 code +IP RMB 2 the instruction pointer points to pointer to 6800 code +* =6809= after NEXT, Y will retain IP, and X will retain W until overwritten +* RP RMB 2 the return stack pointer +* =6809= S stack is fine for the flow of control stack. +* =6809= SP will be U +UP RMB 2 the pointer to base of current user's 'USER' table +* ( altered during multi-tasking ) +* UP will be early in the DP variables. +* +* For the tracer: +* =6809= Trace variables will also be in the direct page. + RMB 4 +TRASP RMB 2 +TRAVEC RMB 2 +TRAA RMB 1 +TRAB RMB 1 +* + PAGE +* This system is shown with one user, but additional users +* may be added by allocating additional user tables: +* UORIG2 RMB 64 data table for user #2 +* +* +* =6809= Should the TASK record be in the DP or not? +* Some of this stuff gets initialized during +* COLD start and WARM start: +* [ names correspond to FORTH words of similar (no X) name ] +* + ORG $100 +* ORG $1100 +UORIG RMB 6 3 reserved variables +XSPZER RMB 2 initial top of data stack for this user +XRZERO RMB 2 initial top of return stack +XTIB RMB 2 start of terminal input buffer +XWIDTH RMB 2 name field width +XWARN RMB 2 warning message mode (0 = no disc) +XFENCE RMB 2 fence for FORGET +XDP RMB 2 dictionary pointer +XVOCL RMB 2 vocabulary linking +XBLK RMB 2 disc block being accessed +XIN RMB 2 scan pointer into the block +XOUT RMB 2 cursor position +XSCR RMB 2 disc screen being accessed ( O=terminal ) +XOFSET RMB 2 disc sector offset for multi-disc +XCONT RMB 2 last word in primary search vocabulary +XCURR RMB 2 last word in extensible vocabulary +XSTATE RMB 2 flag for 'interpret' or 'compile' modes +XBASE RMB 2 number base for I/O numeric conversion +XDPL RMB 2 decimal point place +XFLD RMB 2 +XCSP RMB 2 current stack position, for compile checks +XRNUM RMB 2 +XHLD RMB 2 +XDELAY RMB 2 carriage return delay count +XCOLUM RMB 2 carriage width +IOSTAT RMB 2 last acia status from write/read + RMB 2 ( 4 spares! ) + RMB 2 + RMB 2 + RMB 2 + + + + +* +* +* end of user table, start of common system variables +* +* +* +XUSE RMB 2 +XPREV RMB 2 + RMB 4 ( spares ) + + PAGE +* These things, up through the lable 'REND', are overwritten +* at time of cold load and should have the same contents +* as shown here: +* + FCB $C5 immediate + FCC 4,FORTH + FCB $C8 + FDB NOOP-7 +FORTH FDB DODOES,DOVOC,$81A0,TASK-7 + FDB 0 +* + FCC "(C) Forth Interest Group, 1979" + + FCB $84 + FCC 3,TASK + FCB $CB + FDB FORTH-8 +TASK FDB DOCOL,SEMIS +* +REND EQU * ( first empty location in dictionary ) + + PAGE +* The FORTH program ( address $1000 ($2000) to $27FF (37FF?) ) is written +* so that it can be in a ROM, or write-protected if desired + ORG $2000 + +* ######>> screen 3 << +* +*************************** +** C O L D E N T R Y ** +*************************** +ORIG NOP + JMP CENT +*************************** +** W A R M E N T R Y ** +*************************** + NOP + JMP WENT warm-start code, keeps current dictionary intact + +* +******* startup parmeters ************************** +* + FDB $6800,0000 cpu & revision + FDB 0 topmost word in FORTH vocabulary +BACKSP FDB $7F backspace character for editing +UPINIT FDB UORIG initial user area +*SINIT FDB ORIG-$D0 initial top of data stack +SINIT FDB ORIG-$210 initial top of data stack +*RINIT FDB ORIG-2 initial top of return stack +RINIT FDB ORIG-$10 initial top of return stack +* FDB ORIG-$D0 terminal input buffer + FDB ORIG-$200 terminal input buffer + FDB 31 initial name field width + FDB 0 initial warning mode (0 = no disc) +FENCIN FDB REND initial fence +DPINIT FDB REND cold start value for DP +VOCINT FDB FORTH+8 +COLINT FDB 132 initial terminal carriage width +DELINT FDB 4 initial carriage return delay +**************************************************** +* + PAGE +* +* ######>> screen 13 << +* PULABX PUL A 24 cycles until 'NEXT' +* PUL B +* STABX STA A 0,X 16 cycles until 'NEXT' +* STA B 1,X +* BRA NEXT +* GETX LDA A 0,X 18 cycles until 'NEXT' +* LDA B 1,X +* PUSHBA PSH B 8 cycles until 'NEXT' +* PSH A +* PULABX PUL A 24 cycles until 'NEXT' +* PUL B +* STABX STA A 0,X 16 cycles until 'NEXT' +* STA B 1,X +* BRA NEXT +* GETX LDA A 0,X 18 cycles until 'NEXT' +* LDA B 1,X +* +* =6809= These really aren't all that useful. +PULABX PULU D +STABX STD ,X + BRA NEXT ; Used less than seven times. +GETX LDD ,X +PUSHBA PSHU D ; Used only seven times, saves only 14 bytes. + * Must fall through to NEXT + + +* +* "NEXT" takes 38 cycles if TRACE is removed, +* +* and 95 cycles if NOT tracing. +* +* = = = = = = = t h e v i r t u a l m a c h i n e = = = = = +* = +* NEXT LDX IP +* INX pre-increment mode +* INX +* STX IP +* NEXT2 LDX 0,X get W which points to CFA of word to be done +* NEXT3 STX W +* LDX 0,X get VECT which points to executable code +NEXT LDX ' + TSX + BSR PHEX4F + LDA A #' ' + BSR PHEX4F +* + JSR PCR + LDX TRAVEC +* +* NEXTGO JMP 0,X +NEXTGO JMP [,Y++] +* NOP +* JMP TRACE ( an alternate for the above ) +* = +*DBG +PHEX4F JSR PEMIT + BSR PHEXX2 + BSR PHEXX2 + LDA A #' ' + JSR PEMIT + RTS +PHEXX2 LDA A 0,X + LSR A + LSR A + LSR A + LSR A + JSR PHEXD + LDA A 0,X + JSR PHEXD + INX + RTS +PHEXD AND A #$0F + CMP A #10 + BLO PHEXDH + ADD A #7 ; 'A'-'9'+1 +PHEXDH ADD A #'0' + JSR PEMIT + RTS +*DBG +* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = + + + PAGE +* +* ======>> 1 << + FCB $83 + FCC 2,LIT NOTE: this is different from LITERAL + FCB $D4 + FDB 0 link of zero to terminate dictionary scan +LIT FDB *+2 +* LDX IP +* INX +* INX +* STX IP +* LDA A 0,X +* LDA B 1,X +* JMP PUSHBA + LDD ,X++ + STX > screen 14 << +* ======>> 2 << +*DBG + FCB $85 + FCC 4,XCLIT ; for debugging + FCB $D4 + FDB LIT-6 ; should never link +*DBG +CLITER FDB *+2 (this is an invisible word, with no header) +* LDX IP +* INX +* STX IP +* CLR A +* LDA B 1,X +* JMP PUSHBA + LDB ,X+ + CLR A + STX > 3 << + FCB $87 + FCC 6,EXECUTE + FCB $C5 + FDB LIT-6 +EXEC FDB *+2 +* TSX +* LDX 0,X get code field address (CFA) +* INS pop stack +* INS +* JMP NEXT3 + PULU Y + JMP NEXTSW +* +* ######>> screen 15 << +* ======>> 4 << + FCB $86 + FCC 5,BRANCH + FCB $C8 + FDB EXEC-10 +BRAN FDB ZBYES Go steal code in ZBRANCH +* +* ======>> 5 << + FCB $87 + FCC 6,0BRANCH + FCB $C8 + FDB BRAN-9 +ZBRAN FDB *+2 +* PULA +* PULB +* ABA +* BNE ZBNO +* BCS ZBNO + LDD ,U++ ; set flags + BNE ZBNO +* ZBYES LDX > screen 16 << +* ======>> 6 << + FCB $86 + FCC 5,(LOOP) + FCB $A9 + FDB ZBRAN-10 +XLOOP FDB *+2 +* CLR A +* LDA B #1 get set to increment counter by 1 +* BRA XPLOP2 go steal other guy's code! + LDD #1 + BRA XPLOPP +* +* ======>> 7 << + FCB $87 + FCC 6,(+LOOP) + FCB $A9 + FDB XLOOP-9 +XPLOOP FDB *+2 Note: +LOOP has an un-signed loop counter +* PUL A get increment +* PUL B +* XPLOP2 TST A +* BPL XPLOF forward looping +* BSR XPLOPS +* SEC +* SBC B 5,X +* SBC A 4,X +* BPL ZBYES +* BRA XPLONO fall through + LDD +* +* the subroutine : +XPLOPS LDX RP + ADD B 3,X add it to counter + ADC A 2,X + STA B 3,X store new counter value + STA A 2,X + RTS +* +XPLOF BSR XPLOPS + SUB B 5,X + SBC A 4,X + BMI ZBYES +* +XPLONO INX done, don't branch back + INX + INX + INX + STX RP + BRA ZBNO use ZBRAN to skip over unused delta +* +* ######>> screen 17 << +* ======>> 8 << + FCB $84 + FCC 3,(DO) + FCB $A9 + FDB XPLOOP-10 +XDO FDB *+2 This is the RUNTIME DO, not the COMPILING DO + LDX RP + DEX + DEX + DEX + DEX + STX RP + PUL A + PUL B + STA A 2,X + STA B 3,X + PUL A + PUL B + STA A 4,X + STA B 5,X + JMP NEXT +* +* ======>> 9 << + FCB $81 I + FCB $C9 + FDB XDO-7 +I FDB *+2 + LDX RP + INX + INX + JMP GETX +* +* ######>> screen 18 << +* ======>> 10 << + FCB $85 + FCC 4,DIGIT + FCB $D4 + FDB I-4 +DIGIT FDB *+2 NOTE: legal input range is 0-9, A-Z + TSX + LDA A 3,X + SUB A #$30 ascii zero + BMI DIGIT2 IF LESS THAN '0', ILLEGAL + CMP A #$A + BMI DIGIT0 IF '9' OR LESS + CMP A #$11 + BMI DIGIT2 if less than 'A' + CMP A #$2B + BPL DIGIT2 if greater than 'Z' + SUB A #7 translate 'A' thru 'F' +DIGIT0 CMP A 1,X + BPL DIGIT2 if not less than the base + LDA B #1 set flag + STA A 3,X store digit +DIGIT1 STA B 1,X store the flag + JMP NEXT +DIGIT2 CLR B + INS + INS pop bottom number + TSX + STA B 0,X make sure both bytes are 00 + BRA DIGIT1 +* +* ######>> screen 19 << +* +* The word format in the dictionary is: +* +* char-count + $80 lowest address +* char 1 +* char 2 +* +* char n + $80 +* link high byte \___point to previous word +* link low byte / +* CFA high byte \___pnt to 6800 code +* CFA low byte / +* parameter fields +* " +* " +* " +* +* ======>> 11 << + FCB $86 + FCC 5,(FIND) + FCB $A9 + FDB DIGIT-8 +PFIND FDB *+2 + NOP + NOP +PD EQU N ptr to dict word being checked +PA0 EQU N+2 +PA EQU N+4 +PC EQU N+6 + LDX #PD + LDA B #4 +PFIND0 PUL A loop to get arguments + STA A 0,X + INX + DEC B + BNE PFIND0 +* + LDX PD +PFIND1 LDA B 0,X get count dict count + STA B PC + AND B #$3F + INX + STX PD update PD + LDX PA0 + LDA A 0,X get count from arg + INX + STX PA intialize PA + CBA compare lengths + BNE PFIND4 +PFIND2 LDX PA + LDA A 0,X + INX + STX PA + LDX PD + LDA B 0,X + INX + STX PD + TST B is dict entry neg. ? + BPL PFIND8 + AND B #$7F clear sign + CBA + BEQ FOUND +PFIND3 LDX 0,X get new link + BNE PFIND1 continue if link not=0 +* +* not found : +* + CLR A + CLR B + JMP PUSHBA +PFIND8 CBA + BEQ PFIND2 +PFIND4 LDX PD +PFIND9 LDA B 0,X scan forward to end of this name + INX + BPL PFIND9 + BRA PFIND3 +* +* found : +* +FOUND LDA A PD compute CFA + LDA B PD+1 + ADD B #4 + ADC A #0 + PSH B + PSH A + LDA A PC + PSH A + CLR A + PSH A + LDA B #1 + JMP PUSHBA +* + PSH A + CLR A + PSH A + LDA B #1 + JMP PUSHBA +* +* ######>> screen 20 << +* ======>> 12 << + FCB $87 + FCC 6,ENCLOSE + FCB $C5 + FDB PFIND-9 +* NOTE : +* FC means offset (bytes) to First Character of next word +* EW " " to End of Word +* NC " " to Next Character to start next enclose at +ENCLOS FDB *+2 + INS + PUL B now, get the low byte, for an 8-bit delimiter + TSX + LDX 0,X + CLR N +* wait for a non-delimiter or a NUL +ENCL2 LDA A 0,X + BEQ ENCL6 + CBA CHECK FOR DELIM + BNE ENCL3 + INX + INC N + BRA ENCL2 +* found first character. Push FC +ENCL3 LDA A N found first char. + PSH A + CLR A + PSH A +* wait for a delimiter or a NUL +ENCL4 LDA A 0,X + BEQ ENCL7 + CBA ckech for delim. + BEQ ENCL5 + INX + INC N + BRA ENCL4 +* found EW. Push it +ENCL5 LDA B N + CLR A + PSH B + PSH A +* advance and push NC + INC B + JMP PUSHBA +* found NUL before non-delimiter, therefore there is no word +ENCL6 LDA B N found NUL + PSH B + PSH A + INC B + BRA ENCL7+2 +* found NUL following the word instead of SPACE +ENCL7 LDA B N + PSH B save EW + PSH A +ENCL8 LDA B N save NC + JMP PUSHBA + + PAGE +* +* ######>> screen 21 << +* The next 4 words call system dependant I/O routines +* which are listed after word "-->" ( lable: "arrow" ) +* in the dictionary. +* +* ======>> 13 << + FCB $84 + FCC 3,EMIT + FCB $D4 + FDB ENCLOS-10 +EMIT FDB *+2 + PUL A + PUL A + JSR PEMIT + LDX UP + INC XOUT+1-UORIG,X + BNE *+4 + INC XOUT-UORIG,X + JMP NEXT +* +* ======>> 14 << + FCB $83 + FCC 2,KEY + FCB $D9 + FDB EMIT-7 +KEY FDB *+2 + JSR PKEY + PSH A + CLR A + PSH A + JMP NEXT +* +* ======>> 15 << + FCB $89 + FCC 8,?TERMINAL + FCB $CC + FDB KEY-6 +QTERM FDB *+2 + JSR PQTER + CLR B + JMP PUSHBA stack the flag +* +* ======>> 16 << + FCB $82 + FCC 1,CR + FCB $D2 + FDB QTERM-12 +CR FDB *+2 + JSR PCR + JMP NEXT +* +* ######>> screen 22 << +* ======>> 17 << + FCB $85 + FCC 4,CMOVE source, destination, count + FCB $C5 + FDB CR-5 +CMOVE FDB *+2 takes ( 43+47*count cycles ) + LDX #N + LDA B #6 +CMOV1 PUL A + STA A 0,X move parameters to scratch area + INX + DEC B + BNE CMOV1 +CMOV2 LDA A N + LDA B N+1 + SUB B #1 + SBC A #0 + STA A N + STA B N+1 + BCS CMOV3 + LDX N+4 + LDA A 0,X + INX + STX N+4 + LDX N+2 + STA A 0,X + INX + STX N+2 + BRA CMOV2 +CMOV3 JMP NEXT +* +* ######>> screen 23 << +* ======>> 18 << + FCB $82 + FCC 1,U* + FCB $AA + FDB CMOVE-8 +USTAR FDB *+2 + BSR USTARS + INS + INS + JMP PUSHBA +* +* The following is a subroutine which +* multiplies top 2 words on stack, +* leaving 32-bit result: high order word in A,B +* low order word in 2nd word of stack. +* +USTARS LDA A #16 bits/word counter + PSH A + CLR A + CLR B + TSX +USTAR2 ROR 5,X shift multiplier + ROR 6,X + DEC 0,X done? + BMI USTAR4 + BCC USTAR3 + ADD B 4,X + ADC A 3,X +USTAR3 ROR A + ROR B shift result + BRA USTAR2 +USTAR4 INS dump counter + RTS +* +* ######>> screen 24 << +* ======>> 19 << + FCB $82 + FCC 1,U/ + FCB $AF + FDB USTAR-5 +USLASH FDB *+2 + LDA A #17 + PSH A + TSX + LDA A 3,X + LDA B 4,X +USL1 CMP A 1,X + BHI USL3 + BCS USL2 + CMP B 2,X + BCC USL3 +USL2 CLC + BRA USL4 +USL3 SUB B 2,X + SBC A 1,X + SEC +USL4 ROL 6,X + ROL 5,X + DEC 0,X + BEQ USL5 + ROL B + ROL A + BCC USL1 + BRA USL3 +USL5 INS + INS + INS + INS + INS + JMP SWAP+4 reverse quotient & remainder +* +* ######>> screen 25 << +* ======>> 20 << + FCB $83 + FCC 2,AND + FCB $C4 + FDB USLASH-5 +AND FDB *+2 + PUL A + PUL B + TSX + AND B 1,X + AND A 0,X + JMP STABX +* +* ======>> 21 << + FCB $82 + FCC 1,OR + FCB $D2 + FDB AND-6 +OR FDB *+2 + PUL A + PUL B + TSX + ORA B 1,X + ORA A 0,X + JMP STABX +* +* ======>> 22 << + FCB $83 + FCC 2,XOR + FCB $D2 + FDB OR-5 +XOR FDB *+2 + PUL A + PUL B + TSX + EOR B 1,X + EOR A 0,X + JMP STABX +* +* ######>> screen 26 << +* ======>> 23 << + FCB $83 + FCC 2,SP@ + FCB $C0 + FDB XOR-6 +SPAT FDB *+2 + TSX + STX N scratch area + LDX #N + JMP GETX +* +* ======>> 24 << + FCB $83 + FCC 2,SP! + FCB $A1 + FDB SPAT-6 +SPSTOR FDB *+2 + LDX UP + LDX XSPZER-UORIG,X + TXS watch it ! X and S are not equal. + JMP NEXT +* ======>> 25 << + FCB $83 + FCC 2,RP! + FCB $A1 + FDB SPSTOR-6 +RPSTOR FDB *+2 + LDX RINIT initialize from rom constant + STX RP + JMP NEXT +* +* ======>> 26 << + FCB $82 + FCC 1,;S + FCB $D3 + FDB RPSTOR-6 +SEMIS FDB *+2 + LDX RP + INX + INX + STX RP + LDX 0,X get address we have just finished. + JMP NEXT+2 increment the return address & do next word +* +* ######>> screen 27 << +* ======>> 27 << + FCB $85 + FCC 4,LEAVE + FCB $C5 + FDB SEMIS-5 +LEAVE FDB *+2 + LDX RP + LDA A 2,X + LDA B 3,X + STA A 4,X + STA B 5,X + JMP NEXT +* +* ======>> 28 << + FCB $82 + FCC 1,>R + FCB $D2 + FDB LEAVE-8 +TOR FDB *+2 + LDX RP + DEX + DEX + STX RP + PUL A + PUL B + STA A 2,X + STA B 3,X + JMP NEXT +* +* ======>> 29 << + FCB $82 + FCC 1,R> + FCB $BE + FDB TOR-5 +FROMR FDB *+2 + LDX RP + LDA A 2,X + LDA B 3,X + INX + INX + STX RP + JMP PUSHBA +* +* ======>> 30 << + FCB $81 R + FCB $D2 + FDB FROMR-5 +R FDB *+2 + LDX RP + INX + INX + JMP GETX +* +* ######>> screen 28 << +* ======>> 31 << + FCB $82 + FCC 1,0= + FCB $BD + FDB R-4 +ZEQU FDB *+2 + TSX + CLR A + CLR B + LDX 0,X + BNE ZEQU2 + INC B +ZEQU2 TSX + JMP STABX +* +* ======>> 32 << + FCB $82 + FCC 1,0< + FCB $BC + FDB ZEQU-5 +ZLESS FDB *+2 + TSX + LDA A #$80 check the sign bit + AND A 0,X + BEQ ZLESS2 + CLR A if neg. + LDA B #1 + JMP STABX +ZLESS2 CLR B + JMP STABX +* +* ######>> screen 29 << +* ======>> 33 << + FCB $81 '+' + FCB $AB + FDB ZLESS-5 +PLUS FDB *+2 + PUL A + PUL B + TSX + ADD B 1,X + ADC A 0,X + JMP STABX +* +* ======>> 34 << + FCB $82 + FCC 1,D+ + FCB $AB + FDB PLUS-4 +DPLUS FDB *+2 + TSX + CLC + LDA B #4 +DPLUS2 LDA A 3,X + ADC A 7,X + STA A 7,X + DEX + DEC B + BNE DPLUS2 + INS + INS + INS + INS + JMP NEXT +* +* ======>> 35 << + FCB $85 + FCC 4,MINUS + FCB $D3 + FDB DPLUS-5 +MINUS FDB *+2 + TSX + NEG 1,X + BCC MINUS2 + NEG 0,X + BRA MINUS3 +MINUS2 COM 0,X +MINUS3 JMP NEXT +* +* ======>> 36 << + FCB $86 + FCC 5,DMINUS + FCB $D3 + FDB MINUS-8 +DMINUS FDB *+2 + TSX + COM 0,X + COM 1,X + COM 2,X + NEG 3,X + BNE DMINX + INC 2,X + BNE DMINX + INC 1,X + BNE DMINX + INC 0,X +DMINX JMP NEXT +* +* ######>> screen 30 << +* ======>> 37 << + FCB $84 + FCC 3,OVER + FCB $D2 + FDB DMINUS-9 +OVER FDB *+2 + TSX + LDA A 2,X + LDA B 3,X + JMP PUSHBA +* +* ======>> 38 << + FCB $84 + FCC 3,DROP + FCB $D0 + FDB OVER-7 +DROP FDB *+2 + INS + INS + JMP NEXT +* +* ======>> 39 << + FCB $84 + FCC 3,SWAP + FCB $D0 + FDB DROP-7 +SWAP FDB *+2 + PUL A + PUL B + TSX + LDX 0,X + INS + INS + PSH B + PSH A + STX N + LDX #N + JMP GETX +* +* ======>> 40 << + FCB $83 + FCC 2,DUP + FCB $D0 + FDB SWAP-7 +DUP FDB *+2 + PUL A + PUL B + PSH B + PSH A + JMP PUSHBA +* +* ######>> screen 31 << +* ======>> 41 << + FCB $82 + FCC 1,+! + FCB $A1 + FDB DUP-6 +PSTORE FDB *+2 + TSX + LDX 0,X + INS + INS + PUL A get stack data + PUL B + ADD B 1,X add & store low byte + STA B 1,X + ADC A 0,X add & store hi byte + STA A 0,X + JMP NEXT +* +* ======>> 42 << + FCB $86 + FCC 5,TOGGLE + FCB $C5 + FDB PSTORE-5 +TOGGLE FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE + FDB SEMIS +* +* ######>> screen 32 << +* ======>> 43 << + FCB $81 @ + FCB $C0 + FDB TOGGLE-9 +AT FDB *+2 + TSX + LDX 0,X get address + INS + INS + JMP GETX +* +* ======>> 44 << + FCB $82 + FCC 1,C@ + FCB $C0 + FDB AT-4 +CAT FDB *+2 + TSX + LDX 0,X + CLR A + LDA B 0,X + INS + INS + JMP PUSHBA +* +* ======>> 45 << + FCB $81 + FCB $A1 + FDB CAT-5 +STORE FDB *+2 + TSX + LDX 0,X get address + INS + INS + JMP PULABX +* +* ======>> 46 << + FCB $82 + FCC 1,C! + FCB $A1 + FDB STORE-4 +CSTORE FDB *+2 + TSX + LDX 0,X get address + INS + INS + INS + PUL B + STA B 0,X + JMP NEXT + PAGE +* +* ######>> screen 33 << +* ======>> 47 << + FCB $C1 : immediate + FCB $BA + FDB CSTORE-5 +COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE + FDB CREATE,RBRAK + FDB PSCODE + +* Here is the IP pusher for allowing +* nested words in the virtual machine: +* ( ;S is the equivalent un-nester ) + +DOCOL LDX RP make room in the stack + DEX + DEX + STX RP + LDA A IP + LDA B IP+1 + STA A 2,X Store address of the high level word + STA B 3,X that we are starting to execute + LDX W Get first sub-word of that definition + JMP NEXT+2 and execute it +* +* ======>> 48 << + FCB $C1 ; imnediate code + FCB $BB + FDB COLON-4 +SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK + FDB SEMIS +* +* ######>> screen 34 << +* ======>> 49 << + FCB $88 + FCC 7,CONSTANT + FCB $D4 + FDB SEMI-4 +CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE +DOCON LDX W + LDA A 2,X + LDA B 3,X A & B now contain the constant + JMP PUSHBA +* +* ======>> 50 << + FCB $88 + FCC 7,VARIABLE + FCB $C5 + FDB CON-11 +VAR FDB DOCOL,CON,PSCODE +DOVAR LDA A W + LDA B W+1 + ADD B #2 + ADC A #0 A,B now contain the address of the variable + JMP PUSHBA +* +* ======>> 51 << + FCB $84 + FCC 3,USER + FCB $D2 + FDB VAR-11 +USER FDB DOCOL,CON,PSCODE +DOUSER LDX W get offset into user's table + LDA A 2,X + LDA B 3,X + ADD B UP+1 add to users base address + ADC A UP + JMP PUSHBA push address of user's variable +* +* ######>> screen 35 << +* ======>> 52 << + FCB $81 + FCB $B0 0 + FDB USER-7 +ZERO FDB DOCON + FDB 0000 +* +* ======>> 53 << + FCB $81 + FCB $B1 1 + FDB ZERO-4 +ONE FDB DOCON + FDB 1 +* +* ======>> 54 << + FCB $81 + FCB $B2 2 + FDB ONE-4 +TWO FDB DOCON + FDB 2 +* +* ======>> 55 << + FCB $81 + FCB $B3 3 + FDB TWO-4 +THREE FDB DOCON + FDB 3 +* +* ======>> 56 << + FCB $82 + FCC 1,BL + FCB $CC + FDB THREE-4 +BL FDB DOCON ascii blank + FDB $20 +* +* ======>> 57 << + FCB $85 + FCC 4,FIRST + FCB $D4 + FDB BL-5 +FIRST FDB DOCON + FDB MEMEND-528 (132 * NBLK) +* +* ======>> 58 << + FCB $85 + FCC 4,LIMIT ( the end of memory +1 ) + FCB $D4 + FDB FIRST-8 +LIMIT FDB DOCON + FDB MEMEND +* +* ======>> 59 << + FCB $85 + FCC 4,B/BUF (bytes/buffer) + FCB $C6 + FDB LIMIT-8 +BBUF FDB DOCON + FDB 128 +* +* ======>> 60 << + FCB $85 + FCC 4,B/SCR (blocks/screen) + FCB $D2 + FDB BBUF-8 +BSCR FDB DOCON + FDB 8 +* blocks/screen = 1024 / "B/BUF" = 8 +* +* ======>> 61 << + FCB $87 + FCC 6,+ORIGIN + FCB $CE + FDB BSCR-8 +PORIG FDB DOCOL,LIT,ORIG,PLUS + FDB SEMIS +* +* ######>> screen 36 << +* ======>> 62 << + FCB $82 + FCC 1,S0 + FCB $B0 + FDB PORIG-10 +SZERO FDB DOUSER + FDB XSPZER-UORIG +* +* ======>> 63 << + FCB $82 + FCC 1,R0 + FCB $B0 + FDB SZERO-5 +RZERO FDB DOUSER + FDB XRZERO-UORIG +* +* ======>> 64 << + FCB $83 + FCC 2,TIB + FCB $C2 + FDB RZERO-5 +TIB FDB DOUSER + FDB XTIB-UORIG +* +* ======>> 65 << + FCB $85 + FCC 4,WIDTH + FCB $C8 + FDB TIB-6 +WIDTH FDB DOUSER + FDB XWIDTH-UORIG +* +* ======>> 66 << + FCB $87 + FCC 6,WARNING + FCB $C7 + FDB WIDTH-8 +WARN FDB DOUSER + FDB XWARN-UORIG +* +* ======>> 67 << + FCB $85 + FCC 4,FENCE + FCB $C5 + FDB WARN-10 +FENCE FDB DOUSER + FDB XFENCE-UORIG +* +* ======>> 68 << + FCB $82 + FCC 1,DP points to first free byte at end of dictionary + FCB $D0 + FDB FENCE-8 +DP FDB DOUSER + FDB XDP-UORIG +* +* ======>> 68.5 << + FCB $88 + FCC 7,VOC-LINK + FCB $CB + FDB DP-5 +VOCLIN FDB DOUSER + FDB XVOCL-UORIG +* +* ======>> 69 << + FCB $83 + FCC 2,BLK + FCB $CB + FDB VOCLIN-11 +BLK FDB DOUSER + FDB XBLK-UORIG +* +* ======>> 70 << + FCB $82 + FCC 1,IN scan pointer for input line buffer + FCB $CE + FDB BLK-6 +IN FDB DOUSER + FDB XIN-UORIG +* +* ======>> 71 << + FCB $83 + FCC 2,OUT + FCB $D4 + FDB IN-5 +OUT FDB DOUSER + FDB XOUT-UORIG +* +* ======>> 72 << + FCB $83 + FCC 2,SCR + FCB $D2 + FDB OUT-6 +SCR FDB DOUSER + FDB XSCR-UORIG +* ######>> screen 37 << +* +* ======>> 73 << + FCB $86 + FCC 5,OFFSET + FCB $D4 + FDB SCR-6 +OFSET FDB DOUSER + FDB XOFSET-UORIG +* +* ======>> 74 << + FCB $87 + FCC 6,CONTEXT points to pointer to vocab to search first + FCB $D4 + FDB OFSET-9 +CONTXT FDB DOUSER + FDB XCONT-UORIG +* +* ======>> 75 << + FCB $87 + FCC 6,CURRENT points to ptr. to vocab being extended + FCB $D4 + FDB CONTXT-10 +CURENT FDB DOUSER + FDB XCURR-UORIG +* +* ======>> 76 << + FCB $85 + FCC 4,STATE 1 if compiling, 0 if not + FCB $C5 + FDB CURENT-10 +STATE FDB DOUSER + FDB XSTATE-UORIG +* +* ======>> 77 << + FCB $84 + FCC 3,BASE number base for all input & output + FCB $C5 + FDB STATE-8 +BASE FDB DOUSER + FDB XBASE-UORIG +* +* ======>> 78 << + FCB $83 + FCC 2,DPL + FCB $CC + FDB BASE-7 +DPL FDB DOUSER + FDB XDPL-UORIG +* +* ======>> 79 << + FCB $83 + FCC 2,FLD + FCB $C4 + FDB DPL-6 +FLD FDB DOUSER + FDB XFLD-UORIG +* +* ======>> 80 << + FCB $83 + FCC 2,CSP + FCB $D0 + FDB FLD-6 +CSP FDB DOUSER + FDB XCSP-UORIG +* +* ======>> 81 << + FCB $82 + FCC 1,R# + FCB $A3 + FDB CSP-6 +RNUM FDB DOUSER + FDB XRNUM-UORIG +* +* ======>> 82 << + FCB $83 + FCC 2,HLD + FCB $C4 + FDB RNUM-5 +HLD FDB DOCON + FDB XHLD +* +* ======>> 82.5 <<== SPECIAL + FCB $87 + FCC 6,COLUMNS line width of terminal + FCB $D3 + FDB HLD-6 +COLUMS FDB DOUSER + FDB XCOLUM-UORIG +* +* ######>> screen 38 << +* ======>> 83 << + FCB $82 + FCC 1,1+ + FCB $AB + FDB COLUMS-10 +ONEP FDB DOCOL,ONE,PLUS + FDB SEMIS +* +* ======>> 84 << + FCB $82 + FCC 1,2+ + FCB $AB + FDB ONEP-5 +TWOP FDB DOCOL,TWO,PLUS + FDB SEMIS +* +* ======>> 85 << + FCB $84 + FCC 3,HERE + FCB $C5 + FDB TWOP-5 +HERE FDB DOCOL,DP,AT + FDB SEMIS +* +* ======>> 86 << + FCB $85 + FCC 4,ALLOT + FCB $D4 + FDB HERE-7 +ALLOT FDB DOCOL,DP,PSTORE + FDB SEMIS +* +* ======>> 87 << + FCB $81 ; , (COMMA) + FCB $AC + FDB ALLOT-8 +COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT + FDB SEMIS +* +* ======>> 88 << + FCB $82 + FCC 1,C, + FCB $AC + FDB COMMA-4 +CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT + FDB SEMIS +* +* ======>> 89 << + FCB $81 ; - + FCB $AD + FDB CCOMM-5 +SUB FDB DOCOL,MINUS,PLUS + FDB SEMIS +* +* ======>> 90 << + FCB $81 = + FCB $BD + FDB SUB-4 +EQUAL FDB DOCOL,SUB,ZEQU + FDB SEMIS +* +* ======>> 91 << + FCB $81 < + FCB $BC + FDB EQUAL-4 +LESS FDB *+2 + PUL A + PUL B + TSX + CMP A 0,X + INS + BGT LESST + BNE LESSF + CMP B 1,X + BHI LESST +LESSF CLR B + BRA LESSX +LESST LDA B #1 +LESSX CLR A + INS + JMP PUSHBA +* +* ======>> 92 << + FCB $81 > + FCB $BE + FDB LESS-4 +GREAT FDB DOCOL,SWAP,LESS + FDB SEMIS +* +* ======>> 93 << + FCB $83 + FCC 2,ROT + FCB $D4 + FDB GREAT-4 +ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP + FDB SEMIS +* +* ======>> 94 << + FCB $85 + FCC 4,SPACE + FCB $C5 + FDB ROT-6 +SPACE FDB DOCOL,BL,EMIT + FDB SEMIS +* +* ======>> 95 << + FCB $83 + FCC 2,MIN + FCB $CE + FDB SPACE-8 +MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN + FDB MIN2-* + FDB SWAP +MIN2 FDB DROP + FDB SEMIS +* +* ======>> 96 << + FCB $83 + FCC 2,MAX + FCB $D8 + FDB MIN-6 +MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN + FDB MAX2-* + FDB SWAP +MAX2 FDB DROP + FDB SEMIS +* +* ======>> 97 << + FCB $84 + FCC 3,-DUP + FCB $D0 + FDB MAX-6 +DDUP FDB DOCOL,DUP,ZBRAN + FDB DDUP2-* + FDB DUP +DDUP2 FDB SEMIS +* +* ######>> screen 39 << +* ======>> 98 << + FCB $88 + FCC 7,TRAVERSE + FCB $C5 + FDB DDUP-7 +TRAV FDB DOCOL,SWAP +TRAV2 FDB OVER,PLUS,CLITER + FCB $7F + FDB OVER,CAT,LESS,ZBRAN + FDB TRAV2-* + FDB SWAP,DROP + FDB SEMIS +* +* ======>> 99 << + FCB $86 + FCC 5,LATEST + FCB $D4 + FDB TRAV-11 +LATEST FDB DOCOL,CURENT,AT,AT + FDB SEMIS +* +* ======>> 100 << + FCB $83 + FCC 2,LFA + FCB $C1 + FDB LATEST-9 +LFA FDB DOCOL,CLITER + FCB 4 + FDB SUB + FDB SEMIS +* +* ======>> 101 << + FCB $83 + FCC 2,CFA + FCB $C1 + FDB LFA-6 +CFA FDB DOCOL,TWO,SUB + FDB SEMIS +* +* ======>> 102 << + FCB $83 + FCC 2,NFA + FCB $C1 + FDB CFA-6 +NFA FDB DOCOL,CLITER + FCB 5 + FDB SUB,ONE,MINUS,TRAV + FDB SEMIS +* +* ======>> 103 << + FCB $83 + FCC 2,PFA + FCB $C1 + FDB NFA-6 +PFA FDB DOCOL,ONE,TRAV,CLITER + FCB 5 + FDB PLUS + FDB SEMIS +* +* ######>> screen 40 << +* ======>> 104 << + FCB $84 + FCC 3,!CSP + FCB $D0 + FDB PFA-6 +SCSP FDB DOCOL,SPAT,CSP,STORE + FDB SEMIS +* +* ======>> 105 << + FCB $86 + FCC 5,?ERROR + FCB $D2 + FDB SCSP-7 +QERR FDB DOCOL,SWAP,ZBRAN + FDB QERR2-* + FDB ERROR,BRAN + FDB QERR3-* +QERR2 FDB DROP +QERR3 FDB SEMIS +* +* ======>> 106 << + FCB $85 + FCC 4,?COMP + FCB $D0 + FDB QERR-9 +QCOMP FDB DOCOL,STATE,AT,ZEQU,CLITER + FCB $11 + FDB QERR + FDB SEMIS +* +* ======>> 107 << + FCB $85 + FCC 4,?EXEC + FCB $C3 + FDB QCOMP-8 +QEXEC FDB DOCOL,STATE,AT,CLITER + FCB $12 + FDB QERR + FDB SEMIS +* +* ======>> 108 << + FCB $86 + FCC 5,?PAIRS + FCB $D3 + FDB QEXEC-8 +QPAIRS FDB DOCOL,SUB,CLITER + FCB $13 + FDB QERR + FDB SEMIS +* +* ======>> 109 << + FCB $84 + FCC 3,?CSP + FCB $D0 + FDB QPAIRS-9 +QCSP FDB DOCOL,SPAT,CSP,AT,SUB,CLITER + FCB $14 + FDB QERR + FDB SEMIS +* +* ======>> 110 << + FCB $88 + FCC 7,?LOADING + FCB $C7 + FDB QCSP-7 +QLOAD FDB DOCOL,BLK,AT,ZEQU,CLITER + FCB $16 + FDB QERR + FDB SEMIS +* +* ######>> screen 41 << +* ======>> 111 << + FCB $87 + FCC 6,COMPILE + FCB $C5 + FDB QLOAD-11 +COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA + FDB SEMIS +* +* ======>> 112 << + FCB $C1 [ immediate + FCB $DB + FDB COMPIL-10 +LBRAK FDB DOCOL,ZERO,STATE,STORE + FDB SEMIS +* +* ======>> 113 << + FCB $81 ] + FCB $DD + FDB LBRAK-4 +RBRAK FDB DOCOL,CLITER + FCB $C0 + FDB STATE,STORE + FDB SEMIS +* +* ======>> 114 << + FCB $86 + FCC 5,SMUDGE + FCB $C5 + FDB RBRAK-4 +SMUDGE FDB DOCOL,LATEST,CLITER + FCB $20 + FDB TOGGLE + FDB SEMIS +* +* ======>> 115 << + FCB $83 + FCC 2,HEX + FCB $D8 + FDB SMUDGE-9 +HEX FDB DOCOL + FDB CLITER + FCB 16 + FDB BASE,STORE + FDB SEMIS +* +* ======>> 116 << + FCB $87 + FCC 6,DECIMAL + FCB $CC + FDB HEX-6 +DEC FDB DOCOL + FDB CLITER + FCB 10 note: hex "A" + FDB BASE,STORE + FDB SEMIS +* +* ######>> screen 42 << +* ======>> 117 << + FCB $87 + FCC 6,(;CODE) + FCB $A9 + FDB DEC-10 +PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE + FDB SEMIS +* +* ======>> 118 << + FCB $C5 immediate + FCC 4,;CODE + FCB $C5 + FDB PSCODE-10 +SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK + FDB SEMIS +* note: "QSTACK" will be replaced by "ASSEMBLER" later +* +* ######>> screen 43 << +* ======>> 119 << + FCB $87 + FCC 6,> 120 << + FCB $85 + FCC 4,DOES> + FCB $BE + FDB BUILDS-10 +DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE + FDB PSCODE +DODOES LDA A IP + LDA B IP+1 + LDX RP make room on return stack + DEX + DEX + STX RP + STA A 2,X push return address + STA B 3,X + LDX W get addr of pointer to run-time code + INX + INX + STX N stash it in scratch area + LDX 0,X get new IP + STX IP + CLR A get address of parameter + LDA B #2 + ADD B N+1 + ADC A N + PSH B and push it on data stack + PSH A + JMP NEXT2 +* +* ######>> screen 44 << +* ======>> 121 << + FCB $85 + FCC 4,COUNT + FCB $D4 + FDB DOES-8 +COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT + FDB SEMIS +* +* ======>> 122 << + FCB $84 + FCC 3,TYPE + FCB $C5 + FDB COUNT-8 +TYPE FDB DOCOL,DDUP,ZBRAN + FDB TYPE3-* + FDB OVER,PLUS,SWAP,XDO +TYPE2 FDB I,CAT,EMIT,XLOOP + FDB TYPE2-* + FDB BRAN + FDB TYPE4-* +TYPE3 FDB DROP +TYPE4 FDB SEMIS +* +* ======>> 123 << + FCB $89 + FCC 8,-TRAILING + FCB $C7 + FDB TYPE-7 +DTRAIL FDB DOCOL,DUP,ZERO,XDO +DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL + FDB SUB,ZBRAN + FDB DTRAL3-* + FDB LEAVE,BRAN + FDB DTRAL4-* +DTRAL3 FDB ONE,SUB +DTRAL4 FDB XLOOP + FDB DTRAL2-* + FDB SEMIS +* +* ======>> 124 << + FCB $84 + FCC 3,(.") + FCB $A9 + FDB DTRAIL-12 +PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP + FDB FROMR,PLUS,TOR,TYPE + FDB SEMIS +* +* ======>> 125 << + FCB $C2 immediate + FCC 1,." + FCB $A2 + FDB PDOTQ-7 +DOTQ FDB DOCOL + FDB CLITER + FCB $22 ascii quote + FDB STATE,AT,ZBRAN + FDB DOTQ1-* + FDB COMPIL,PDOTQ,WORD + FDB HERE,CAT,ONEP,ALLOT,BRAN + FDB DOTQ2-* +DOTQ1 FDB WORD,HERE,COUNT,TYPE +DOTQ2 FDB SEMIS +* +* ######>> screen 45 << +* ======>> 126 <<== MACHINE DEPENDENT + FCB $86 + FCC 5,?STACK + FCB $CB + FDB DOTQ-5 +QSTACK FDB DOCOL,CLITER + FCB $12 + FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE + FDB QERR +* prints 'empty stack' +* +QSTAC2 FDB SPAT +* Here, we compare with a value at least 128 +* higher than dict. ptr. (DP) + FDB HERE,CLITER + FCB $80 + FDB PLUS,LESS,ZBRAN + FDB QSTAC3-* + FDB TWO + FDB QERR +* prints 'full stack' +* +QSTAC3 FDB SEMIS +* +* ======>> 127 << this word's function +* is done by ?STACK in this version +* FCB $85 +* FCC 4,?FREE +* FCB $C5 +* FDB QSTACK-9 +*QFREE FDB DOCOL,SPAT,HERE,CLITER +* FCB $80 +* FDB PLUS,LESS,TWO,QERR,SEMIS +* +* ######>> screen 46 << +* ======>> 128 << + FCB $86 + FCC 5,EXPECT + FCB $D4 + FDB QSTACK-9 +EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO +EXPEC2 FDB KEY,DUP,CLITER + FCB $0E + FDB PORIG,AT,EQUAL,ZBRAN + FDB EXPEC3-* + FDB DROP,CLITER + FCB 8 ( backspace character to emit ) + FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS + FDB TOR,SUB,BRAN + FDB EXPEC6-* +EXPEC3 FDB DUP,CLITER + FCB $D ( carriage return ) + FDB EQUAL,ZBRAN + FDB EXPEC4-* + FDB LEAVE,DROP,BL,ZERO,BRAN + FDB EXPEC5-* +EXPEC4 FDB DUP +EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE +EXPEC6 FDB EMIT,XLOOP + FDB EXPEC2-* + FDB DROP + FDB SEMIS +* +* ======>> 129 << + FCB $85 + FCC 4,QUERY + FCB $D9 + FDB EXPECT-9 +QUERY FDB DOCOL,TIB,AT,COLUMS + FDB AT,EXPECT,ZERO,IN,STORE +*DBG +* FDB MNOP +*DBG + FDB SEMIS +* +* ======>> 130 << + FCB $C1 immediate < carriage return > + FCB $80 + FDB QUERY-8 +NULL FDB DOCOL,BLK,AT,ZBRAN + FDB NULL2-* + FDB ONE,BLK,PSTORE + FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD + FDB ZEQU +* check for end of screen + FDB ZBRAN + FDB NULL1-* + FDB QEXEC,FROMR,DROP +NULL1 FDB BRAN + FDB NULL3-* +NULL2 FDB FROMR,DROP +NULL3 FDB SEMIS +* +* ######>> screen 47 << +* ======>> 133 << + FCB $84 + FCC 3,FILL + FCB $CC + FDB NULL-4 +FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP + FDB FROMR,ONE,SUB,CMOVE + FDB SEMIS +* +* ======>> 134 << + FCB $85 + FCC 4,ERASE + FCB $C5 + FDB FILL-7 +ERASE FDB DOCOL,ZERO,FILL + FDB SEMIS +* +* ======>> 135 << + FCB $86 + FCC 5,BLANKS + FCB $D3 + FDB ERASE-8 +BLANKS FDB DOCOL,BL,FILL + FDB SEMIS +* +* ======>> 136 << + FCB $84 + FCC 3,HOLD + FCB $C4 + FDB BLANKS-9 +HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE + FDB SEMIS +* +* ======>> 137 << + FCB $83 + FCC 2,PAD + FCB $C4 + FDB HOLD-7 +PAD FDB DOCOL,HERE,CLITER + FCB $44 + FDB PLUS + FDB SEMIS +* +* ######>> screen 48 << +* ======>> 138 << + FCB $84 + FCC 3,WORD + FCB $C4 + FDB PAD-6 +WORD FDB DOCOL,BLK,AT,ZBRAN + FDB WORD2-* + FDB BLK,AT,BLOCK,BRAN + FDB WORD3-* +WORD2 FDB TIB,AT +WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,CLITER + FCB 34 + FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE + FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE + FDB SEMIS +* +* ######>> screen 49 << +* ======>> 139 << + FCB $88 + FCC 7,(NUMBER) + FCB $A9 + FDB WORD-7 +PNUMB FDB DOCOL +PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN + FDB PNUMB4-* + FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE + FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN + FDB PNUMB3-* + FDB ONE,DPL,PSTORE +PNUMB3 FDB FROMR,BRAN + FDB PNUMB2-* +PNUMB4 FDB FROMR + FDB SEMIS +* +* ======>> 140 << + FCB $86 + FCC 5,NUMBER + FCB $D2 + FDB PNUMB-11 +NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,CLITER + FCC "-" minus sign + FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF +NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB + FDB ZBRAN + FDB NUMB2-* + FDB DUP,CAT,CLITER + FCC "." + FDB SUB,ZERO,QERR,ZERO,BRAN + FDB NUMB1-* +NUMB2 FDB DROP,FROMR,ZBRAN + FDB NUMB3-* + FDB DMINUS +NUMB3 FDB SEMIS +* +* ======>> 141 << + FCB $85 + FCC 4,-FIND + FCB $C4 + FDB NUMB-9 +DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT +*DBG + FDB MNOP +*DBG + FDB PFIND +*DBG + FDB MNOP +*DBG + FDB DUP,ZEQU,ZBRAN + FDB DFIND2-* + FDB DROP,HERE,LATEST,PFIND +DFIND2 FDB SEMIS +* +* ######>> screen 50 << +* ======>> 142 << + FCB $87 + FCC 6,(ABORT) + FCB $A9 + FDB DFIND-8 +PABORT FDB DOCOL,ABORT + FDB SEMIS +* +* ======>> 143 << + FCB $85 + FCC 4,ERROR + FCB $D2 + FDB PABORT-10 +ERROR FDB DOCOL,WARN,AT,ZLESS + FDB ZBRAN +* note: WARNING is -1 to abort, 0 to print error # +* and 1 to print error message from disc + FDB ERROR2-* + FDB PABORT +ERROR2 FDB HERE,COUNT,TYPE,PDOTQ + FCB 4,7 ( bell ) + FCC " ? " + FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT + FDB SEMIS +* +* ======>> 144 << + FCB $83 + FCC 2,ID. + FCB $AE + FDB ERROR-8 +IDDOT FDB DOCOL,PAD,CLITER + FCB 32 + FDB CLITER + FCB $5F ( underline ) + FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD + FDB SWAP,CMOVE,PAD,COUNT,CLITER + FCB 31 + FDB AND,TYPE,SPACE + FDB SEMIS +* +* ######>> screen 51 << +* ======>> 145 << + FCB $86 + FCC 5,CREATE + FCB $C5 + FDB IDDOT-6 +CREATE FDB DOCOL,DFIND,ZBRAN + FDB CREAT2-* + FDB DROP,PDOTQ + FCB 8 + FCB 7 ( bel ) + FCC "redef: " + FDB NFA,IDDOT,CLITER + FCB 4 + FDB MESS,SPACE +CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN + FDB ONEP,ALLOT,DUP,CLITER + FCB $A0 + FDB TOGGLE,HERE,ONE,SUB,CLITER + FCB $80 + FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE + FDB HERE,TWOP,COMMA + FDB SEMIS +* +* ######>> screen 52 << +* ======>> 146 << + FCB $C9 immediate + FCC 8,[COMPILE] + FCB $DD + FDB CREATE-9 +BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA + FDB SEMIS +* +* ======>> 147 << + FCB $C7 immediate + FCC 6,LITERAL + FCB $CC + FDB BCOMP-12 +LITER FDB DOCOL,STATE,AT,ZBRAN + FDB LITER2-* + FDB COMPIL,LIT,COMMA +LITER2 FDB SEMIS +* +* ======>> 148 << + FCB $C8 immediate + FCC 7,DLITERAL + FCB $CC + FDB LITER-10 +DLITER FDB DOCOL,STATE,AT,ZBRAN + FDB DLITE2-* + FDB SWAP,LITER,LITER +DLITE2 FDB SEMIS +* +* ######>> screen 53 << +* ======>> 149 << + FCB $89 + FCC 8,INTERPRET + FCB $D4 + FDB DLITER-11 +INTERP FDB DOCOL +INTER2 FDB DFIND +*DBG +* FDB MNOP +* FDB OVER,OVER,HEX,DOT,DOT,DEC +*DBG + FDB ZBRAN + FDB INTER5-* + FDB STATE,AT,LESS + FDB ZBRAN + FDB INTER3-* + FDB CFA,COMMA,BRAN + FDB INTER4-* +INTER3 FDB CFA,EXEC +INTER4 FDB BRAN + FDB INTER7-* +INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN + FDB INTER6-* + FDB DLITER,BRAN + FDB INTER7-* +INTER6 FDB DROP,LITER +INTER7 FDB QSTACK,BRAN + FDB INTER2-* +* FDB SEMIS never executed + +* +* ######>> screen 54 << +* ======>> 150 << + FCB $89 + FCC 8,IMMEDIATE + FCB $C5 + FDB INTERP-12 +IMMED FDB DOCOL,LATEST,CLITER + FCB $40 + FDB TOGGLE + FDB SEMIS +* +* ======>> 151 << + FCB $8A + FCC 9,VOCABULARY + FCB $D9 + FDB IMMED-12 +VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA + FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES +DOVOC FDB TWOP,CONTXT,STORE + FDB SEMIS +* +* ======>> 152 << +* +* Note: FORTH does not go here in the rom-able dictionary, +* since FORTH is a type of variable. +* +* +* ======>> 153 << + FCB $8B + FCC 10,DEFINITIONS + FCB $D3 + FDB VOCAB-13 +DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE + FDB SEMIS +* +* ======>> 154 << + FCB $C1 immediate ( + FCB $A8 + FDB DEFIN-14 +PAREN FDB DOCOL,CLITER + FCC ")" + FDB WORD + FDB SEMIS +* +* ######>> screen 55 << +* ======>> 155 << + FCB $84 + FCC 3,QUIT + FCB $D4 + FDB PAREN-4 +QUIT FDB DOCOL,ZERO,BLK,STORE + FDB LBRAK +* +* Here is the outer interpretter +* which gets a line of input, does it, prints " OK" +* then repeats : +QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU + FDB ZBRAN + FDB QUIT3-* + FDB PDOTQ + FCB 3 + FCC 3, OK +QUIT3 FDB BRAN + FDB QUIT2-* +* FDB SEMIS ( never executed ) +* +* ======>> 156 << + FCB $85 + FCC 4,ABORT + FCB $D4 + FDB QUIT-7 +ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ + FCB 8 + FCC "Forth-68" + FDB FORTH,DEFIN +*DBG +* FDB TRCON +* FDB LIT +* FDB ABORT-8 +* FDB IDDOT +* FDB LIT +* FDB NULL-4 +* FDB IDDOT +* FDB LIT +* FDB MNOP-7 +* FDB IDDOT +* FDB LIT +* FDB TRCON-10 +* FDB IDDOT +* FDB LIT +* FDB TRCOFF-11 +* FDB IDDOT +*DBG + FDB QUIT +* FDB SEMIS never executed + PAGE +* +* ######>> screen 56 << +* bootstrap code... moves rom contents to ram : +* ======>> 157 << + FCB $84 + FCC 3,COLD + FCB $C4 + FDB ABORT-8 +COLD FDB *+2 +CENT LDS #REND-1 top of destination + LDX #ERAM top of stuff to move +COLD2 DEX + LDA A 0,X + PSH A move TASK & FORTH to ram + CPX #RAM + BNE COLD2 +* + LDS #XFENCE-1 put stack at a safe place for now + LDX COLINT + STX XCOLUM + LDX DELINT + STX XDELAY + LDX VOCINT + STX XVOCL + LDX DPINIT + STX XDP + LDX FENCIN + STX XFENCE + + +WENT LDS #XFENCE-1 top of destination + LDX #FENCIN top of stuff to move +WARM2 DEX + LDA A 0,X + PSH A + CPX #SINIT + BNE WARM2 +* + LDS SINIT + LDX UPINIT + STX UP init user ram pointer + LDX #ABORT + STX IP + NOP Here is a place to jump to special user + NOP initializations such as I/0 interrups + NOP +* +* For systems with TRACE: + LDX #00 + STX TRLIM clear trace mode + LDX #0 + STX BRKPT clear breakpoint address + JMP RPSTOR+2 start the virtual machine running ! +* +* Here is the stuff that gets copied to ram : +* at address $140: +* +* Thus, MAGIC numbers that initialize USE and PREV, magically! (JMR) +* RAM FDB $3000,$3000,0,0 +RAM FDB $4000+132,$4000+132,0,0 + +* ======>> (152) << + FCB $C5 immediate + FCC 4,FORTH + FCB $C8 + FDB MNOP-7 +RFORTH FDB DODOES,DOVOC,$81A0,TASK-7 + FDB 0 + FCC "(C) Forth Interest Group, 1979" + FCB $84 + FCC 3,TASK + FCB $CB + FDB FORTH-8 +RTASK FDB DOCOL,SEMIS +ERAM FCC "David Lion" + PAGE +* +* ######>> screen 57 << +* ======>> 158 << + FCB $84 + FCC 3,S->D + FCB $C4 + FDB COLD-7 +STOD FDB DOCOL,DUP,ZLESS,MINUS + FDB SEMIS + + +* +* ======>> 159 << + FCB $81 ; * + FCB $AA + FDB STOD-7 +STAR FDB *+2 + JSR USTARS + INS + INS + JMP NEXT +* +* ======>> 160 << + FCB $84 + FCC 3,/MOD + FCB $C4 + FDB STAR-4 +SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH + FDB SEMIS +* +* ======>> 161 << + FCB $81 ; / + FCB $AF + FDB SLMOD-7 +SLASH FDB DOCOL,SLMOD,SWAP,DROP + FDB SEMIS +* +* ======>> 162 << + FCB $83 + FCC 2,MOD + FCB $C4 + FDB SLASH-4 +MOD FDB DOCOL,SLMOD,DROP + FDB SEMIS +* +* ======>> 163 << + FCB $85 + FCC 4,*/MOD + FCB $C4 + FDB MOD-6 +SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH + FDB SEMIS +* +* ======>> 164 << + FCB $82 + FCC 1,*/ + FCB $AF + FDB SSMOD-8 +SSLASH FDB DOCOL,SSMOD,SWAP,DROP + FDB SEMIS +* +* ======>> 165 << + FCB $85 + FCC 4,M/MOD + FCB $C4 + FDB SSLASH-5 +MSMOD FDB DOCOL,TOR,ZERO,R,USLASH + FDB FROMR,SWAP,TOR,USLASH,FROMR + FDB SEMIS +* +* ======>> 166 << + FCB $83 + FCC 2,ABS + FCB $D3 + FDB MSMOD-8 +ABS FDB DOCOL,DUP,ZLESS,ZBRAN + FDB ABS2-* + FDB MINUS +ABS2 FDB SEMIS +* +* ======>> 167 << + FCB $84 + FCC 3,DABS + FCB $D3 + FDB ABS-6 +DABS FDB DOCOL,DUP,ZLESS,ZBRAN + FDB DABS2-* + FDB DMINUS +DABS2 FDB SEMIS +* +* ######>> screen 58 << +* Disc primatives : +* ======>> 168 << + FCB $83 + FCC 2,USE + FCB $C5 + FDB DABS-7 +USE FDB DOCON + FDB XUSE +* ======>> 169 << + FCB $84 + FCC 3,PREV + FCB $D6 + FDB USE-6 +PREV FDB DOCON + FDB XPREV +* ======>> 170 << + FCB $84 + FCC 3,+BUF + FCB $C6 + FDB PREV-7 +PBUF FDB DOCOL,CLITER + FCB $84 + FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN + FDB PBUF2-* + FDB DROP,FIRST +PBUF2 FDB DUP,PREV,AT,SUB + FDB SEMIS +* +* ======>> 171 << + FCB $86 + FCC 5,UPDATE + FCB $C5 + FDB PBUF-7 +UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE + FDB SEMIS +* +* ======>> 172 << + FCB $8D + FCC 12,EMPTY-BUFFERS + FCB $D3 + FDB UPDATE-9 +MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE + FDB SEMIS +* +* ======>> 173 << + FCB $83 + FCC 2,DR0 + FCB $B0 + FDB MTBUF-16 +DRZERO FDB DOCOL,ZERO,OFSET,STORE + FDB SEMIS +* +* ======>> 174 <<== system dependant word + FCB $83 + FCC 2,DR1 + FCB $B1 + FDB DRZERO-6 +*DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE +DRONE FDB DOCOL,LIT,RAMDSZ,OFSET,STORE + FDB SEMIS +* +* ######>> screen 59 << +* ======>> 175 << + FCB $86 + FCC 5,BUFFER + FCB $D2 + FDB DRONE-6 +BUFFER FDB DOCOL,USE,AT,DUP,TOR +BUFFR2 FDB PBUF,ZBRAN + FDB BUFFR2-* + FDB USE,STORE,R,AT,ZLESS + FDB ZBRAN + FDB BUFFR3-* + FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW +BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP + FDB SEMIS +* +* ######>> screen 60 << +* ======>> 176 << + FCB $85 + FCC 4,BLOCK + FCB $CB + FDB BUFFER-9 +BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR + FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN + FDB BLOCK5-* +BLOCK3 FDB PBUF,ZEQU,ZBRAN + FDB BLOCK4-* + FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB +BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN + FDB BLOCK3-* + FDB DUP,PREV,STORE +BLOCK5 FDB FROMR,DROP,TWOP + FDB SEMIS +* +* ######>> screen 61 << +* ======>> 177 << + FCB $86 + FCC 5,(LINE) + FCB $A9 + FDB BLOCK-8 +PLINE FDB DOCOL,TOR,CLITER + FCB $40 + FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,CLITER + FCB $40 + FDB SEMIS +* +* ======>> 178 << + FCB $85 + FCC 4,.LINE + FCB $C5 + FDB PLINE-9 +DLINE FDB DOCOL,PLINE,DTRAIL,TYPE + FDB SEMIS +* +* ======>> 179 << + FCB $87 + FCC 6,MESSAGE + FCB $C5 + FDB DLINE-8 +MESS FDB DOCOL,WARN,AT,ZBRAN + FDB MESS3-* + FDB DDUP,ZBRAN + FDB MESS3-* + FDB CLITER + FCB 4 + FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN + FDB MESS4-* +MESS3 FDB PDOTQ + FCB 6 + FCC 6,err # ; Make sure there's a space there at the end. + FDB DOT +MESS4 FDB SEMIS +* +* ======>> 180 << + FCB $84 + FCC 3,LOAD input:scr # + FCB $C4 + FDB MESS-10 +LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE + FDB BSCR,STAR,BLK,STORE + FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE + FDB SEMIS +* +* ======>> 181 << + FCB $C3 + FCC 2,--> + FCB $BE + FDB LOAD-7 +ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR + FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE + FDB SEMIS + PAGE +* +* +* ######>> screen 63 << +* The next 4 subroutines are machine dependent, and are +* called by words 13 through 16 in the dictionary. +* +* ======>> 182 << code for EMIT +* PEMIT JMP $F018 ; EXBUG outch, rob the RTS. +PEMIT STA B N+1 save B + STX N+2 save X + LDA B ACIAC + BIT B #2 check ready bit + BEQ PEMIT+4 if not ready for more data + STA A N + AND A #$7F + STA A ACIAD + LDX UP + STA B IOSTAT-UORIG,X + LDA A N + LDA B N+1 recover B & X + LDX N+2 + RTS only A register may change +* PEMIT JMP $E1D1 for MIKBUG +* PEMIT FCB $3F,$11,$39 for PROTO +* PEMIT JMP $D286 for Smoke Signal DOS +* +* ======>> 183 << code for KEY +PKEY CLR $FF53 + INC $FF53 ; shut off echo + JMP $F015 ; EXBUG inch, rob the RTS. +* PKEY STA B N +* STX N+1 +* LDA B ACIAC +* ASR B +* BCC PKEY+4 no incoming data yet +* LDA A ACIAD +* AND A #$7F strip parity bit +* LDX UP +* STA B IOSTAT+1-UORIG,X +* LDA B N +* LDX N+1 +* RTS +* PKEY JMP $E1AC for MIKBUG +* PKEY FCB $3F,$14,$39 for PROTO +* PKEY JMP $D289 for Smoke Signal DOS +* +* ######>> screen 64 << +* ======>> 184 << code for ?TERMINAL +PQTER LDA A ACIAC Test for 'break' condition + AND A #$11 mask framing error bit and +* input buffer full + BEQ PQTER2 + LDA A ACIAD clear input buffer + LDA A #01 +PQTER2 RTS + + + PAGE +* +* ======>> 185 << code for CR +PCR JMP $F021 ; EXBUG pcrlf, rob the RTS. +* PCR LDA A #$D carriage return +* BSR PEMIT +* LDA A #$A line feed +* BSR PEMIT +* LDA A #$7F rubout +* LDX UP +* LDA B XDELAY+1-UORIG,X +* PCR2 DEC B +* BMI PQTER2 return if minus +* PSH B save counter +* BSR PEMIT print RUBOUTs to delay..... +* PUL B +* BRA PCR2 repeat + + + PAGE +* +* ######>> screen 66 << +* ======>> 187 << + FCB $85 + FCC 4,?DISC + FCB $C3 + FDB ARROW-6 +QDISC FDB *+2 + JMP NEXT +* +* ######>> screen 67 << +* ======>> 189 << + FCB $8B + FCC 10,BLOCK-WRITE + FCB $C5 + FDB QDISC-8 +BWRITE FDB *+2 + JMP NEXT +* +* ######>> screen 68 << +* ======>> 190 << + FCB $8A + FCC 9,BLOCK-READ + FCB $C4 + FDB BWRITE-14 +BREAD FDB *+2 + JMP NEXT +* +*The next 3 words are written to create a substitute for disc +* mass memory,located between $3210 & $3FFF in ram. +* ======>> 190.1 << + FCB $82 + FCC 1,LO + FCB $CF + FDB BREAD-13 +LO FDB DOCON + FDB MEMEND a system dependent equate at front +* +* ======>> 190.2 << + FCB $82 + FCC 1,HI + FCB $C9 + FDB LO-5 +HI FDB DOCON +* FDB MEMTOP ( $3FFF ($7FFF) in this version ) + FDB RAMDEN +* +* ######>> screen 69 << +* ======>> 191 << + FCB $83 + FCC 2,R/W + FCB $D7 + FDB HI-5 +RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN + FDB RW2-* + FDB PDOTQ + FCB 8 + FCC 8, Range ? + FDB QUIT +RW2 FDB FROMR,ZBRAN + FDB RW3-* + FDB SWAP +RW3 FDB BBUF,CMOVE + FDB SEMIS +* +* ######>> screen 72 << +* ======>> 192 << + FCB $C1 immediate + FCB $A7 ' ( tick ) + FDB RW-6 +TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER + FDB SEMIS +* +* ======>> 193 << + FCB $86 + FCC 5,FORGET + FCB $D4 + FDB TICK-4 +FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,CLITER + FCB $18 + FDB QERR,TICK,DUP,FENCE,AT,LESS,CLITER + FCB $15 + FDB QERR,DUP,ZERO,PORIG,GREAT,CLITER + FCB $15 + FDB QERR,DUP,NFA,DP,STORE,LFA,AT,CONTXT,AT,STORE + FDB SEMIS +* +* ######>> screen 73 << +* ======>> 194 << + FCB $84 + FCC 3,BACK + FCB $CB + FDB FORGET-9 +BACK FDB DOCOL,HERE,SUB,COMMA + FDB SEMIS +* +* ======>> 195 << + FCB $C5 + FCC 4,BEGIN + FCB $CE + FDB BACK-7 +BEGIN FDB DOCOL,QCOMP,HERE,ONE + FDB SEMIS +* +* ======>> 196 << + FCB $C5 + FCC 4,ENDIF + FCB $C6 + FDB BEGIN-8 +ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE + FDB OVER,SUB,SWAP,STORE + FDB SEMIS +* +* ======>> 197 << + FCB $C4 + FCC 3,THEN + FCB $CE + FDB ENDIF-8 +THEN FDB DOCOL,ENDIF + FDB SEMIS +* +* ======>> 198 << + FCB $C2 + FCC 1,DO + FCB $CF + FDB THEN-7 +DO FDB DOCOL,COMPIL,XDO,HERE,THREE + FDB SEMIS +* +* ======>> 199 << + FCB $C4 + FCC 3,LOOP + FCB $D0 + FDB DO-5 +LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK + FDB SEMIS +* +* ======>> 200 << + FCB $C5 + FCC 4,+LOOP + FCB $D0 + FDB LOOP-7 +PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK + FDB SEMIS +* +* ======>> 201 << + FCB $C5 + FCC 4,UNTIL ( same as END ) + FCB $CC + FDB PLOOP-8 +UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK + FDB SEMIS +* +* ######>> screen 74 << +* ======>> 202 << + FCB $C3 + FCC 2,END + FCB $C4 + FDB UNTIL-8 +END FDB DOCOL,UNTIL + FDB SEMIS +* +* ======>> 203 << + FCB $C5 + FCC 4,AGAIN + FCB $CE + FDB END-6 +AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK + FDB SEMIS +* +* ======>> 204 << + FCB $C6 + FCC 5,REPEAT + FCB $D4 + FDB AGAIN-8 +REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR + FDB TWO,SUB,ENDIF + FDB SEMIS +* +* ======>> 205 << + FCB $C2 + FCC 1,IF + FCB $C6 + FDB REPEAT-9 +IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO + FDB SEMIS +* +* ======>> 206 << + FCB $C4 + FCC 3,ELSE + FCB $C5 + FDB IF-5 +ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE + FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO + FDB SEMIS +* +* ======>> 207 << + FCB $C5 + FCC 4,WHILE + FCB $C5 + FDB ELSE-7 +WHILE FDB DOCOL,IF,TWOP + FDB SEMIS +* +* ######>> screen 75 << +* ======>> 208 << + FCB $86 + FCC 5,SPACES + FCB $D3 + FDB WHILE-8 +SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN + FDB SPACE3-* + FDB ZERO,XDO +SPACE2 FDB SPACE,XLOOP + FDB SPACE2-* +SPACE3 FDB SEMIS +* +* ======>> 209 << + FCB $82 + FCC 1,<# + FCB $A3 + FDB SPACES-9 +BDIGS FDB DOCOL,PAD,HLD,STORE + FDB SEMIS +* +* ======>> 210 << + FCB $82 + FCC 1,#> + FCB $BE + FDB BDIGS-5 +EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB + FDB SEMIS +* +* ======>> 211 << + FCB $84 + FCC 3,SIGN + FCB $CE + FDB EDIGS-5 +SIGN FDB DOCOL,ROT,ZLESS,ZBRAN + FDB SIGN2-* + FDB CLITER + FCC "-" + FDB HOLD +SIGN2 FDB SEMIS +* +* ======>> 212 << + FCB $81 # + FCB $A3 + FDB SIGN-7 +DIG FDB DOCOL,BASE,AT,MSMOD,ROT,CLITER + FCB 9 + FDB OVER,LESS,ZBRAN + FDB DIG2-* + FDB CLITER + FCB 7 + FDB PLUS +DIG2 FDB CLITER + FCC "0" ascii zero + FDB PLUS,HOLD + FDB SEMIS +* +* ======>> 213 << + FCB $82 + FCC 1,#S + FCB $D3 + FDB DIG-4 +DIGS FDB DOCOL +DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN + FDB DIGS2-* + FDB SEMIS +* +* ######>> screen 76 << +* ======>> 214 << + FCB $82 + FCC 1,.R + FCB $D2 + FDB DIGS-5 +DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR + FDB SEMIS +* +* ======>> 215 << + FCB $83 + FCC 2,D.R + FCB $D2 + FDB DOTR-5 +DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN + FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE + FDB SEMIS +* +* ======>> 216 << + FCB $82 + FCC 1,D. + FCB $AE + FDB DDOTR-6 +DDOT FDB DOCOL,ZERO,DDOTR,SPACE + FDB SEMIS +* +* ======>> 217 << + FCB $81 . + FCB $AE + FDB DDOT-5 +DOT FDB DOCOL,STOD,DDOT + FDB SEMIS +* +* ======>> 218 << + FCB $81 ? + FCB $BF + FDB DOT-4 +QUEST FDB DOCOL,AT,DOT + FDB SEMIS +* +* ######>> screen 77 << +* ======>> 219 << + FCB $84 + FCC 3,LIST + FCB $D4 + FDB QUEST-4 +LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ + FCB 6 + FCC "SCR # " + FDB DOT,CLITER + FCB $10 + FDB ZERO,XDO +LIST2 FDB CR,I,THREE + FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP + FDB LIST2-* + FDB CR + FDB SEMIS +* +* ======>> 220 << + FCB $85 + FCC 4,INDEX + FCB $D8 + FDB LIST-7 +INDEX FDB DOCOL,CR,ONEP,SWAP,XDO +INDEX2 FDB CR,I,THREE + FDB DOTR,SPACE,ZERO,I,DLINE + FDB QTERM,ZBRAN + FDB INDEX3-* + FDB LEAVE +INDEX3 FDB XLOOP + FDB INDEX2-* + FDB SEMIS +* +* ======>> 221 << + FCB $85 + FCC 4,TRIAD + FCB $C4 + FDB INDEX-8 +TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR + FDB THREE,OVER,PLUS,SWAP,XDO +TRIAD2 FDB CR,I + FDB LIST,QTERM,ZBRAN + FDB TRIAD3-* + FDB LEAVE +TRIAD3 FDB XLOOP + FDB TRIAD2-* + FDB CR,CLITER + FCB $0F + FDB MESS,CR + FDB SEMIS +* +* ######>> screen 78 << +* ======>> 222 << + FCB $85 + FCC 4,VLIST + FCB $D4 + FDB TRIAD-8 +VLIST FDB DOCOL,CLITER + FCB $80 + FDB OUT,STORE,CONTXT,AT,AT +VLIST1 FDB OUT,AT,COLUMS,AT,CLITER + FCB 32 + FDB SUB,GREAT,ZBRAN + FDB VLIST2-* + FDB CR,ZERO,OUT,STORE +VLIST2 FDB DUP +* FDB TRCON + FDB IDDOT,SPACE,SPACE,PFA,LFA,AT + FDB DUP,ZEQU,QTERM,OR +* FDB TRCOFF + FDB ZBRAN + FDB VLIST1-* + FDB DROP + FDB SEMIS +* +* ======>> XX << + FCB $84 + FCC 3,NOOP + FCB $D0 + FDB VLIST-8 +NOOP FDB NEXT a useful no-op +* +* ======>> XX1 << + FDB $87 + FCC 6,TRACEON + FCB $CE + FDB NOOP-7 +TRCON FDB *+2 + CLR TRACEM + INC TRACEM + JMP NEXT +* +* ======>> XX2 << + FDB $88 + FCC 7,TRACEOFF + FCB $C6 + FDB TRCON-10 +TRCOFF FDB *+2 + CLR TRACEM + JMP NEXT +* +* ======>> XXX << + FDB $84 + FCC 3,MNOP + FCB $D0 + FDB TRCOFF-11 +MNOP FDB *+2 + NOP a place to insert a machine-level breakpoint. + JMP NEXT +* +ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program +* + ORG MEMEND simulating disc on-line +* SCREEN 0 + FCC "0) Index to BIF HI-LEVEL disk " + FCC "1) " + FCC "2) Title page, Copr. notice " + FCC "3) MONITOR CALL TO DEBUG " + FCC "4) ERROR MESSAGES " + FCC "5) " + FCC "6) " + FCC "7) " + FCC "8) " + FCC "9) " + FCC "10) " + FCC "11) " + FCC "12) " + FCC "13) " + FCC "14) " + FCC "15) " +* SCREEN 1 + FCC "16) " + FCC "17) " + FCC "18) " + FCC "19) " + FCC "20) " + FCC "21) " + FCC "22) " + FCC "23) " + FCC "24) " + FCC "25) " + FCC "26) " + FCC "27) " + FCC "28) " + FCC "29) " + FCC "30) " + FCC "31) " +* SCREEN 2 + FCC " ( FORTH 68 RAM resident utilities and testing stuff ) " 0 + FCC " ( Copyright 2013 Joel Rees ) " 1 + FCC " " 2 + FCC " " 3 + FCC " " 4 + FCC " " 5 + FCC " " 6 + FCC " " 7 + FCC " " 8 + FCC " " 9 + FCC " " 10 + FCC " " 11 + FCC " " 12 + FCC " " 13 + FCC " " 14 + FCC " " 15 +* SCREEN 3 + FCC " ( No need to call the monitor in exorsim, just ctrl-c. ) " 0 + FCC " ( But maybe we can put some other useful stuff here. ) " 1 + FCC " " 2 + FCC " 1 WARNING ! " 3 + FCC " " 4 + FCC " VOCABULARY DEBUG DEFINITIONS " 5 + FCC " ( addr n -- ) " 6 + FCC " : DUMPHEX BASE @ >R HEX " 7 + FCC " 0 DO DUP I + C@ 0 <# # # #> TYPE SPACE LOOP " 8 + FCC " DROP R> BASE ! ; " 9 + FCC " " 10 + FCC " " 11 + FCC " " 12 + FCC " " 13 + FCC " " 14 + FCC " FORTH DEFINITIONS " 15 +* SCREEN 4 + FCC "( ERROR MESSAGES ) " 0 + FCC "DATA STACK UNDERFLOW " 1 + FCC "DICTIONARY FULL " 2 + FCC "ADDRESS RESOLUTION ERROR " 3 + FCC "HIDES DEFINITION IN " 4 + FCC "NULL VECTOR WRITTEN " 5 + FCC "DISC RANGE? " 6 + FCC "DATA STACK OVERFLOW " 7 + FCC "DISC ERROR! " 8 + FCC "CAN'T EXECUTE A NULL! " 9 + FCC "CONTROL STACK UNDERFLOW " 10 + FCC "CONTROL STACK OVERFLOW " 11 + FCC "ARRAY REFERENCE OUT OF BOUNDS " 12 + FCC "ARRAY DIMENSION NOT VALID " 13 + FCC "NO PROCEDURE TO ENTER " 14 + FCC " ( WAS REGISTER ) " 15 +* SCREEN 5 + FCC " " 0 + FCC "COMPILATION ONLY, USE IN DEF " 1 + FCC "EXECUTION ONLY " 2 + FCC "CONDITIONALS NOT PAIRED " 3 + FCC "DEFINITION INCOMPLETE " 4 + FCC "IN PROTECTED DICTIONARY " 5 + FCC "USE ONLY WHEN LOADING " 6 + FCC "OFF CURRENT EDITING SCREEN " 7 + FCC "DECLARE VOCABULARY " 8 + FCC "DEFINITION NOT IN VOCABULARY " 9 + FCC "IN FORWARD BLOCK " 10 + FCC "ALLOCATION LIST CORRUPTED: LOST " 11 + FCC "CAN'T REDEFINE nul! " 12 + FCC "NOT FORWARD REFERENCE " 13 + FCC " ( WAS IMMEDIATE ) " 14 + FCC " " 15 +* SCREEN 6 + FCC "( MORE ERROR MESSAGES asm6809 ) " 0 + FCC "HAS INCORRECT ADDRESS MODE " 1 + FCC "HAS INCORRECT INDEX MODE " 2 + FCC "OPERAND NOT REGISTER " 3 + FCC "HAS ILLEGAL IMMEDIATE " 4 + FCC "PC OFFSET MUST BE ABSOLUTE " 5 + FCC "ACCUMULATOR OFFSET REQUIRED " 6 + FCC "ILLEGAL MEMORY INDIRECTION (6809) " 7 + FCC "ILLEGAL INDEX BASE (6809) " 8 + FCC "ILLEGAL TARGET SPECIFIED " 9 + FCC "CAN'T STACK ON SELF (6809) " 10 + FCC "DUPLICATE IN LIST " 11 + FCC "REGISTER NOT STACK (6809) " 12 + FCC "EMPTY REGISTER LIST (6809) " 13 + FCC "IMMEDIATE OPERAND REQUIRED " 14 + FCC "REQUIRES CONDITION " 15 +* +* SCREEN 7 + FCC " " 0 + FCC "COMPILE-TIME STACK UNDERFLOW " 1 + FCC "COMPILE-TIME STACK OVERFLOW " 2 + FCC " " 3 + FCC " " 4 + FCC " " 5 + FCC " " 6 + FCC " " 7 + FCC " " 8 + FCC " " 9 + FCC " " 10 + FCC " " 11 + FCC " " 12 + FCC " " 13 + FCC " " 14 + FCC " " 15 +* +* SCREEN 8 + FCC " ( Crude editing facilities. -- one byte characters ) " 0 + FCC " " 1 + FCC " VOCABULARY EDITOR DEFINITIONS " 2 + FCC " " 3 + FCC " ( n -- nb nc ) ( convert line number to block, count offset ) " 4 + FCC " : L2BLOCK 64 * B/BUF /MOD ; ( 64 characters per line magic # ) " 5 + FCC " " 6 + FCC " ( n -- n ) ( convert screen number to block number ) " 7 + FCC " : S2BLOCK B/SCR * ; ( magic numbers hidden in B/SCR ) " 8 + FCC " " 9 + FCC " ( ns nl -- addr ) ( screen, line to address in block ) " 10 + FCC " : SL2BB SWAP S2BLOCK SWAP L2BLOCK SWAP >R + BLOCK R> + ; " 11 + FCC " " 12 + FCC " ( ns nl -- ) ( show one line of the screen ) " 13 + FCC " : SHOWLINE SL2BB CR 64 TYPE ; ( list just one line ) " 14 + FCC " --> " 15 +* +* SCREEN 9 + FCC " ( More crude editing facilities. -- one byte characters ) " 0 + FCC " " 1 + FCC " 0 VARIABLE LNEDBUF 62 ALLOT ( buffer for line editing ) " 2 + FCC " " 3 + FCC " ( ns nl -- ) ( overwrite one line of the screen ) " 4 + FCC " : PUTLINE LNEDBUF 64 BLANKS ( just enough to write to disc ) " 5 + FCC " CR LNEDBUF 64 EXPECT CR ( just enough to write ) " 6 + FCC " SL2BB LNEDBUF SWAP 64 CMOVE UPDATE ; " 7 + FCC " ( Full screen editing requires keyboard control codes. ) " 8 + FCC " " 9 + FCC " " 10 + FCC " " 11 + FCC " " 12 + FCC " " 13 + FCC " " 14 + FCC " " 15 +* +* I don't know enough about the EXORciser, and don't want to take the time +* to try to work through the disk simulation in exorsim to get real simulated +* disk access running. +* This gives me enough to check my understanding of forth, to help me figure +* out my bif-c project or whatever my next step is. +* +* Going farther with the exorsim version of the fig-FORTH 6800 model would be +* a good student exercise, maybe? (For what coursework?) +* But I think I need to move on. +* +* SCREEN 10 + FCC " " 0 + FCC " " 1 + FCC " " 2 + FCC " " 3 + FCC " " 4 + FCC " " 5 + FCC " " 6 + FCC " " 7 + FCC " " 8 + FCC " " 9 + FCC " " 10 + FCC " " 11 + FCC " " 12 + FCC " " 13 + FCC " " 14 + FCC " " 15 +* +* SCREEN 11 + FCC " " 0 + FCC " " 1 + FCC " " 2 + FCC " " 3 + FCC " " 4 + FCC " " 5 + FCC " " 6 + FCC " " 7 + FCC " " 8 + FCC " " 9 + FCC " " 10 + FCC " " 11 + FCC " " 12 + FCC " " 13 + FCC " " 14 + FCC " " 15 +* +* SCREEN 12 + FCC " " 0 + FCC " " 1 + FCC " " 2 + FCC " " 3 + FCC " " 4 + FCC " " 5 + FCC " " 6 + FCC " " 7 + FCC " " 8 + FCC " " 9 + FCC " " 10 + FCC " " 11 + FCC " " 12 + FCC " " 13 + FCC " " 14 + FCC " " 15 +* +RAMDEN EQU * +RAMDSZ EQU RAMDEN-MEMEND +* + ORG ORIG ; set the COLD entry address + + + + + + PAGE + OPT L + END -- 2.11.0