* 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 ,U++ BPL XPLOF ADDD ,S STD ,S SUBD 2,S **** Have to think about this. * * 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