OPT PRT * fig-FORTH FOR 6809, converted by unintelligent conversion from 6800 source. * To do: * 4 IO routines -- OK? * adjust ram locations -- OK? * then add trace routines -- OK? * then try in emulator * ASSEMBLY SOURCE LISTING * RELEASE 1 * MAY 1979 * WITH COMPILER SECURITY * AND VARIABLE LENGTH NAMES * 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 NOG,PAG * filename FTH7.21 * === FORTH-6800 06-06-79 21:OO * 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 * * 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 ) * Note: PCR, also. (PRTCR) * * 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. * * 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. * * NBLK EQU 4 # of disc buffer blocks for virtual memory * MEMEND EQU 132*NBLK+$3000 end of ram MEMEND EQU 132*NBLK+$5000+132 end of ram with some breathing room (32K Coco) * 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 (32K Coco) * No ACIA in Coco (how sad). * ACIAC EQU $FBCE the ACIA control address and * ACIAD EQU ACIAC+1 data address for PROTO PAGE * MEMORY MAP for this 16K system (32K Coco): * ( positioned so that systems with 4k byte write- * protected segments can write protect FORTH ) * * Read below and calculate it yourself: * addr. contents pointer init by * **** ******************************* ******* ****** * 3FFF HI * substitute for disc mass memory * 3210 LO,MEMEND * 320F * 4 buffer sectors of VIRTUAL MEMORY * 3000 FIRST * >>>>>> memory from here up must be RAM <<<<<< * * 27FF * 6k of romable "FORTH" <== IP ABORT * <== W * the VIRTUAL FORTH MACHINE * * 1004 (3004) <<< WARM START ENTRY >>> * 1000 (3000) <<< COLD START ENTRY >>> * * >>>>>> memory from here down must be RAM <<<<<< * FFE RETURN STACK base <== RP RINIT * * FB4 * INPUT LINE BUFFER * holds up to 132 characters * and is scanned upward by IN * starting at TIB * F30 <== IN TIB * F2F DATA STACK <== SP SP0,SINIT * | grows downward from F2F * v * - - * | * I DICTIONARY grows upward * * 183 end of ram-dictionary. <== DP DPINIT * "TASK" * * 150 "FORTH" ( a word ) <=, <== CONTEXT * `==== CURRENT * 148 start of ram-dictionary. * * 100 user #l table of variables <= UP DPINIT * F0 registers & pointers for the virtual machine * scratch area used by various words * E0 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 * SP (hardware SP) points to first free byte in data 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 $1300 variables PGBASE EQU * PGBDP EQU PGBASE/$100 SETDP PGBDP N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY, * SP@,SWAP,DOES>,COLD * 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: W RMB 2 the instruction register points to 6800 code IP RMB 2 the instruction pointer points to pointer to 6800 code RP RMB 2 the return stack pointer UP RMB 2 the pointer to base of current user's 'USER' table * ( altered during multi-tasking ) * * For the tracer: RMB 4 TRASP RMB 2 TRAVEC RMB 2 TRAA RMB 1 TRAB RMB 1 FLAGON 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 * * * 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 $1400 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 'FORT' ; 'FORTH' FCB $C8 FDB NOOP-7 FORTH FDB DODOES,DOVOC,$81A0,TASK-7 FDB 0 * FCC "(C) Forth Interest Group, 1979" FCB $84 FCC 'TAS' ; 'TASK' FCB $CB FDB FORTH-8 TASK FDB DOCOL,SEMIS * REND EQU * ( first empty location in dictionary ) PAGE * Check the addresses yourself: * The FORTH program ( address $1000 to $27FF ) is written * so that it can be in a ROM, or write-protected if desired ORG $3000 * ######>> 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 ************************** * RPTIB EQU $200 Give us more room to breath. SBUMPR EQU $10 Bumper area for stacks. * FDB $6800,6809 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-RPTIB-SBUMPR*2 * RINIT FDB ORIG-2 initial top of return stack RINIT FDB ORIG-SBUMPR * FDB ORIG-$D0 terminal input buffer FDB ORIG-RPTIB-SBUMPR 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 << * Calculate the cycles yourself: PULABX PULS A 24 cycles until 'NEXT' PULS B STABX STA 0,X 16 cycles until 'NEXT' STB 1,X BRA NEXT GETX LDA 0,X 18 cycles until 'NEXT' LDB 1,X PUSHBA PSHS B 8 cycles until 'NEXT' PSHS A * * "NEXT" takes 38 cycles if TRACE is removed, * * and 95 cycles if NOT tracing. (Way bogus numbers by now.) * * = = = = = = = t h e v i r t u a l m a c h i n e = = = = = * = NEXT LDX IP LEAX 1,X pre-increment mode LEAX 1,X 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 * = * The next instruction could be patched to JMP TRACE = * if a TRACE routine is available: = * = * Or add the TRACE routine in-line, since we are assembling it. TST TRACEM BEQ NEXTGO STX TRAVEC TFR S,X ; Mechanical! Mechanical! (So the funn 6800 stack didn't beach us.) STX TRASP LDA #':' JSR PEMIT * LDA #' ' * JSR PEMIT LDX W LEAX -1,X LEAX -1,X ; allocation link LEAX -1,X ; last char LDA #31 NAMTST LEAX -1,X ; length byte? LDB 0,X BMI NAMTDN DECA BNE NAMTST NAMTDN ANDB #31 ; It's the length byte whether it wants to be or not. NAMSHW LEAX 1,X LDA 0,X JSR PEMIT DECB BNE NAMSHW * show the virtual registers * TOO MUCH OUTPUT! Have to trim this. LDA #' ' JSR PEMIT LDA #'@' LDX #TRAVEC JSR PHEX4F TFR DP,A LDB #(W-PGBASE) TFR D,X LDA #'W' JSR PHEX4F LDA #'I' JSR PHEX4F LDA #'R' JSR PHEX4F LDA #'U' JSR PHEX4F TFR DP,A LDB #(W-TRASP) TFR D,X LDA #'S' BSR PHEX4F LDA #'>' TFR S,X BSR PHEX4F LDA #' ' BSR PHEX4F * JSR PRTCR LDX TRAVEC * NEXTGO JMP 0,X NOP * JMP TRACE ( an alternate for the above ) * = * = *DBG PHEX4F JSR PEMIT BSR PHEXX2 BSR PHEXX2 LDA #' ' JMP PEMIT ; rob return * PHEXX2 LDA 0,X LSRA LSRA LSRA LSRA BSR PHEXD LDA 0,X BSR PHEXD LEAX 1,X RTS * PHEXD ANDA #$0F CMPA #10 BLO PHEXDH ADDA #7 ; 'A'-'9'+1 PHEXDH ADDA #'0' JMP PEMIT ; rob return * DEBUGP FDB *+2 INC FLAGON my version of trace LDA FLAGON JSR PEMIT JMP NEXT * DEBUGM FDB *+2 DEC FLAGON my version of trace LDA FLAGON JSR PEMIT JMP NEXT *DBG * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = PAGE * * ======>> 1 << FCB $83 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL FCB $D4 FDB 0 link of zero to terminate dictionary scan LIT FDB *+2 LDX IP LEAX 1,X LEAX 1,X STX IP LDA 0,X LDB 1,X JMP PUSHBA * * ######>> screen 14 << * ======>> 2 << CLITER FDB *+2 (this is an invisible word, with no header) LDX IP LEAX 1,X STX IP CLRA LDB 1,X JMP PUSHBA * * ======>> 3 << FCB $87 FCC 'EXECUT' ; 'EXECUTE' FCB $C5 FDB LIT-6 EXEC FDB *+2 TFR S,X LDX 0,X get code field address (CFA) LEAS 1,S pop stack LEAS 1,S JMP NEXT3 * * ######>> screen 15 << * ======>> 4 << FCB $86 FCC 'BRANC' ; 'BRANCH' FCB $C8 FDB EXEC-10 BRAN FDB ZBYES Go steal code in ZBRANCH * * ======>> 5 << FCB $87 FCC '0BRANC' ; '0BRANCH' FCB $C8 FDB BRAN-9 ZBRAN FDB *+2 PULS A PULS B * ABA is only used here. * Could immediately convert PULs to LDD ,S++ ; * with no need for trailing BCS to look for overflow * because we are only testing for non-zero, but, * converting as if by unintelligent macro: PSHS B ; LOL ADDA ,S+ * End of unintelligent ABA conversion. BNE ZBNO BCS ZBNO ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP) LDB 3,X LDA 2,X ADDB IP+1 ADCA IP STB IP+1 STA IP JMP NEXT ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP). LEAX 1,X jump over branch delta LEAX 1,X STX IP JMP NEXT * * ######>> screen 16 << * ======>> 6 << FCB $86 FCC '(LOOP' ; '(LOOP)' FCB $A9 FDB ZBRAN-10 XLOOP FDB *+2 CLRA LDB #1 get set to increment counter by 1 BRA XPLOP2 go steal other guy's code! * * ======>> 7 << FCB $87 FCC '(+LOOP' ; '(+LOOP)' FCB $A9 FDB XLOOP-9 XPLOOP FDB *+2 Note: +LOOP has an un-signed loop counter PULS A get increment PULS B XPLOP2 TSTA BPL XPLOF forward looping BSR XPLOPS ORCC #1 SBCB 5,X SBCA 4,X BPL ZBYES BRA XPLONO fall through * * the subroutine : XPLOPS LDX RP ADDB 3,X add it to counter ADCA 2,X STB 3,X store new counter value STA 2,X RTS * XPLOF BSR XPLOPS SUBB 5,X SBCA 4,X BMI ZBYES * XPLONO LEAX 1,X done, don't branch back LEAX 1,X LEAX 1,X LEAX 1,X STX RP BRA ZBNO use ZBRAN to skip over unused delta * * ######>> screen 17 << * ======>> 8 << FCB $84 FCC '(DO' ; '(DO)' FCB $A9 FDB XPLOOP-10 XDO FDB *+2 This is the RUNTIME DO, not the COMPILING DO LDX RP LEAX -1,X LEAX -1,X LEAX -1,X LEAX -1,X STX RP PULS A PULS B STA 2,X STB 3,X PULS A PULS B STA 4,X STB 5,X JMP NEXT * * ======>> 9 << FCB $81 I FCB $C9 FDB XDO-7 I FDB *+2 LDX RP LEAX 1,X LEAX 1,X JMP GETX * * ######>> screen 18 << * ======>> 10 << FCB $85 FCC 'DIGI' ; 'DIGIT' FCB $D4 FDB I-4 DIGIT FDB *+2 NOTE: legal input range is 0-9, A-Z TFR S,X LDA 3,X SUBA #$30 ascii zero BMI DIGIT2 IF LESS THAN '0', ILLEGAL CMPA #$A BMI DIGIT0 IF '9' OR LESS CMPA #$11 BMI DIGIT2 if less than 'A' CMPA #$2B BPL DIGIT2 if greater than 'Z' SUBA #7 translate 'A' thru 'F' DIGIT0 CMPA 1,X BPL DIGIT2 if not less than the base LDB #1 set flag STA 3,X store digit DIGIT1 STB 1,X store the flag JMP NEXT DIGIT2 CLRB LEAS 1,S LEAS 1,S pop bottom number TFR S,X STB 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 '(FIND' ; '(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 PCT EQU N+6 ; PC in 6800 source LDX #PD LDB #4 PFIND0 PULS A loop to get arguments STA 0,X LEAX 1,X DECB BNE PFIND0 * LDX PD PFIND1 LDB 0,X get count dict count STB PCT ANDB #$3F LEAX 1,X STX PD update PD LDX PA0 LDA 0,X get count from arg LEAX 1,X STX PA intialize PA PSHS B ; sim CBA CMPA ,S+ compare lengths BNE PFIND4 PFIND2 LDX PA LDA 0,X LEAX 1,X STX PA LDX PD LDB 0,X LEAX 1,X STX PD TSTB is dict entry neg. ? BPL PFIND8 ANDB #$7F clear sign PSHS B ; sim CBA CMPA ,S+ BEQ FOUND PFIND3 LDX 0,X get new link BNE PFIND1 continue if link not=0 * * not found : * CLRA CLRB JMP PUSHBA PFIND8 PSHS B ; sim CBA CMPA ,S+ BEQ PFIND2 PFIND4 LDX PD PFIND9 LDB 0,X scan forward to end of this name LEAX 1,X BPL PFIND9 BRA PFIND3 * * found : * FOUND LDA PD compute CFA LDB PD+1 ADDB #4 ADCA #0 PSHS B PSHS A LDA PCT PSHS A CLRA PSHS A LDB #1 JMP PUSHBA * PSHS A CLRA PSHS A LDB #1 JMP PUSHBA * * ######>> screen 20 << * ======>> 12 << FCB $87 FCC 'ENCLOS' ; '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 LEAS 1,S PULS B now, get the low byte, for an 8-bit delimiter TFR S,X LDX 0,X CLR N * wait for a non-delimiter or a NUL ENCL2 LDA 0,X BEQ ENCL6 PSHS B ; sim CBA CMPA ,S+ CHECK FOR DELIM BNE ENCL3 LEAX 1,X INC N BRA ENCL2 * found first character. Push FC ENCL3 LDA N found first char. PSHS A CLRA PSHS A * wait for a delimiter or a NUL ENCL4 LDA 0,X BEQ ENCL7 PSHS B ; sim CBA CMPA ,S+ ckech for delim. BEQ ENCL5 LEAX 1,X INC N BRA ENCL4 * found EW. Push it ENCL5 LDB N CLRA PSHS B PSHS A * advance and push NC INCB JMP PUSHBA * found NUL before non-delimiter, therefore there is no word ENCL6 LDB N found NUL PSHS B PSHS A INCB BRA ENCL7A ; ENCL7+2 ******* was a *potential* bug ****** (But DP) * found NUL following the word instead of SPACE ENCL7 LDB N ENCL7A PSHS B save EW PSHS A ENCL8 LDB 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 'EMI' ; 'EMIT' FCB $D4 FDB ENCLOS-10 EMIT FDB *+2 PULS A PULS A JSR PEMIT LDX UP INC XOUT+1-UORIG,X BNE EMITDN INC XOUT-UORIG,X EMITDN JMP NEXT * * ======>> 14 << FCB $83 FCC 'KE' ; 'KEY' FCB $D9 FDB EMIT-7 KEY FDB *+2 JSR PKEY PSHS A CLRA PSHS A JMP NEXT * * ======>> 15 << FCB $89 FCC '?TERMINA' ; '?TERMINAL' FCB $CC FDB KEY-6 QTERM FDB *+2 JSR PQTER CLRB JMP PUSHBA stack the flag * * ======>> 16 << FCB $82 FCC 'C' ; 'CR' FCB $D2 FDB QTERM-12 CR FDB *+2 JSR PRTCR JMP NEXT * * ######>> screen 22 << * ======>> 17 << FCB $85 FCC 'CMOV' ; 'CMOVE' : source, destination, count FCB $C5 FDB CR-5 CMOVE FDB *+2 takes ( 43+47*count cycles ) LDX #N LDB #6 CMOV1 PULS A STA 0,X move parameters to scratch area LEAX 1,X DECB BNE CMOV1 CMOV2 LDA N LDB N+1 SUBB #1 SBCA #0 STA N STB N+1 BCS CMOV3 LDX N+4 LDA 0,X LEAX 1,X STX N+4 LDX N+2 STA 0,X LEAX 1,X STX N+2 BRA CMOV2 CMOV3 JMP NEXT * * ######>> screen 23 << * ======>> 18 << FCB $82 FCC 'U' ; 'U*' FCB $AA FDB CMOVE-8 USTAR FDB *+2 BSR USTARS LEAS 1,S LEAS 1,S 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 #16 bits/word counter PSHS A CLRA CLRB TFR S,X USTAR2 ROR 5,X shift multiplier ROR 6,X DEC 0,X done? BMI USTAR4 BCC USTAR3 ADDB 4,X ADCA 3,X USTAR3 RORA RORB ; shift result BRA USTAR2 USTAR4 LEAS 1,S dump counter RTS * * ######>> screen 24 << * ======>> 19 << FCB $82 FCC 'U' ; 'U/' FCB $AF FDB USTAR-5 USLASH FDB *+2 LDA #17 PSHS A TFR S,X LDA 3,X LDB 4,X USL1 CMPA 1,X BHI USL3 BCS USL2 CMPB 2,X BCC USL3 USL2 ANDCC #~1 BRA USL4 USL3 SUBB 2,X SBCA 1,X ORCC #1 USL4 ROL 6,X ROL 5,X DEC 0,X BEQ USL5 ROLB ROLA BCC USL1 BRA USL3 USL5 LEAS 1,S LEAS 1,S LEAS 1,S LEAS 1,S LEAS 1,S JMP SWAP+4 reverse quotient & remainder * * ######>> screen 25 << * ======>> 20 << FCB $83 FCC 'AN' ; 'AND' FCB $C4 FDB USLASH-5 AND FDB *+2 PULS A PULS B TFR S,X ANDB 1,X ANDA 0,X JMP STABX * * ======>> 21 << FCB $82 FCC 'O' ; 'OR' FCB $D2 FDB AND-6 OR FDB *+2 PULS A PULS B TFR S,X ORB 1,X ORA 0,X JMP STABX * * ======>> 22 << FCB $83 FCC 'XO' ; 'XOR' FCB $D2 FDB OR-5 XOR FDB *+2 PULS A PULS B TFR S,X EORB 1,X EORA 0,X JMP STABX * * ######>> screen 26 << * ======>> 23 << FCB $83 FCC 'SP' ; 'SP@' FCB $C0 FDB XOR-6 SPAT FDB *+2 TFR S,X STX N scratch area LDX #N JMP GETX * * ======>> 24 << FCB $83 FCC 'SP' ; 'SP!' FCB $A1 FDB SPAT-6 SPSTOR FDB *+2 LDX UP LDX XSPZER-UORIG,X * Potential problem area? No. ****** TFR X,S watch it ! X and S are not equal -- on 6800. * But they are on 6809, and that's what we want here. JMP NEXT * ======>> 25 << FCB $83 FCC 'RP' ; 'RP!' FCB $A1 FDB SPSTOR-6 RPSTOR FDB *+2 LDX RINIT initialize from rom constant STX RP JMP NEXT * * ======>> 26 << FCB $82 FCC ';' ; ';S' FCB $D3 FDB RPSTOR-6 SEMIS FDB *+2 * DBG LDA #-$10 ADDA FLAGON STA FLAGON my version of trace JSR PEMIT * LDX RP LEAX 1,X LEAX 1,X 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 'LEAV' ; 'LEAVE' FCB $C5 FDB SEMIS-5 LEAVE FDB *+2 LDX RP LDA 2,X LDB 3,X STA 4,X STB 5,X JMP NEXT * * ======>> 28 << FCB $82 FCC '>' ; '>R' FCB $D2 FDB LEAVE-8 TOR FDB *+2 LDX RP LEAX -1,X LEAX -1,X STX RP PULS A PULS B STA 2,X STB 3,X JMP NEXT * * ======>> 29 << FCB $82 FCC 'R' ; 'R>' FCB $BE FDB TOR-5 FROMR FDB *+2 LDX RP LDA 2,X LDB 3,X LEAX 1,X LEAX 1,X STX RP JMP PUSHBA * * ======>> 30 << FCB $81 R FCB $D2 FDB FROMR-5 R FDB *+2 LDX RP LEAX 1,X LEAX 1,X JMP GETX * * ######>> screen 28 << * ======>> 31 << FCB $82 FCC '0' ; '0=' FCB $BD FDB R-4 ZEQU FDB *+2 TFR S,X CLRA CLRB LDX 0,X BNE ZEQU2 INCB ZEQU2 TFR S,X JMP STABX * * ======>> 32 << FCB $82 FCC '0' ; '0<' FCB $BC FDB ZEQU-5 ZLESS FDB *+2 TFR S,X LDA #$80 check the sign bit ANDA 0,X BEQ ZLESS2 CLRA if neg. LDB #1 JMP STABX ZLESS2 CLRB JMP STABX * * ######>> screen 29 << * ======>> 33 << FCB $81 '+' FCB $AB FDB ZLESS-5 PLUS FDB *+2 PULS A PULS B TFR S,X ADDB 1,X ADCA 0,X JMP STABX * * ======>> 34 << FCB $82 FCC 'D' ; 'D+' FCB $AB FDB PLUS-4 DPLUS FDB *+2 TFR S,X ANDCC #~1 LDB #4 DPLUS2 LDA 3,X ADCA 7,X STA 7,X LEAX -1,X DECB BNE DPLUS2 LEAS 1,S LEAS 1,S LEAS 1,S LEAS 1,S JMP NEXT * * ======>> 35 << FCB $85 FCC 'MINU' ; 'MINUS' FCB $D3 FDB DPLUS-5 MINUS FDB *+2 TFR S,X NEG 1,X BCC MINUS2 NEG 0,X BRA MINUS3 MINUS2 COM 0,X MINUS3 JMP NEXT * * ======>> 36 << FCB $86 FCC 'DMINU' ; 'DMINUS' FCB $D3 FDB MINUS-8 DMINUS FDB *+2 TFR S,X 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 'OVE' ; 'OVER' FCB $D2 FDB DMINUS-9 OVER FDB *+2 TFR S,X LDA 2,X LDB 3,X JMP PUSHBA * * ======>> 38 << FCB $84 FCC 'DRO' ; 'DROP' FCB $D0 FDB OVER-7 DROP FDB *+2 LEAS 1,S LEAS 1,S JMP NEXT * * ======>> 39 << FCB $84 FCC 'SWA' ; 'SWAP' FCB $D0 FDB DROP-7 SWAP FDB *+2 PULS A PULS B TFR S,X LDX 0,X LEAS 1,S LEAS 1,S PSHS B PSHS A STX N LDX #N JMP GETX * * ======>> 40 << FCB $83 FCC 'DU' ; 'DUP' FCB $D0 FDB SWAP-7 DUP FDB *+2 PULS A PULS B PSHS B PSHS A JMP PUSHBA * * ######>> screen 31 << * ======>> 41 << FCB $82 FCC '+' ; '+!' FCB $A1 FDB DUP-6 PSTORE FDB *+2 TFR S,X LDX 0,X LEAS 1,S LEAS 1,S PULS A get stack data PULS B ADDB 1,X add & store low byte STB 1,X ADCA 0,X add & store hi byte STA 0,X JMP NEXT * * ======>> 42 << FCB $86 FCC 'TOGGL' ; '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 TFR S,X LDX 0,X get address LEAS 1,S LEAS 1,S JMP GETX * * ======>> 44 << FCB $82 FCC 'C' ; 'C@' FCB $C0 FDB AT-4 CAT FDB *+2 TFR S,X LDX 0,X CLRA LDB 0,X LEAS 1,S LEAS 1,S JMP PUSHBA * * ======>> 45 << FCB $81 FCB $A1 FDB CAT-5 STORE FDB *+2 TFR S,X LDX 0,X get address LEAS 1,S LEAS 1,S JMP PULABX * * ======>> 46 << FCB $82 FCC 'C' ; 'C!' FCB $A1 FDB STORE-4 CSTORE FDB *+2 TFR S,X LDX 0,X get address LEAS 1,S LEAS 1,S LEAS 1,S PULS B STB 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 LEAX -1,X LEAX -1,X STX RP * DBG LDA #$10 ADDA FLAGON STA FLAGON my version of trace JSR PEMIT * LDA IP LDB IP+1 STA 2,X Store address of the high level word STB 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 'CONSTAN' ; 'CONSTANT' FCB $D4 FDB SEMI-4 CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE DOCON LDX W LDA 2,X LDB 3,X A & B now contain the constant JMP PUSHBA * * ======>> 50 << FCB $88 FCC 'VARIABL' ; 'VARIABLE' FCB $C5 FDB CON-11 VAR FDB DOCOL,CON,PSCODE DOVAR LDA W LDB W+1 ADDB #2 ADCA #0 A,B now contain the address of the variable JMP PUSHBA * * ======>> 51 << FCB $84 FCC 'USE' ; 'USER' FCB $D2 FDB VAR-11 USER FDB DOCOL,CON,PSCODE DOUSER LDX W get offset into user's table LDA 2,X LDB 3,X ADDB UP+1 add to users base address ADCA 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 'B' ; 'BL' FCB $CC FDB THREE-4 BL FDB DOCON ascii blank FDB $20 * * ======>> 57 << FCB $85 FCC 'FIRS' ; 'FIRST' FCB $D4 FDB BL-5 FIRST FDB DOCON FDB MEMEND-528 (132 * NBLK) * * ======>> 58 << FCB $85 FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 ) FCB $D4 FDB FIRST-8 LIMIT FDB DOCON FDB MEMEND * * ======>> 59 << FCB $85 FCC 'B/BU' ; 'B/BUF' : (bytes/buffer) FCB $C6 FDB LIMIT-8 BBUF FDB DOCON FDB 128 * * ======>> 60 << FCB $85 FCC 'B/SC' ; 'B/SCR' : (blocks/screen) FCB $D2 FDB BBUF-8 BSCR FDB DOCON FDB 8 * blocks/screen = 1024 / "B/BUF" = 8 * * ======>> 61 << FCB $87 FCC '+ORIGI' ; '+ORIGIN' FCB $CE FDB BSCR-8 PORIG FDB DOCOL,LIT,ORIG,PLUS FDB SEMIS * * ######>> screen 36 << * ======>> 62 << FCB $82 FCC 'S' ; 'S0' FCB $B0 FDB PORIG-10 SZERO FDB DOUSER FDB XSPZER-UORIG * * ======>> 63 << FCB $82 FCC 'R' ; 'R0' FCB $B0 FDB SZERO-5 RZERO FDB DOUSER FDB XRZERO-UORIG * * ======>> 64 << FCB $83 FCC 'TI' ; 'TIB' FCB $C2 FDB RZERO-5 TIB FDB DOUSER FDB XTIB-UORIG * * ======>> 65 << FCB $85 FCC 'WIDT' ; 'WIDTH' FCB $C8 FDB TIB-6 WIDTH FDB DOUSER FDB XWIDTH-UORIG * * ======>> 66 << FCB $87 FCC 'WARNIN' ; 'WARNING' FCB $C7 FDB WIDTH-8 WARN FDB DOUSER FDB XWARN-UORIG * * ======>> 67 << FCB $85 FCC 'FENC' ; 'FENCE' FCB $C5 FDB WARN-10 FENCE FDB DOUSER FDB XFENCE-UORIG * * ======>> 68 << FCB $82 FCC 'D' ; 'DP' : points to first free byte at end of dictionary FCB $D0 FDB FENCE-8 DICPT FDB DOUSER ; DP in 6800 source FDB XDP-UORIG * * ======>> 68.5 << FCB $88 FCC 'VOC-LIN' ; 'VOC-LINK' FCB $CB FDB DICPT-5 VOCLIN FDB DOUSER FDB XVOCL-UORIG * * ======>> 69 << FCB $83 FCC 'BL' ; 'BLK' FCB $CB FDB VOCLIN-11 BLK FDB DOUSER FDB XBLK-UORIG * * ======>> 70 << FCB $82 FCC 'I' ; 'IN' : scan pointer for input line buffer FCB $CE FDB BLK-6 IN FDB DOUSER FDB XIN-UORIG * * ======>> 71 << FCB $83 FCC 'OU' ; 'OUT' FCB $D4 FDB IN-5 OUT FDB DOUSER FDB XOUT-UORIG * * ======>> 72 << FCB $83 FCC 'SC' ; 'SCR' FCB $D2 FDB OUT-6 SCR FDB DOUSER FDB XSCR-UORIG * ######>> screen 37 << * * ======>> 73 << FCB $86 FCC 'OFFSE' ; 'OFFSET' FCB $D4 FDB SCR-6 OFSET FDB DOUSER FDB XOFSET-UORIG * * ======>> 74 << FCB $87 FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first FCB $D4 FDB OFSET-9 CONTXT FDB DOUSER FDB XCONT-UORIG * * ======>> 75 << FCB $87 FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended FCB $D4 FDB CONTXT-10 CURENT FDB DOUSER FDB XCURR-UORIG * * ======>> 76 << FCB $85 FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not FCB $C5 FDB CURENT-10 STATE FDB DOUSER FDB XSTATE-UORIG * * ======>> 77 << FCB $84 FCC 'BAS' ; 'BASE' : number base for all input & output FCB $C5 FDB STATE-8 BASE FDB DOUSER FDB XBASE-UORIG * * ======>> 78 << FCB $83 FCC 'DP' ; 'DPL' FCB $CC FDB BASE-7 DPL FDB DOUSER FDB XDPL-UORIG * * ======>> 79 << FCB $83 FCC 'FL' ; 'FLD' FCB $C4 FDB DPL-6 FLD FDB DOUSER FDB XFLD-UORIG * * ======>> 80 << FCB $83 FCC 'CS' ; 'CSP' FCB $D0 FDB FLD-6 CSP FDB DOUSER FDB XCSP-UORIG * * ======>> 81 << FCB $82 FCC 'R' ; 'R#' FCB $A3 FDB CSP-6 RNUM FDB DOUSER FDB XRNUM-UORIG * * ======>> 82 << FCB $83 FCC 'HL' ; 'HLD' FCB $C4 FDB RNUM-5 HLD FDB DOCON FDB XHLD * * ======>> 82.5 <<== SPECIAL FCB $87 FCC 'COLUMN' ; '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 '2' ; '2+' FCB $AB FDB ONEP-5 TWOP FDB DOCOL,TWO,PLUS FDB SEMIS * * ======>> 85 << FCB $84 FCC 'HER' ; 'HERE' FCB $C5 FDB TWOP-5 HERE FDB DOCOL,DICPT,AT FDB SEMIS * * ======>> 86 << FCB $85 FCC 'ALLO' ; 'ALLOT' FCB $D4 FDB HERE-7 ALLOT FDB DOCOL,DICPT,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 'C' ; '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 PULS A PULS B TFR S,X CMPA 0,X LEAS 1,S BGT LESST BNE LESSF CMPB 1,X BHI LESST LESSF CLRB BRA LESSX LESST LDB #1 LESSX CLRA LEAS 1,S JMP PUSHBA * * ======>> 92 << FCB $81 > FCB $BE FDB LESS-4 GREAT FDB DOCOL,SWAP,LESS FDB SEMIS * * ======>> 93 << FCB $83 FCC 'RO' ; 'ROT' FCB $D4 FDB GREAT-4 ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP FDB SEMIS * * ======>> 94 << FCB $85 FCC 'SPAC' ; 'SPACE' FCB $C5 FDB ROT-6 SPACE FDB DOCOL,BL,EMIT FDB SEMIS * * ======>> 95 << FCB $83 FCC 'MI' ; '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 'MA' ; '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 '-DU' ; '-DUP' FCB $D0 FDB MAX-6 DDUP FDB DOCOL,DUP,ZBRAN FDB DDUP2-* FDB DUP DDUP2 FDB SEMIS * * ######>> screen 39 << * ======>> 98 << FCB $88 FCC 'TRAVERS' ; '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 'LATES' ; 'LATEST' FCB $D4 FDB TRAV-11 LATEST FDB DOCOL,CURENT,AT,AT FDB SEMIS * * ======>> 100 << FCB $83 FCC 'LF' ; 'LFA' FCB $C1 FDB LATEST-9 LFA FDB DOCOL,CLITER FCB 4 FDB SUB FDB SEMIS * * ======>> 101 << FCB $83 FCC 'CF' ; 'CFA' FCB $C1 FDB LFA-6 CFA FDB DOCOL,TWO,SUB FDB SEMIS * * ======>> 102 << FCB $83 FCC 'NF' ; 'NFA' FCB $C1 FDB CFA-6 NFA FDB DOCOL,CLITER FCB 5 FDB SUB,ONE,MINUS,TRAV FDB SEMIS * * ======>> 103 << FCB $83 FCC 'PF' ; 'PFA' FCB $C1 FDB NFA-6 PFA FDB DOCOL,ONE,TRAV,CLITER FCB 5 FDB PLUS FDB SEMIS * * ######>> screen 40 << * ======>> 104 << FCB $84 FCC '!CS' ; '!CSP' FCB $D0 FDB PFA-6 SCSP FDB DOCOL,SPAT,CSP,STORE FDB SEMIS * * ======>> 105 << FCB $86 FCC '?ERRO' ; '?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 '?COM' ; '?COMP' FCB $D0 FDB QERR-9 QCOMP FDB DOCOL,STATE,AT,ZEQU,CLITER FCB $11 FDB QERR FDB SEMIS * * ======>> 107 << FCB $85 FCC '?EXE' ; '?EXEC' FCB $C3 FDB QCOMP-8 QEXEC FDB DOCOL,STATE,AT,CLITER FCB $12 FDB QERR FDB SEMIS * * ======>> 108 << FCB $86 FCC '?PAIR' ; '?PAIRS' FCB $D3 FDB QEXEC-8 QPAIRS FDB DOCOL,SUB,CLITER FCB $13 FDB QERR FDB SEMIS * * ======>> 109 << FCB $84 FCC '?CS' ; '?CSP' FCB $D0 FDB QPAIRS-9 QCSP FDB DOCOL,SPAT,CSP,AT,SUB,CLITER FCB $14 FDB QERR FDB SEMIS * * ======>> 110 << FCB $88 FCC '?LOADIN' ; '?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 'COMPIL' ; '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 'SMUDG' ; 'SMUDGE' FCB $C5 FDB RBRAK-4 SMUDGE FDB DOCOL,LATEST,CLITER FCB $20 FDB TOGGLE FDB SEMIS * * ======>> 115 << FCB $83 FCC 'HE' ; 'HEX' FCB $D8 FDB SMUDGE-9 HEX FDB DOCOL FDB CLITER FCB 16 FDB BASE,STORE FDB SEMIS * * ======>> 116 << FCB $87 FCC 'DECIMA' ; 'DECIMAL' FCB $CC FDB HEX-6 DECIM FDB DOCOL FDB CLITER FCB 10 note: hex "A" FDB BASE,STORE FDB SEMIS * * ######>> screen 42 << * ======>> 117 << FCB $87 FCC '(;CODE' ; '(;CODE)' FCB $A9 FDB DECIM-10 PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE FDB SEMIS * * ======>> 118 << FCB $C5 immediate FCC ';COD' ; ';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 '> 120 << FCB $85 FCC 'DOES' ; 'DOES>' FCB $BE FDB BUILDS-10 DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE FDB PSCODE DODOES LDA IP LDB IP+1 LDX RP make room on return stack LEAX -1,X LEAX -1,X STX RP STA 2,X push return address STB 3,X LDX W get addr of pointer to run-time code LEAX 1,X LEAX 1,X STX N stash it in scratch area LDX 0,X get new IP STX IP CLRA get address of parameter LDB #2 ADDB N+1 ADCA N PSHS B and push it on data stack PSHS A JMP NEXT2 * * ######>> screen 44 << * ======>> 121 << FCB $85 FCC 'COUN' ; 'COUNT' FCB $D4 FDB DOES-8 COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT FDB SEMIS * * ======>> 122 << FCB $84 FCC 'TYP' ; '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 '-TRAILIN' ; '-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 '(."' ; '(.")' 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 '.' ; '."' 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 '?STAC' ; '?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 'EXPEC' ; '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 'QUER' ; 'QUERY' FCB $D9 FDB EXPECT-9 QUERY FDB DOCOL,TIB,AT,COLUMS FDB AT,EXPECT,ZERO,IN,STORE 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 'FIL' ; '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 'ERAS' ; 'ERASE' FCB $C5 FDB FILL-7 ERASE FDB DOCOL,ZERO,FILL FDB SEMIS * * ======>> 135 << FCB $86 FCC 'BLANK' ; 'BLANKS' FCB $D3 FDB ERASE-8 BLANKS FDB DOCOL,BL,FILL FDB SEMIS * * ======>> 136 << FCB $84 FCC 'HOL' ; 'HOLD' FCB $C4 FDB BLANKS-9 HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE FDB SEMIS * * ======>> 137 << FCB $83 FCC 'PA' ; 'PAD' FCB $C4 FDB HOLD-7 PAD FDB DOCOL,HERE,CLITER FCB $44 FDB PLUS FDB SEMIS * * ######>> screen 48 << * ======>> 138 << FCB $84 FCC 'WOR' ; '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 '(NUMBER' ; '(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 'NUMBE' ; '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 '-FIN' ; '-FIND' FCB $C4 FDB NUMB-9 DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT FDB PFIND,DUP,ZEQU,ZBRAN FDB DFIND2-* FDB DROP,HERE,LATEST,PFIND DFIND2 FDB SEMIS * * ######>> screen 50 << * ======>> 142 << FCB $87 FCC '(ABORT' ; '(ABORT)' FCB $A9 FDB DFIND-8 PABORT FDB DOCOL,ABORT FDB SEMIS * * ======>> 143 << FCB $85 FCC 'ERRO' ; '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 'ID' ; '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 'CREAT' ; '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 '[COMPILE' ; '[COMPILE]' FCB $DD FDB CREATE-9 BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA FDB SEMIS * * ======>> 147 << FCB $C7 immediate FCC 'LITERA' ; '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 'DLITERA' ; '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 'INTERPRE' ; 'INTERPRET' FCB $D4 FDB DLITER-11 INTERP FDB DOCOL INTER2 FDB DFIND,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 'IMMEDIAT' ; 'IMMEDIATE' FCB $C5 FDB INTERP-12 IMMED FDB DOCOL,LATEST,CLITER FCB $40 FDB TOGGLE FDB SEMIS * * ======>> 151 << FCB $8A FCC 'VOCABULAR' ; '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 'DEFINITION' ; '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 'QUI' ; '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 ' OK' ; ' OK' QUIT3 FDB BRAN FDB QUIT2-* * FDB SEMIS ( never executed ) * * ======>> 156 << FCB $85 FCC 'ABOR' ; 'ABORT' FCB $D4 FDB QUIT-7 ABORT FDB DOCOL,SPSTOR,DECIM,QSTACK,DRZERO,CR,PDOTQ FCB 15 FCC "Forth-68oo-68o9" FDB FORTH,DEFIN FDB QUIT * FDB SEMIS never executed PAGE * * ######>> screen 56 << * bootstrap code... moves rom contents to ram : * ======>> 157 << FCB $84 FCC 'COL' ; 'COLD' FCB $C4 FDB ABORT-8 COLD FDB *+2 * CENT LDS #REND-1 top of destination on 6800 CENT LDA #PGBDP TFR A,DP LDS #REND top of destination on 6809 LDX #ERAM top of stuff to move COLD2 LEAX -1,X LDA 0,X PSHS A move TASK & FORTH to ram CMPX #RAM BNE COLD2 * * LDS #XFENCE-1 put stack at a safe place for now -- 6800 * But only matters if we're interrupted. LDS #XFENCE put stack at a safe place for now -- 6809 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 -- 6800 WENT LDS #XFENCE top of destination -- 6809 LDX #FENCIN top of stuff to move WARM2 LEAX -1,X LDA 0,X PSHS A CMPX #SINIT BNE WARM2 * * Don't get faked out. * This is just a safe place for the stack if we're interrupted. * ABORT sends us through RP! and then SP! * And SP! loads S through X, which is just fine for the 6809, too. 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 * DBG LDA #$21 STA FLAGON my version of trace JSR PEMIT * JMP RPSTOR+2 start the virtual machine running ! * * Here is the stuff that gets copied to ram : * at address $140: * RAM FDB $5000,$5000,0,0 * ======>> (152) << FCB $C5 immediate FCC 'FORT' ; 'FORTH' FCB $C8 FDB NOOP-7 RFORTH FDB DODOES,DOVOC,$81A0,TASK-7 FDB 0 FCC "(C) Forth Interest Group, 1979" FCB $84 FCC 'TAS' ; 'TASK' FCB $CB FDB FORTH-8 RTASK FDB DOCOL,SEMIS ERAM FCC "David Lion" PAGE * * ######>> screen 57 << * ======>> 158 << FCB $84 FCC 'S->' ; '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 LEAS 1,S LEAS 1,S JMP NEXT * * ======>> 160 << FCB $84 FCC '/MO' ; '/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 'MO' ; 'MOD' FCB $C4 FDB SLASH-4 MOD FDB DOCOL,SLMOD,DROP FDB SEMIS * * ======>> 163 << FCB $85 FCC '*/MO' ; '*/MOD' FCB $C4 FDB MOD-6 SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH FDB SEMIS * * ======>> 164 << FCB $82 FCC '*' ; '*/' FCB $AF FDB SSMOD-8 SSLASH FDB DOCOL,SSMOD,SWAP,DROP FDB SEMIS * * ======>> 165 << FCB $85 FCC 'M/MO' ; '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 'AB' ; 'ABS' FCB $D3 FDB MSMOD-8 ABS FDB DOCOL,DUP,ZLESS,ZBRAN FDB ABS2-* FDB MINUS ABS2 FDB SEMIS * * ======>> 167 << FCB $84 FCC 'DAB' ; '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 'US' ; 'USE' FCB $C5 FDB DABS-7 USE FDB DOCON FDB XUSE * ======>> 169 << FCB $84 FCC 'PRE' ; 'PREV' FCB $D6 FDB USE-6 PREV FDB DOCON FDB XPREV * ======>> 170 << FCB $84 FCC '+BU' ; '+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 'UPDAT' ; 'UPDATE' FCB $C5 FDB PBUF-7 UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE FDB SEMIS * * ======>> 172 << FCB $8D FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS' FCB $D3 FDB UPDATE-9 MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE FDB SEMIS * * ======>> 173 << FCB $83 FCC 'DR' ; 'DR0' FCB $B0 FDB MTBUF-16 DRZERO FDB DOCOL,ZERO,OFSET,STORE FDB SEMIS * * ======>> 174 <<== system dependant word FCB $83 FCC 'DR' ; 'DR1' FCB $B1 FDB DRZERO-6 DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE FDB SEMIS * * ######>> screen 59 << * ======>> 175 << FCB $86 FCC 'BUFFE' ; '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 'BLOC' ; '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 '(LINE' ; '(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 '.LIN' ; '.LINE' FCB $C5 FDB PLINE-9 DLINE FDB DOCOL,PLINE,DTRAIL,TYPE FDB SEMIS * * ======>> 179 << FCB $87 FCC 'MESSAG' ; '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 'err # ' ; 'err # ' FDB DOT MESS4 FDB SEMIS * * ======>> 180 << FCB $84 FCC 'LOA' ; '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 '--' ; '-->' 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 * character to output in A * Coco: PEMIT PSHS Y,U,DP CLRB TFR B,DP JSR [$A002] PULS Y,U,DP,PC * * PEMIT STB N save B * STX N+1 save X * LDB ACIAC * BITB #2 check ready bit * BEQ PEMIT+4 if not ready for more data * STA ACIAD * LDX UP * STB IOSTAT-UORIG,X * LDB N recover B & X * LDX N+1 * 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 * Returns input character in A * Coco: PKEY PSHS Y,U,DP CLRB TFR B,DP LDA #$CF a cursor LDB [$0088] (locate) save STA [$0088] PKEYBZ JSR [$A000] BEQ PKEYBZ STB [$0088] restore PULS Y,U,DP,PC * * PKEY STB N * STX N+1 * LDB ACIAC * ASRB * BCC PKEY+4 no incoming data yet * LDA ACIAD * ANDA #$7F strip parity bit * LDX UP * STB IOSTAT+1-UORIG,X * LDB 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 * Returns flag in A (non-zero if BREAK). * Coco: PQTER PSHS Y,U,DP CLRB TFR B,DP JSR [$A000] CLRB CMPA #3 break key BNE PQTERN INCB EXG A,B PQTERN PULS Y,U,DP,PC * * PQTER LDA ACIAC Test for 'break' condition * ANDA #$11 mask framing error bit and ** input buffer full * BEQ PQTER2 * LDA ACIAD clear input buffer * LDA #01 *PQTER2 RTS PAGE * * ======>> 185 << code for CR * Coco: PRTCR LDA #$D carriage return ; PCR in 6800 source BRA PEMIT Let PEMIT return * * BSR PEMIT * LDA #$A line feed * BSR PEMIT * LDA #$7F rubout * LDX UP * LDB XDELAY+1-UORIG,X * PCR2 DECB * BMI PQTER2 return if minus * PSHS B save counter * BSR PEMIT print RUBOUTs to delay..... * PULS B * BRA PCR2 repeat PAGE * * ######>> screen 66 << * ======>> 187 << FCB $85 FCC '?DIS' ; '?DISC' FCB $C3 FDB ARROW-6 QDISC FDB *+2 JMP NEXT * * ######>> screen 67 << * ======>> 189 << FCB $8B FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE' FCB $C5 FDB QDISC-8 BWRITE FDB *+2 JMP NEXT * * ######>> screen 68 << * ======>> 190 << FCB $8A FCC 'BLOCK-REA' ; '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 'L' ; 'LO' FCB $CF FDB BREAD-13 LO FDB DOCON FDB MEMEND a system dependent equate at front * * ======>> 190.2 << FCB $82 FCC 'H' ; 'HI' FCB $C9 FDB LO-5 HI FDB DOCON FDB MEMTOP ( $3FFF in this version ) * * ######>> screen 69 << * ======>> 191 << FCB $83 FCC 'R/' ; '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 ' Range ?' ; ' 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 'FORGE' ; '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,DICPT,STORE,LFA,AT,CONTXT,AT,STORE FDB SEMIS * * ######>> screen 73 << * ======>> 194 << FCB $84 FCC 'BAC' ; 'BACK' FCB $CB FDB FORGET-9 BACK FDB DOCOL,HERE,SUB,COMMA FDB SEMIS * * ======>> 195 << FCB $C5 FCC 'BEGI' ; 'BEGIN' FCB $CE FDB BACK-7 BEGIN FDB DOCOL,QCOMP,HERE,ONE FDB SEMIS * * ======>> 196 << FCB $C5 FCC 'ENDI' ; 'ENDIF' FCB $C6 FDB BEGIN-8 ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE FDB OVER,SUB,SWAP,STORE FDB SEMIS * * ======>> 197 << FCB $C4 FCC 'THE' ; 'THEN' FCB $CE FDB ENDIF-8 THEN FDB DOCOL,ENDIF FDB SEMIS * * ======>> 198 << FCB $C2 FCC 'D' ; 'DO' FCB $CF FDB THEN-7 DO FDB DOCOL,COMPIL,XDO,HERE,THREE FDB SEMIS * * ======>> 199 << FCB $C4 FCC 'LOO' ; 'LOOP' FCB $D0 FDB DO-5 LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK FDB SEMIS * * ======>> 200 << FCB $C5 FCC '+LOO' ; '+LOOP' FCB $D0 FDB LOOP-7 PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK FDB SEMIS * * ======>> 201 << FCB $C5 FCC 'UNTI' ; '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 'EN' ; 'END' FCB $C4 FDB UNTIL-8 END FDB DOCOL,UNTIL FDB SEMIS * * ======>> 203 << FCB $C5 FCC 'AGAI' ; 'AGAIN' FCB $CE FDB END-6 AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK FDB SEMIS * * ======>> 204 << FCB $C6 FCC 'REPEA' ; 'REPEAT' FCB $D4 FDB AGAIN-8 REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR FDB TWO,SUB,ENDIF FDB SEMIS * * ======>> 205 << FCB $C2 FCC 'I' ; 'IF' FCB $C6 FDB REPEAT-9 IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO FDB SEMIS * * ======>> 206 << FCB $C4 FCC 'ELS' ; '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 'WHIL' ; 'WHILE' FCB $C5 FDB ELSE-7 WHILE FDB DOCOL,IF,TWOP FDB SEMIS * * ######>> screen 75 << * ======>> 208 << FCB $86 FCC 'SPACE' ; '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 '<' ; '<#' FCB $A3 FDB SPACES-9 BDIGS FDB DOCOL,PAD,HLD,STORE FDB SEMIS * * ======>> 210 << FCB $82 FCC '#' ; '#>' FCB $BE FDB BDIGS-5 EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB FDB SEMIS * * ======>> 211 << FCB $84 FCC 'SIG' ; '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 '#' ; '#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 '.' ; '.R' FCB $D2 FDB DIGS-5 DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR FDB SEMIS * * ======>> 215 << FCB $83 FCC 'D.' ; '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 'D' ; '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 'LIS' ; 'LIST' FCB $D4 FDB QUEST-4 LIST FDB DOCOL,DECIM,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 'INDE' ; '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 'TRIA' ; '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 'VLIS' ; '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,IDDOT,SPACE,SPACE,PFA,LFA,AT FDB DUP,ZEQU,QTERM,OR,ZBRAN FDB VLIST1-* FDB DROP FDB SEMIS * * ======>> XX << FCB $84 FCC 'NOO' ; 'NOOP' FCB $D0 FDB VLIST-8 NOOP FDB NEXT a useful no-op ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program PAGE OPT L END