OPT PRT * fig-FORTH FOR 6809 * ASSEMBLY SOURCE LISTING * RELEASE 0 * JAN 2019 * WITH COMPILER SECURITY * AND VARIABLE LENGTH NAMES * Using RTS mode * * Adapted by Joel Matthew Rees * from fig-FORTH for 6800 by Dave Lion, et. al. * This free/libre/open source publication is provided * through the courtesy of: * FORTH * INTEREST * GROUP * fig * and other interested parties. * Ancient address: * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668 * URL: http://www.forth.org * Further distribution must include this notice. PAGE NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees OPT NOG,PAG * filename fig-forth-auto6809opt.asm * === FORTH-6809 {date} {time} * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to deal * in the Software without restriction, including without limitation the rights * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN * THE SOFTWARE. * * "Associated documentation" for this declaration of license * shall be interpreted to include only the comments in this file, * or, if the code is split into multiple files, * all files containing the complete source. * * This is the MIT model license, as published by the Open Source Consortium, * with associated documentation defined. * It was chosen to reflect the spirit of the original * terms of use, which used archaic legal terminology. * * Authors of the 6800 model: * === Primary: 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 * NATWID EQU 2 ; bytes per natural integer/pointer * The original version was developed on an AMI EVK 300 PROTO * system using an ACIA for the I/O. * This version is developed targeting the Tandy Color Computer. * All terminal 1/0 * is done in three subroutines: * PEMIT ( word # 182 ) * PKEY ( 183 ) * PQTERM ( 184 ) * * The FORTH words for disc related I/O follow the model * of the FORTH Interest Group, but have not yet been * tested using a real disc. * * Addresses in the 6800 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. * Those deviations will be altered in this * implementation for the 6809 -- Color Computer. * * MEMORY MAP for this 16K|32K system: * ( delineated so that systems with 4k byte write- * protected segments can write protect FORTH ) * * addr. contents pointer init by * **** ******************************* ******* ****** * * Coco has no ACIA! * ACIAC EQU $FBCE the ACIA control address and * ACIAD EQU ACIAC+1 data address for PROTO * MEMT32 EQU $7FFF ; Theoretical absolute end of all ram MEMT16 EQU $3FFF ; 16K is too tight until we no longer need disc emulation. MEMTOP EQU MEMT32 * MASSHI EQU MEMTOP * * 3FFF|7FFF HI * * substitute for disc mass memory RAMSCR EQU 8 ; addresses calculate as 2 (Too much for 16K in RAM only.) SCRSZ EQU 1024 * 3800|7800 LO MASSLO EQU MASSHI-RAMSCR*SCRSZ+1 RAMDSK EQU MASSLO MEMEND EQU MASSLO * * 3800|7800 MEMEND * "end" of "usable ram" (If disc mass memory emulation is removed, actual end.) * * 37FF|77FF * * per-user tables USERSZ EQU 256 ; (Addressable by DP, must be 256 on even boundary) USER16 EQU 1 ; We can change these for ROMPACK or 64K. USER32 EQU 2 ; maybe? USERCT EQU USER32 USERLO EQU MEMEND-USERSZ*USERCT IUP EQU USERLO IUPDP EQU IUP/256 * user tables of variables * registers & pointers for the virtual machine * scratch area for potential use in something, maybe? * * 3700|7600 <== UP * * This is a really awkward place to define the disk buffer records. * * 4 buffer sectors of VIRTUAL MEMORY NBLK EQU 4 ; # of disc buffer blocks for virtual memory * Should NBLK be SCRSZ/SECTSZ? * each block is SECTSZ+SECTRL bytes in size, * holding SECTSZ characters SECTSZ EQU 256 SECTRL EQU 2*NATWID ; Currently held sector number, etc. BUFSZ EQU (SECTSZ+SECTRL)*NBLK BUFBAS EQU USERLO-BUFSZ * *BUG* SECTRL is hard-wired into several definitions. * It will take a bit of work to ferret them out. * It is too small, and it should not be hard-wired. * SECTSZ was also hard-wired into several definitions, * will I find them all? * * 32E0|71E0 FIRST * PAGE * * Don't want one return too many to destroy the disc buffers. RPBUMP EQU 4*NATWID * * 32D8|71D8 <== RP RINIT * IRP EQU BUFBAS-RPBUMP * RETURN STACK RSTK16 EQU $50*NATWID ; 80 max levels nesting calls RSTK32 EQU $90*NATWID ; 144 max RSTKSZ EQU RSTK32 * * 3248|70B8 * SFTBND EQU IRP-RSTKSZ ; (false boundary between TIB and return stack) * INPUT LINE BUFFER * holds up to TIBSZ characters * and is scanned upward by IN * starting at TIB TIBSZ EQU 256 ITIB EQU SFTBND-TIBSZ * * 3148|6FB8 <== IN TIB * * Don't want terminal input and parameter underflow collisions SPBUMP EQU 4*NATWID * ISP EQU ITIB-SPBUMP * * 3140|6FB0 <== SP SP0,SINIT * DATA STACK * | grows downward from 3140|6FB0 * v * - - * ^ * | * I DICTIONARY grows upward * * >>>>>>--------Two words to start RAMmable dictionary--------<<<<<< * * (2B00) * ???? end of ram-dictionary. <== DICTPT DPINIT * "TASK" * * ???? "FORTH" ( a word ) <=, <== CONTEXT * `==== CURRENT * start of ram-dictionary. * * >>>>>> memory from here up must be in RAM area <<<<<< * * ???? * 6k of romable "FORTH" <== IP ABORT * <== W * the VIRTUAL FORTH MACHINE * * 1208 initialization tables * 1204 <<< WARM START ENTRY >>> * 1200 <<< COLD START ENTRY >>> * 1200 lowest address used by FORTH * CODEBG EQU $1200 * CODEBG EQU $3000 * * >>>>>> memory from here down left alone <<<<<< * >>>>>> so we can safely call ROM routines <<<<<< * * 0000 PAGE *** * * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS : * * IP (hardware Y) points to the current instruction ( pre-increment mode ) * RP (hardware S) points to last return address pushedin return stack * SP (hardware U) points to last byte pushed in data stack * * Y must be IP when NEXT is entered (if using the inner loop). * * When A and B hold one 16 bit FORTH data word, * A contains the high byte, B, the low byte. * * UP (hardware DP) is the base of per-task ("user") variables. * (Be careful of the stray semantics of "user".) * * W (hardware X) is the pointer to the "code field" address of native CPU * machine code to be executed for the definition of the dictionary word * to be executed/currently executing. * The following natural integer (word) begins any "parameter section" * (body) -- similar to a "this" pointer, but not the same. * It may be native CPU machine code, or it may be a global variable, * or it may be a list of Forth definition words (addresses). * * ====== * This implementation uses the native subroutine architecture * rather than a postponed-push call that the 6800 model VM uses * to save code and time in leaf routines. * * This should allow directly calling many of the Forth words * from assembly language code. * (Be aware of the need for a valid W in some cases.) * It won't allow mixing assembly language directly into Forth word lists. * ====== * * boolean flags: * 0 is false, anything else is true. * Most places in this model that set a boolean flag set true as 1. * This is in contrast to many models that set a boolean flag as -1. * *** PAGE * This system is shown with one user (task), * but additional users (tasks) may be added * by allocating additional user tables: * ORG IUP UBASE RMB USERSZ UBASEX RMB USERSZ data table for extra users * * Some of this stuff gets initialized during * COLD start and WARM start: * [ names correspond to FORTH words of similar (no X) name ] * ORG IUP UORIG EQU * * A few useful VM variables * Will be removed when they are no longer needed. * All are replaced by 6809 registers. 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 * This is not exactly accurate. Points to the definiton body, * which is native CPU machine code when it is native CPU machine 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 ) * *UORIG RMB 6 3 reserved variables 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 XDICTP 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 * * * * These need to be moved to where they will be * initialized globals in variable space, not in the USER table. * Or, more accurately, need to be turned into monitored or semaphored resources. XUSE RMB 2 XPREV RMB 2 RMB 4 ( spares ) PAGE * The FORTH program ( address $1200 to about $27FF ) will be written * so that it can be in a ROM, or write-protected if desired, * but right now we're just getting it running. ORG CODEBG * ######>> screen 3 << * *************************** ** C O L D E N T R Y ** *************************** ORIG NOP * JMP CENT LBSR CENT *************************** ** W A R M E N T R Y ** *************************** NOP * JMP WENT warm-start code, keeps current dictionary intact LBSR WENT warm-start code, keeps current dictionary intact SETDP IUPDP * ******* startup parmeters ************************** * FDB $6809,0000 cpu & revision FDB 0 topmost word in FORTH vocabulary * BACKSP FDB $7F backspace character for editing BACKSP FDB $08 backspace character for editing UPINIT FDB UORIG initial user area * UPINIT FDB UORIG initial user area SINIT FDB ISP ; initial top of data stack * SINIT FDB ORIG-$D0 initial top of data stack RINIT FDB IRP ; initial top of return stack * RINIT FDB ORIG-2 initial top of return stack FDB ITIB ; terminal input buffer * FDB ORIG-$D0 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 DICTPT BUFINT FDB BUFBAS Start of the disk buffers area VOCINT FDB FORTH+4*NATWID COLINT FDB TIBSZ initial terminal carriage width DELINT FDB 4 initial carriage return delay **************************************************** * PAGE * * ######>> screen 13 << * These were of questionable use anyway, * kept here now to satisfy the assembler and show hints. * They're too much trouble to use with native subroutine call anyway. * PULABX PULS A ; 24 cycles until 'NEXT' * PULS B ; * PULABX PULU A,B ; ?? cycles until 'NEXT' * STABX STA 0,X 16 cycles until 'NEXT' * STB 1,X * STABX STD 0,X ; ?? cycles until 'NEXT' BRA NEXT * GETX LDA 0,X 18 cycles until 'NEXT' * LDB 1,X * GETX LDD 0,X ?? cycles until 'NEXT' * PUSHBA PSHS B ; 8 cycles until 'NEXT' * PSHS A ; * PUSHBA PSHU A,B ; ?? cycles until 'NEXT' * * "NEXT" takes ?? cycles if TRACE is removed, * * and ?? cycles if trace is present and NOT tracing. * * = = = = = = = t h e v i r t u a l m a c h i n e = = = = = * = * NEXT itself might just completely go away. * About the only reason to keep it is to allowing executing a list * which allows a cheap TRACE routine. * * NEXT is a loop which implements the Forth VM. * It basically cycles through calling the code out of code lists, * one at a time. * Using a native CPU return for this uses a few extra cycles per call, * compared to simply jumping to each definition and jumping back * to the known beginning of the loop, * but the loop itself is really only there for convenience. * * This implementation uses the native subroutine call, * to break the wall between Forth code and non-Forth code. * * NEXT LDX IP * LEAX 1,X ; pre-increment mode * LEAX 1,X ; * STX IP NEXT ; IP is Y, push before using, pull before you come back here. * * NEXT2 LDX 0,X get W which points to CFA of word to be done NEXT2 LDX ,Y++ get W which points to CFA of word to be done * BSR DBGNAM * BSR DBGREG * But NEXT2 is too much trouble to use with subroutine threading anyway. * NEXT3 STX W NEXT3 ; W is X until you use X for something else. (TOS points back here.) * But NEXT3 is too much trouble to use with subroutine threading anyway. * 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: = * = * JMP 0,X JSR [,X] ; Saving the postinc cycles, * ; but X must be bumped NATWID to the parameters. * NOP * JMP TRACE ( an alternate for the above ) * BSR DBGREG ( an alternate for the above ) * In other words, with the call and the NOP, * there is room to patch the call with a JMP to your TRACE * routine, which you have to provide. BRA NEXT * DBGNAM PSHS CC,D,X,Y TST > 1 << * ( --- n ) * Pushes the following natural width integer from the instruction stream * as a literal, or immediate value. * * FDB {OP} * FDB {OP} * FDB LIT * FDB LITERAL-TO-BE-PUSHED * FDB {OP} * * In native processor code, there should be a better way, use that instead. * More specifically, DO NOT CALL THIS from assembly language code. * (Note that there is no compile-only flag in the fig model.) * * See (FIND), or PFIND , for layout of the header format. * FCB $83 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set. FDB 0 ; link of zero to terminate dictionary scan LIT FDB *+NATWID ; Note also that LIT is meaningless in native code. LDD ,Y++ PSHU A,B RTS * LDX IP * LEAX 1,X ; * LEAX 1,X ; * STX IP * LDA 0,X * LDB 1,X * JMP PUSHBA * * ######>> screen 14 << * ======>> 2 << * ( --- n ) * Pushes the following byte from the instruction stream * as a literal, or immediate value. * * FDB {OP} * FDB {OP} * FDB LIT8 * FCB LITERAL-TO-BE-PUSHED * FDB {OP} * * If this is kept, it should have a header for TRACE to read. * If the data bus is wider than a byte, you don't want to do this. * Byte shaving like this is often counter-productive anyway. * Changing the name to LIT8, hoping that will be more understandable. * Also, see comments for LIT. * (Note that there is no compile-only flag in the fig model.) FCB $84 FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL FCB $B8 FDB LIT-6 LIT8 FDB *+NATWID (this was an invisible word, with no header) LDB ,Y+ ; This also is meaningless in native code. CLRA PSHU A,B RTS * LDX IP * LEAX 1,X ; * STX IP * CLRA ; * LDB 1,X * JMP PUSHBA * * ( n off --- n ) * off is offset in video buffer area. FCB $87 FCC 'SHOWTO' ; 'SHOWTOS' FCB $D3 ; 'S' FDB LIT8-7 SHOTOS FDB *+NATWID LDX #$400 LDD ,U++ LEAX D,X LDD ,U LBSR OUThxD RTS * FCB $85 FCC 'TROF' ; 'TROFF' FCB $C6 ; 'F'|$80 FDB SHOTOS-10 TROFF FDB *+NATWID CLR > 3 << * ( adr --- ) * Jump to address on stack. Used by the "outer" interpreter to * interactively invoke routines. * Might be useful to have EXECUTE test the pointer, as done in BIF-6809. FCB $87 FCC 'EXECUT' ; 'EXECUTE' FCB $C5 FDB TRON-7 EXEC FDB *+NATWID PULU X ; Gotta have W anyway, just in case. JMP [,X] ; Tail return. * TFR S,X ; TSX : * LDX 0,X get code field address (CFA) * LEAS 1,S ; pop stack * LEAS 1,S ; * JMP NEXT3 * * ######>> screen 15 << * ======>> 4 << * ( --- ) C * Add the following word from the instruction stream to the * instruction pointer (Y++). Causes a program branch in Forth code stream. * * In native processor code, there should be a better way, use that instead. * More specifically, DO NOT CALL THIS from assembly language code. * This is only for Forth code stream. * Also, see comments for LIT. FCB $86 FCC 'BRANC' ; 'BRANCH' FCB $C8 FDB EXEC-10 BRAN FDB ZBYES ; Go steal code in ZBRANCH * Moving code around to optimize the branch taking case in 0BRANCH. ZBNO LEAY NATWID,Y ; No branch. RTS * ======>> 5 << * ( f --- ) C * BRANCH if flag is zero. * * In native processor code, there should be a better way, use that instead. * More specifically, DO NOT CALL THIS from assembly language code. * This is only for Forth code stream. * Also, see comments for LIT. FCB $87 FCC '0BRANC' ; '0BRANCH' FCB $C8 FDB BRAN-9 ZBRAN FDB *+NATWID LDD ,U++ BNE ZBNO ZBYES LDD ,Y++ LEAY D,Y ; IP is postinc RTS * PULS A ; * PULS B ; * PSHS B ; ** emulating ABA: * ADDA ,S+ ; * 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 << * ( --- ) ( limit index *** limit index+1) C * ( limit index *** ) * Counting loop primitive. The counter and limit are the top two * words on the return stack. If the updated index/counter does * not exceed the limit, a branch occurs. If it does, the branch * does not occur, and the index and limit are dropped from the * return stack. * * In native processor code, there should be a better way, use that instead. * More specifically, DO NOT CALL THIS from assembly language code. * This is only for Forth code stream. * Also, see comments for LIT. FCB $86 FCC '(LOOP' ; '(LOOP)' FCB $A9 FDB ZBRAN-10 XLOOP FDB *+NATWID LDD #1 ; Borrowing from BIF-6809. XLOOPA ADDD NATWID,S ; Dodge the return address. STD NATWID,S SUBD 2*NATWID,S BMI ZBYES ; pseudo-signed-unsigned XLOOPN LEAY NATWID,Y LDX ,S ; synthetic return LEAS 3*NATWID,S ; Clean up the index and limit. JMP ,X * CLRA ; * LDB #1 get set to increment counter by 1 (Clears N.) * BRA XPLOP2 go steal other guy's code! * * ======>> 7 << * ( n --- ) ( limit index *** limit index+n ) C * ( limit index *** ) * Loop with a variable increment. Terminates when the index * crosses the boundary from one below the limit to the limit. A * positive n will cause termination if the result index equals the * limit. A negative n must cause the index to become less than * the limit to cause loop termination. * * Note that the end conditions are not symmetric around zero. * * In native processor code, there should be a better way, use that instead. * More specifically, DO NOT CALL THIS from assembly language code. * This is only for Forth code stream. * Also, see comments for LIT. FCB $87 FCC '(+LOOP' ; '(+LOOP)' FCB $A9 FDB XLOOP-9 XPLOOP FDB *+NATWID ; Borrowing from BIF-6809. LDD ,U++ ; inc val BPL XLOOPA ; Steal plain loop code for forward count. ADDD NATWID,S ; Dodge the return address STD NATWID,S SUBD 2*NATWID,S BPL ZBYES ; pseudo-signed-unsigned BRA XLOOPN ; This path might be less time-sensitive. * * This should work, but I want to use tested code. * PULU A,B ; Get the increment. * XPLOP2 PULS X ; Pre-clear the return stack. * PSHU A ; Save the direction in high bit. * ADDD ,S ; Count. * STD ,S ; Update. * SUBD NATWID,S ; Check limit. ** ** I think this should work: * EORA ,U+ ; dir < 0 and (count - limit) >= 0 * BPL XPLONO ; or dir >= 0 and (count - limit) < 0 * LDD ,Y++ * LEAY D,Y ; IP is postinc * JMP ,X * XPLONO LEAS 2*NATWID,S * JMP ,X ; synthetic return * * This definitely should work: * TST ,U+ ; Get the sign * BPL XPLOF ; * CMPD NATWID,S * BMI XPLONO * XPLOYE LDD ,Y++ * LEAY D,Y ; IP is postinc * JMP ,X * XPLOF CMPD NATWID,S * BMI XPLOYE * XPLONO LEAS 2*NATWID,S * JMP ,X ; synthetic return * * 6800 Probably could have used the exclusive-or method, too.: * PULS A ; get increment * PULS B ; * XPLOP2 TSTA ; * BPL XPLOF forward looping * BSR XPLOPS * ORCC #$01 ; SEC : * 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 << * ( limit index --- ) ( *** limit index ) * Move the loop parameters to the return stack. Synonym for D>R. FCB $84 FCC '(DO' ; '(DO)' FCB $A9 FDB XPLOOP-10 XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO LDX ,S ; Save the return address. PULU A,B PSHS A,B PULU A,B ; Maintain order. STD NATWID,S JMP ,X ; synthetic return * * 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 << * ( --- index ) ( limit index *** limit index ) * Copy the loop index from the return stack. Synonym for R. FCB $81 I FCB $C9 FDB XDO-7 I FDB *+NATWID LDD NATWID,S ; Dodge return address. PSHU A,B RTS * LDX RP * LEAX 1,X ; * LEAX 1,X ; * JMP GETX * * ######>> screen 18 << * ======>> 10 << * ( c base --- false ) * ( c base --- n true ) * Translate C in base, yielding a translation valid flag. If the * translation is not valid in the specified base, only the false * flag is returned. FCB $85 FCC 'DIGI' ; 'DIGIT' FCB $D4 FDB I-4 DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z LDD NATWID,U ; Check the whole thing. SUBD #$30 ; ascii zero BMI DIGIT2 IF LESS THAN '0', ILLEGAL CMPD #$A BMI DIGIT0 IF '9' OR LESS CMPD #$11 BMI DIGIT2 if less than 'A' CMPD #$2B BPL DIGIT2 if greater than 'Z' SUBD #7 translate 'A' thru 'F' DIGIT0 CMPD ,U ; Check the base. BPL DIGIT2 if not less than the base STD NATWID,U ; Store converted digit. (High byte known zero.) LDD #1 ; set valid flag DIGIT1 STD ,U ; store the flag RTS NEXT DIGIT2 LDD #0 ; set not valid flag LEAU NATWID,U ; pop base BRA DIGIT1 * TFR S,X ; TSX : * 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 ; TSX : * STB 0,X make sure both bytes are 00 * BRA DIGIT1 * * ######>> screen 19 << * * The word definition format in the dictionary: * * (Symbol names are bracketed by bytes with the high bit set, rather than linked.) * * NFA (name field address): * char-count + $80 Length of symbol name, flagged with high bit set. * char 1 Characters of symbol name. * char 2 * ... * char n + $80 symbol termination flag (char set < 128 code points) * LFA (link field address): * link high byte \___pointer to previous word in list * link low byte / -- Combined allocation/dictionary list. -- * CFA (code field address): * CFA high byte \___pointer to native CPU machine code * CFA low byte / -- Consider this the characteristic code. -- * PFA (parameter field address): * parameter fields -- Machine code for low-level native machine CPU code, * " instruction list for high-level Forth code, * " constant data for constants, pointers to per task variables, * " space for variables, for global variables, etc. * * In the case of native CPU machine code, the address at CFA will be PFA. * Definition attributes: FIMMED EQU $40 ; Immediate word flag. FSMUDG EQU $20 ; Smudged => definition not ready. CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte. * Note that the SMUDGE bit is not masked out. * * But we really want more (Thinking for a new model, need one more byte): * FCOMPI EQU $10 ; Compile-time-only. * FASSEM EQU $08 ; Assembly-language code only. * F4THLV EQU $04 ; Must not be called from assembly language code. * These would require some significant adjustments to the model. * We also want to put the low-level VM stuff in its own vocabulary. * * ======>> 11 << * (FIND) ( name vocptr --- locptr length true ) * ( name vocptr --- false ) * Search vocabulary for a symbol called name. * name is a pointer to a high-bit bracket string with length head. * vocptr is a pointer to the NFA of the tail-end (LATEST) definition * in the vocabulary to be searched. * Hidden (SMUDGEd) definitions are lexically not equal to their name strings. FCB $86 FCC '(FIND' ; '(FIND)' FCB $A9 FDB DIGIT-8 PFIND FDB *+NATWID PSHS Y ; Have to track two pointers. * Use the stack and registers instead of temp area N. PA0 EQU NATWID ; pointer to the length byte of name being searched against PD EQU 0 ; pointer to NFA of dict word being checked * * INC > screen 20 << * ======>> 12 << * ( buffer ch --- buffer symboloffset delimiteroffset scancount ) * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset ) * ( buffer ch --- buffer nuloffset onepast scancount ) * Scan buffer for a symbol delimited by ch or ASCII NUL, * return the length of the buffer region scanned, * the offset to the trailing delimiter, * and the offset of the first character of the symbol. * Leave the buffer on the stack. * Scancount is also offset to first character not yet looked at. * If no symbol in buffer, scancount and symboloffset point to NUL * and delimiteroffset points one beyond for some reason. * On trailing NUL, delimiteroffset == scancount. * (Buffer is the address of the buffer array to scan.) * (This is a bit too tricky, really.) FCB $87 FCC 'ENCLOS' ; 'ENCLOSE' FCB $C5 FDB PFIND-9 ENCLOS FDB *+NATWID LDA 1,U ; Delimiter character to match against in A. LDX NATWID,U ; Buffer to scan in. CLRB ; Initialize offset. (Buffer < 256 wide!) * Scan to a non-delimiter or a NUL ENCDEL TST B,X ; NUL ? BEQ ENCNUL CMPA B,X ; Delimiter? BNE ENC1ST INCB ; count character BRA ENCDEL * Found first character. Save the offset. ENC1ST STB 1,U ; Found first non-delimiter character -- CLR ,U ; store the count, zero high byte. * Scan to a delimiter or a NUL ENCSYM TST B,X ; NUL ? BEQ ENC0TR CMPA B,X ; delimiter? BEQ ENCEND INCB BRA ENCSYM * Found end of symbol. Push offset to delimiter found. ENCEND CLRA ; high byte -- buffer < 255 wide! PSHU A,B ; Offset to seen delimiter. * Advance and push address of next character to check. ADDD #1 ; In case offset was 255. PSHU A,B RTS * Found NUL before non-delimiter, therefore there is no word ENCNUL CLRA ; high byte -- buffer < 255 wide! STD ,U ; offset to NUL. ADDD #1 ; Point after NUL to allow (FIND) to match it. PSHU A,B ; SUBD #1 ; Next is not passed NUL. PSHU A,B ; Stealing code will save only one byte. RTS * Found NUL following the word instead of delimiter. ENC0TR * INC > screen 21 << * The next 4 words call system dependant I/O routines * which are listed after word "-->" ( lable: "arrow" ) * in the dictionary. * * ======>> 13 << * ( c --- ) * Write c to the output device (screen or printer). * ROM Uses the ECB device number at address $6F, * -2 is printer, 0 is screen. FCB $84 FCC 'EMI' ; 'EMIT' FCB $D4 FDB ENCLOS-10 EMIT FDB *+NATWID PULU D LBSR PEMIT ; PEMIT expects the character in D. INC > 14 << * ( --- c ) * ( --- BREAK ) * Wait for a key from the keyboard. * If the key is BREAK, set the high byte (result $FF03). FCB $83 FCC 'KE' ; 'KEY' FCB $D9 FDB EMIT-7 KEY FDB *+NATWID LBSR PKEY ; PKEY leaves the key/break code in D. PSHU D RTS * JSR PKEY * PSHS A ; * CLRA ; * PSHS A ; * JMP NEXT * * ======>> 15 << * ( --- f ) * Scan keyboard, but do not wait. * Return 0 if no key, * BREAK ($ff03) if BREAK is pressed, * or key currently pressed. FCB $89 FCC '?TERMINA' ; '?TERMINAL' FCB $CC FDB KEY-6 QTERM FDB *+NATWID LBSR PQTER ; PQTER leaves the flag/key in D. PSHU D RTS * JSR PQTER * CLRB ; * JMP PUSHBA stack the flag * * ======>> 16 << * ( --- ) * EMIT a Carriage Return (ASCII CR). FCB $82 FCC 'C' ; 'CR' FCB $D2 FDB QTERM-12 CR FDB *+NATWID LBRA PCR ; Nothing really to do here. * JSR PCR * JMP NEXT * * ######>> screen 22 << * ======>> 17 << * ( source target count --- ) * Copy/move count bytes from source to target. * Moves ascending addresses, * so that overlapping only works if the source is above the destination. FCB $85 FCC 'CMOV' ; 'CMOVE' : source, destination, count FCB $C5 FDB CR-5 CMOVE FDB *+NATWID * Another way ; takes ( 42+17*count+9*(count/256) cycles ) LDD #0 ; #3~3 SUBD ,U++ ; #2~9 ; invert the count PSHS A,Y ; #2~8 PULU X,Y ; #2~9 BEQ CMOVEX ; #2~3 CMOVEL LDA ,Y+ ; #2~6 STA ,X+ ; #2~6 INCB ; #1~2 BNE CMOVEL ; #2~3 INC ,S ; #2~6 BNE CMOVEL ; #2~3 CMOVEX PULS A,Y,PC ; #2~10 * PSHS Y ; * INC > screen 23 << * ======>> 18 << * ( u1 u2 --- ud ) * Multiplies the top two unsigned integers, * yielding a double integer product. FCB $82 FCC 'U' ; 'U*' FCB $AA FDB CMOVE-8 USTAR FDB *+NATWID LEAU -2*NATWID,U LDA 2*NATWID+1,U ; least LDB 3*NATWID+1,U MUL STD NATWID,U LDA 2*NATWID,U ; most LDB 3*NATWID,U MUL STD ,U LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi) MUL ADDD 1,U BCC USTAR3 INC ,U USTAR3 STD 1,U LDA 2*NATWID,U ; second inner (u2 hi) LDB 3*NATWID,U ; (u1 lo) MUL ADDD 1,U BCC USTAR4 INC ,U USTAR4 STD 1,U PULU D,X STD ,U STX NATWID,U RTS * * from 6800 model: * 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 ; TSX : * 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 << * ( ud u --- uremainder uquotient ) * Divides the top unsigned integer * into the second and third words on the stack * as a single unsigned double integer, * leaving the remainder and quotient (quotient on top) * as unsigned integers. * * The smaller the divisor, the more likely dropping the high word * of the quotient loses significant bits. See M/MOD . * FCB $82 FCC 'U' ; 'U/' FCB $AF FDB USTAR-5 USLASH FDB *+NATWID LDA #17 ; bit ct PSHS A LDD NATWID,U ; dividend USLDIV CMPD ,U ; divisor BHS USLSUB ANDCC #~1 ; carry clear BRA USLBIT USLSUB SUBD ,U ORCC #1 ; quotient, (carry set) USLBIT ROL 2*NATWID+1,U ; save it ROL 2*NATWID,U DEC ,S ; more bits? BEQ USLR ROLB ; remainder ROLA BCC USLDIV BRA USLSUB USLR LEAU NATWID,U LDX NATWID,U STD NATWID,U STX ,U PULS A,PC ; Avoiding a LEAS 1,S by discarding A. * * from 6800 model: * LDA #17 * PSHS A ; * TFR S,X ; TSX : * LDA 3,X * LDB 4,X * USL1 CMPA 1,X * BHI USL3 * BCS USL2 * CMPB 2,X * BCC USL3 * USL2 ANDCC #~$01 ; CLC : * BRA USL4 * USL3 SUBB 2,X * SBCA 1,X * ORCC #$01 ; SEC : * 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 << * ( n1 n2 --- n ) * Bitwise and the top two integers. FCB $83 FCC 'AN' ; 'AND' FCB $C4 FDB USLASH-5 AND FDB *+NATWID PULU A,B ANDB 1,U ANDA ,U STD ,U RTS * PULS A ; * PULS B ; * TFR S,X ; TSX : * ANDB 1,X * ANDA 0,X * JMP STABX * * ======>> 21 << * ( n1 n2 --- n ) * Bitwise or the top two integers. FCB $82 FCC 'O' ; 'OR' FCB $D2 FDB AND-6 OR FDB *+NATWID PULU A,B ORB 1,U ORA ,U STD ,U RTS * PULS A ; * PULS B ; * TFR S,X ; TSX : * ORB 1,X * ORA 0,X * JMP STABX * * ======>> 22 << * ( n1 n2 --- n ) * Bitwise exclusive or the top two integers. FCB $83 FCC 'XO' ; 'XOR' FCB $D2 FDB OR-5 XOR FDB *+NATWID PULU A,B EORB 1,U EORA ,U STD ,U RTS * PULS A ; * PULS B ; * TFR S,X ; TSX : * EORB 1,X * EORA 0,X * JMP STABX * * ######>> screen 26 << * ======>> 23 << * ( --- adr ) * Fetch the parameter stack pointer (before it is pushed). * This points at whatever was on the top of stack before. FCB $83 FCC 'SP' ; 'SP@' FCB $C0 FDB XOR-6 SPAT FDB *+NATWID TFR U,X PSHU X RTS * TFR S,X ; TSX : * STX N scratch area * LDX #N * JMP GETX * * ======>> 24 << * ( whatever --- nothing ) * Initialize the parameter stack pointer from the USER variable S0. * Effectively clears the stack. FCB $83 FCC 'SP' ; 'SP!' FCB $A1 FDB SPAT-6 SPSTOR FDB *+NATWID LDU > 25 << * ( whatever *** nothing ) * Initialize the return stack pointer from the initialization table * instead of the user variable R0, for some reason. * Quite possibly, this should be from R0. * Effectively aborts all in process definitions, except the active one. * An emergency measure, to be sure. * The routine that calls this must never execute a return. * So this should never be executed from the terminal, I guess. * This is another that should be compile-time only, and in a separate vocabulary. FCB $83 FCC 'RP' ; 'RP!' FCB $A1 FDB SPSTOR-6 RPSTOR FDB *+NATWID PULS X ; But this guy has to return to his caller. LDS RINIT JMP ,X * LDX RINIT initialize from rom constant * STX RP * JMP NEXT * * ======>> 26 << * ( ip *** ) * Pop IP from return stack (return from high-level definition). * Can be used in a screen to force interpretion to terminate. * Must not be executed when temporaries are saved on top of the return stack. FCB $82 FCC ';' ; ';S' FCB $D3 FDB RPSTOR-6 SEMIS FDB *+NATWID PULS D,Y ; return address in D, and saved IP in Y. TFR D,PC ; Synthetic return. * * Form 6800 model: * 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 << * ( limit index *** index index ) * Force the terminating condition for the innermost loop by * copying its index to its limit. * Termination is postponed until the next * LOOP or +LOOP instruction is executed. * The index remains available for use until * the LOOP or +LOOP instruction is encountered. * Note that the assumption is that the current count is the correct count * to end at, rather than pushing the count to the final count. FCB $85 FCC 'LEAV' ; 'LEAVE' FCB $C5 FDB SEMIS-5 LEAVE FDB *+NATWID LDD NATWID,S ; Dodge the return address. STD 2*NATWID,S RTS * LDX RP * LDA 2,X * LDB 3,X * STA 4,X * STB 5,X * JMP NEXT * * ======>> 28 << * ( n --- ) * ( *** n ) * Move top of parameter stack to top of return stack. FCB $82 FCC '>' ; '>R' FCB $D2 FDB LEAVE-8 TOR FDB *+NATWID PULU A,B LDX ,S STD ,S ; Put it where the return address was. JMP ,X * LDX RP * LEAX -1,X ; * LEAX -1,X ; * STX RP * PULS A ; * PULS B ; * STA 2,X * STB 3,X * JMP NEXT * * ======>> 29 << * ( --- n ) * ( n *** ) * Move top of return stack to top of parameter stack. FCB $82 FCC 'R' ; 'R>' FCB $BE FDB TOR-5 FROMR FDB *+NATWID PULS D,X PSHU X TFR D,PC * LDX RP * LDA 2,X * LDB 3,X * LEAX 1,X ; * LEAX 1,X ; * STX RP * JMP PUSHBA * * ======>> 30 << * ( --- n ) * ( n *** n ) * Copy the top of return stack to top of parameter stack. * A synonym for I. FCB $81 R FCB $D2 FDB FROMR-5 R FDB I+NATWID * LDX RP * LEAX 1,X ; * LEAX 1,X ; * JMP GETX * * ######>> screen 28 << * ======>> 31 << * ( n --- ~n ) * Logically invert top of stack; * or flag true if top is zero, otherwise false. FCB $83 FCC 'NO' ; 'NOT' FCB $D4 FDB R-4 LNOT FDB *+NATWID COM 1,U COM ,U RTS * ( n --- n=0 ) * Logically invert top of stack; * or flag true if top is zero, otherwise false. FCB $82 FCC '0' ; '0=' FCB $BD FDB LNOT-6 ZEQU FDB *+NATWID LDD #0 LDX ,U BNE ZEQUF INCB ; 1 is true ZEQUF STD ,U RTS * TFR S,X ; TSX : * CLRA ; * CLRB ; * LDX 0,X * BNE ZEQU2 * INCB ; *ZEQU2 TFR S,X ; TSX : * JMP STABX * * ======>> 32 << * ( n --- n<0 ) * Flag true if top is negative (MSbit set), otherwise false. FCB $82 FCC '0' ; '0<' FCB $BC FDB ZEQU-5 ZLESS FDB *+NATWID LDD #0 TST ,U BPL ZLESSF INCB ZLESSF STD ,U RTS * TFR S,X ; TSX : * 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 << * ( n1 n2 --- n1+n2 ) * Add top two words. FCB $81 '+' FCB $AB FDB ZLESS-5 PLUS FDB *+NATWID PULU A,B ; #2~7 ADDD ,U ; #2~6 STD ,U ; #2~5 RTS ; #1~5 =#7~23 * PULS A ; * PULS B ; * TFR S,X ; TSX : * ADDB 1,X * ADCA 0,X * JMP STABX * * ======>> 34 << * ( d1 d2 --- d1+d2 ) * Add top two double integers. FCB $82 FCC 'D' ; 'D+' FCB $AB FDB PLUS-4 DPLUS FDB *+NATWID LDD 3*NATWID,U ADDD NATWID,U STD 3*NATWID,U LDD 2*NATWID,U ADCB 1,U ADCA ,U LEAU 2*NATWID,U STD ,U RTS * TFR S,X ; TSX : * ANDCC #~$01 ; CLC : * 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 << * ( n --- -n ) * Negate (two's complement) top of stack. FCB $85 FCC 'MINU' ; 'MINUS' FCB $D3 FDB DPLUS-5 MINUS FDB *+NATWID LDD #0 ; #3~3 SUBD ,U ; #2~5 STD ,U ; #2~5 RTS ; #1~5 = #8~18 * * from 6800 model code: * TFR S,X ; TSX : * NEG 1,X * BCC MINUS2 * NEG 0,X * BRA MINUS3 * MINUS2 COM 0,X * MINUS3 JMP NEXT * * ======>> 36 << * ( d --- -d ) * Negate (two's complement) top two words on stack as a double integer. FCB $86 FCC 'DMINU' ; 'DMINUS' FCB $D3 FDB MINUS-8 DMINUS FDB *+NATWID LDD #0 ; #3~3 SUBD NATWID,U ; #2~7 STD NATWID,U ; #2~7 LDD #0 ; #3~3 SBCB 1,U ; #2~5 SBCA ,U ; #2~4 STD ,U ; #2~5 RTS ; #1~5 = #17~39 * TFR S,X ; 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 << * ( n1 n2 --- n1 n2 n1 ) * Push a copy of the second word on stack. FCB $84 FCC 'OVE' ; 'OVER' FCB $D2 FDB DMINUS-9 OVER FDB *+NATWID LDD NATWID,U PSHU D RTS * TFR S,X ; TSX : * LDA 2,X * LDB 3,X * JMP PUSHBA * * ======>> 38 << * ( n --- ) * Discard the top word on stack. FCB $84 FCC 'DRO' ; 'DROP' FCB $D0 FDB OVER-7 DROP FDB *+NATWID LEAU NATWID,U RTS * LEAS 1,S ; * LEAS 1,S ; * JMP NEXT * * ======>> 39 << * ( n1 n2 --- n2 n1 ) * Swap the top two words on stack. FCB $84 FCC 'SWA' ; 'SWAP' FCB $D0 FDB DROP-7 SWAP FDB *+NATWID PULU D,X PSHU D PSHU X RTS * PULS A ; * PULS B ; * TFR S,X ; TSX : * LDX 0,X * LEAS 1,S ; * LEAS 1,S ; * PSHS B ; * PSHS A ; * STX N * LDX #N * JMP GETX * * ======>> 40 << * ( n1 --- n1 n1 ) * Push a copy of the top word on stack. FCB $83 FCC 'DU' ; 'DUP' FCB $D0 FDB SWAP-7 DUP FDB *+NATWID LDD ,U PSHU D RTS * PULS A ; * PULS B ; * PSHS B ; * PSHS A ; * JMP PUSHBA * * ######>> screen 31 << * ======>> 41 << * ( n adr --- ) * Add the second word on stack to the word at the adr on top of stack. FCB $82 FCC '+' ; '+!' FCB $A1 FDB DUP-6 PSTORE FDB *+NATWID PULU X LDD ,X ADDD ,U++ STD ,X RTS * TFR S,X ; TSX : * 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 << * ( adr b --- ) * Exclusive or byte at adr with low byte of top word. FCB $86 FCC 'TOGGL' ; 'TOGGLE' FCB $C5 FDB PSTORE-5 TOGGLE FDB *+NATWID PULU D,X EORB ,X STB ,X RTS * Using the model code would be less likely to introduce bugs, * but that would sort-of defeat my purposes here. * Anyway, I can borrow from theoretically known good bif-6809 code * and it's fewer bytes and much faster code this way. * TOGGLE * FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE * FDB SEMIS * * ######>> screen 32 << * ======>> 43 << * ( adr --- n ) * Replace address on stack with the word at the address. FCB $81 @ FCB $C0 FDB TOGGLE-9 AT FDB *+NATWID LDD [,U] STD ,U RTS * TFR S,X ; TSX : * LDX 0,X get address * LEAS 1,S ; * LEAS 1,S ; * JMP GETX * * ======>> 44 << * ( adr --- b ) * Replace address on top of stack with the byte at the address. * High byte of result is clear. FCB $82 FCC 'C' ; 'C@' FCB $C0 FDB AT-4 CAT FDB *+NATWID LDB [,U] CLRA STD ,U RTS * TFR S,X ; TSX : * LDX 0,X * CLRA ; * LDB 0,X * LEAS 1,S ; * LEAS 1,S ; * JMP PUSHBA * * ======>> 45 << * ( n adr --- ) * Store second word on stack at address on top of stack. FCB $81 FCB $A1 FDB CAT-5 STORE FDB *+NATWID LDD NATWID,U STD [,U] LEAU 2*NATWID,U RTS * TFR S,X ; TSX : * LDX 0,X get address * LEAS 1,S ; * LEAS 1,S ; * JMP PULABX * * ======>> 46 << * ( b adr --- ) * Store low byte of second word on stack at address on top of stack. * High byte is ignored. FCB $82 FCC 'C' ; 'C!' FCB $A1 FDB STORE-4 CSTORE FDB *+NATWID LDB 3,U STB [,U] LEAU 2*NATWID,U RTS * TFR S,X ; TSX : * 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 << * ( --- ) P * { : name sundry-activities ; } typical input * If executing (not compiling), * record the data stack mark in CSP, * Set the CONTEXT vocabulary to CURRENT, * CREATE a header, * set state to compile, * and compile the call to the trailing native CPU machine code DOCOL. * * This would not be hard to flatten to native code. * But that's not the purpose of a model. 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 ) * ( *** oldIP ) * Characteristic of a colon (:) definition. * Begins execution of a high-level definition, * i. e., nests the definition and begins processing icodes. * Mechanically, it pushes the IP (Y register) * and loads the Parameter Field Address of the definition which * called it into the IP. DOCOL LDD ,S ; Save the return address. STY ,S ; Nest the old IP. LEAY NATWID,X ; W still in X, bump to parameters, load as new IP. TFR D,PC ; synthetic return to interpret. * DOCOL LDX RP make room in the stack * LEAX -1,X ; * LEAX -1,X ; * STX RP * 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 << * ( --- ) P * { : name sundry-activities ; } typical input * ERROR check data stack against mark in CSP, * compile ;S, * unSMUDGE LATEST definition, * and set state to interpretation. FCB $C1 ; imnediate code FCB $BB FDB COLON-4 SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK FDB SEMIS * * ######>> screen 34 << * ======>> 49 << * ( n --- ) * { value CONSTANT name } typical input * CREATE a header, * unSMUDGE it, * compile the constant value, * and compile the call to the trailing native CPU machine code DOCON. FCB $88 FCC 'CONSTAN' ; 'CONSTANT' FCB $D4 FDB SEMI-4 CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE * ( --- n ) * Characteristic of a CONSTANT. * A CONSTANT simply loads its value from its parameter field * and pushes it on the stack. DOCON LDD NATWID,X ; Get the first natural width word of the parameter field. PSHU D RTS * DOCON LDX W * LDA 2,X * LDB 3,X A & B now contain the constant * JMP PUSHBA * * Not in model, needed for abstraction: * ( --- NATWID ) * The byte width of objects on stack. FCB $86 FCC 'NATWI' ; 'NATWID' FCB $C4 FDB CON-11 NATWC FDB DOCON NATWCV FDB NATWID * * Not in model, needed for abstraction: * Note that this is not defined as an INCREMENTER! * Coded to increment by the exact constant returned by NATWID * ( n --- n+NATWID ) FCB $84 FCC 'NAT' ; 'NAT+' FCB $AB FDB NATWC-9 NATP FDB *+NATWID LDD ,U ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative. STD ,U RTS * How this might have been done for 6800 model: * CLRA ; We know the natural width is less than 255, LOL. * LDAB NATWCV+1 * TSX * ADDB 1,X * ADCA ,X * JMP STABX * * ======>> 50 << * ( init --- ) * { init VARIABLE name } typical input * Use CONSTANT to CREATE a header and compile the initial value, init, * then overwrite the characteristic to point to DOVAR. FCB $88 FCC 'VARIABL' ; 'VARIABLE' FCB $C5 FDB NATP-7 VAR FDB DOCOL,CON,PSCODE * ( --- vadr ) * Characteristic of a VARIABLE. * A VARIABLE pushes its PFA address on the stack. * The parameter field of a VARIABLE is the actual allocation of the variable, * so that pushing its address allows its contents to be @ed (fetched). * Ordinary arrays and strings that do not subscript themselves * may be allocated by defining a variable * and immediately ALLOTting the remaining needed space. * VARIABLES are global to all users, * and thus should be hidden in resource monitors, but aren't. DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters. PSHU X RTS * DOVAR LDA W * LDB W+1 * ADDB #2 * ADCA #0 A,B now contain the address of the variable * JMP PUSHBA * * ======>> 51 << * ( ub --- ) * { uboffset USER name } typical input * CREATE a header and compile the unsigned byte offset in the per-USER table, * then overwrite the header with a call to DOUSER. * The USER is entirely responsible for maintaining allocation! FCB $84 FCC 'USE' ; 'USER' FCB $D2 FDB VAR-11 USER FDB DOCOL,CON,PSCODE * ( --- vadr ) * Characteristic of a per-USER variable. * USER variables are similiar to VARIABLEs, * but are allocated (by hand!) in the per-user table. * A USER variable's parameter field contains its offset in the per-user table. DOUSER TFR DP,A ; Make a pointer to the direct page. CLRB * See Alternative -- alternatives start from this point. ADDD NATWID,X ; Add it to the offset to the per-user variable. PSHU D TFR D,X ; Cache the pointer in X for the caller. RTS * Hey, the per-user table could actually be larger than 256 bytes! * But we knew that. It's just not as esthetic to calculate it this way. * Alternative A: * LDX NATWID,X ; Keep the offset * EXG D,X ; Prepare for EA * LEAX D,X * PSHU X * RTS * Alternative B: * PSHS Y ; Get Y free for calculations. * TFR D,Y ; Y points to the UP base * LDD NATWID,X ; Get the offset * LEAX D,Y ; Leave the pointer cached in X. * PSHU X * PULS Y,PC * * From the 6800 model: * 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 << * ( --- 0 ) FCB $81 FCB $B0 0 FDB USER-7 ZERO FDB DOCON FDB 0000 * * ======>> 53 << * ( --- 1 ) FCB $81 FCB $B1 1 FDB ZERO-4 ONE FDB DOCON ONEV FDB 1 * * ======>> 54 << * ( --- 2 ) FCB $81 FCB $B2 2 FDB ONE-4 TWO FDB DOCON TWOV FDB 2 * * ======>> 55 << * ( --- 3 ) FCB $81 FCB $B3 3 FDB TWO-4 THREE FDB DOCON FDB 3 * * ======>> 56 << * ( --- SP ) * ASCII SPACE character FCB $82 FCC 'B' ; 'BL' FCB $CC FDB THREE-4 BL FDB DOCON ascii blank FDB $20 * * ======>> 57 << * This really shouldn't be a CONSTANT. * ( --- adr ) * The base of the disk buffer space. FCB $85 FCC 'FIRS' ; 'FIRST' FCB $D4 FDB BL-5 FIRST FDB DOCON FDB BUFBAS * FDB MEMEND-528 (132 * NBLK) * * ======>> 58 << * This really shouldn't be a CONSTANT. * ( --- adr ) * The limit of the disk buffer space. FCB $85 FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 ) FCB $D4 FDB FIRST-8 LIMIT FDB DOCON FDB BUFBAS+BUFSZ * In 6800 model, was * FDB MEMEND * * ======>> 59 << * ( --- sectorsize ) * The size, in bytes, of a buffer control region. FCB $85 FCC 'B/CT' ; 'B/CTL' : (bytes/control region) FCB $CC FDB LIMIT-8 BCTL FDB DOCON FDB SECTRL * * ( --- sectorsize ) * The size, in bytes, of a buffer. FCB $85 FCC 'B/BU' ; 'B/BUF' : (bytes/buffer) FCB $C6 FDB BCTL-8 BBUF FDB DOCON FDB SECTSZ * Hardcoded in 6800 model: * FDB 128 * * ======>> 60 << * ( --- blocksperscreen ) * The size, in blocks, of a screen. * Should this be the same as NBLK, the number of block buffers maintained? FCB $85 FCC 'B/SC' ; 'B/SCR' : (blocks/screen) FCB $D2 FDB BBUF-8 BSCR FDB DOCON FDB SCRSZ/SECTSZ * Hardcoded in 6800 model as: * FDB 8 * blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes. * * ======>> 61 << * ( n --- adr ) * Calculate the address of entry (#n/2) in the boot-up parameter table. * (Adds the base of the boot-up table to n.) FCB $87 FCC '+ORIGI' ; '+ORIGIN' FCB $CE FDB BSCR-8 PORIG FDB DOCOL,LIT,ORIG,PLUS FDB SEMIS * * ######>> screen 36 << * ======>> 62 << * ( n --- adr ) * This is the per-task variable recording the initial parameter stack pointer. FCB $82 FCC 'S' ; 'S0' FCB $B0 FDB PORIG-10 SZERO FDB DOUSER FDB XSPZER-UORIG * * ======>> 63 << * ( n --- adr ) * This is the per-task variable recording the initial return stack pointer. FCB $82 FCC 'R' ; 'R0' FCB $B0 FDB SZERO-5 RZERO FDB DOUSER FDB XRZERO-UORIG * * ======>> 64 << * ( --- vadr ) * Terminal Input Buffer address. * Note that this is a variable, so users may allocate their own buffers, but it must be @ed. FCB $83 FCC 'TI' ; 'TIB' FCB $C2 FDB RZERO-5 TIB FDB DOUSER FDB XTIB-UORIG * * ======>> 65 << * ( --- maxnamewidth ) * This is the maximum width to which symbol names will be recorded. FCB $85 FCC 'WIDT' ; 'WIDTH' FCB $C8 FDB TIB-6 WIDTH FDB DOUSER FDB XWIDTH-UORIG * * ======>> 66 << * ( --- vadr ) * Availability of error messages on disk. * Contains 1 if messages available, * 0 if not, * -1 if a disk error has occurred. FCB $87 FCC 'WARNIN' ; 'WARNING' FCB $C7 FDB WIDTH-8 WARN FDB DOUSER FDB XWARN-UORIG * * ======>> 67 << * ( --- vadr ) * Boundary for FORGET. FCB $85 FCC 'FENC' ; 'FENCE' FCB $C5 FDB WARN-10 FENCE FDB DOUSER FDB XFENCE-UORIG * * ======>> 68 << * ( --- vadr ) * Dictionary pointer, fetched by HERE. FCB $82 FCC 'D' ; 'DP' : points to first free byte at end of dictionary FCB $D0 FDB FENCE-8 DICTPT FDB DOUSER FDB XDICTP-UORIG * * ======>> 68.5 << * ( --- vadr ) ******* Need to check what this is! * Used in maintaining vocabularies. * I think it points to the "parent" vocabulary, but I'm not sure. * Or maybe this is the CONTEXT vocabulary. I'll have to come back here. ***** FCB $88 FCC 'VOC-LIN' ; 'VOC-LINK' FCB $CB FDB DICTPT-5 VOCLIN FDB DOUSER FDB XVOCL-UORIG * * ======>> 69 << * ( --- vadr ) * Disk block being interpreted. * Zero refers to terminal. * ******** Should be made a 32 bit user variable! ******** * But the base system needs to have full 32 bit support, div and mul, etc. * before we can do that. FCB $83 FCC 'BL' ; 'BLK' FCB $CB FDB VOCLIN-11 BLK FDB DOUSER FDB XBLK-UORIG * * ======>> 70 << * ( --- vadr ) * Input buffer offset/cursor. FCB $82 FCC 'I' ; 'IN' : scan pointer for input line buffer FCB $CE FDB BLK-6 IN FDB DOUSER FDB XIN-UORIG * * ======>> 71 << * ( --- vadr ) * Output buffer offset/cursor. FCB $83 FCC 'OU' ; 'OUT' FCB $D4 FDB IN-5 OUT FDB DOUSER FDB XOUT-UORIG * * ======>> 72 << * ( --- vadr ) * Screen currently being edited, once we have an editor running. FCB $83 FCC 'SC' ; 'SCR' FCB $D2 FDB OUT-6 SCR FDB DOUSER FDB XSCR-UORIG * ######>> screen 37 << * * ======>> 73 << * ( --- vadr ) * Sector offset for LOADing screens, * set by DRIVE to make a new drive the default. * This should also be 32 bit or bigger. FCB $86 FCC 'OFFSE' ; 'OFFSET' FCB $D4 FDB SCR-6 OFSET FDB DOUSER FDB XOFSET-UORIG * * ======>> 74 << * ( --- vadr ) * Current context of interpretation (vocabulary root). 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 << * ( --- vadr ) * Current context of definition (vocabulary root). FCB $87 FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended FCB $D4 FDB CONTXT-10 CURENT FDB DOUSER FDB XCURR-UORIG * * ======>> 76 << * ( --- vadr ) * Compiler/interpreter state. FCB $85 FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not FCB $C5 FDB CURENT-10 STATE FDB DOUSER FDB XSTATE-UORIG * * ======>> 77 << * ( --- vadr ) * Numeric conversion base. FCB $84 FCC 'BAS' ; 'BASE' : number base for all input & output FCB $C5 FDB STATE-8 BASE FDB DOUSER FDB XBASE-UORIG * * ======>> 78 << * ( --- vadr ) * Decimal point location for output. FCB $83 FCC 'DP' ; 'DPL' FCB $CC FDB BASE-7 DPL FDB DOUSER FDB XDPL-UORIG * * ======>> 79 << * ( --- vadr ) * Field width for I/O formatting. FCB $83 FCC 'FL' ; 'FLD' FCB $C4 FDB DPL-6 FLD FDB DOUSER FDB XFLD-UORIG * * ======>> 80 << * ( --- vadr ) * Compiler stack mark for stack check. FCB $83 FCC 'CS' ; 'CSP' FCB $D0 FDB FLD-6 CSP FDB DOUSER FDB XCSP-UORIG * * ======>> 81 << * ( --- vadr ) * Editing cursor location. FCB $82 FCC 'R' ; 'R#' FCB $A3 FDB CSP-6 RNUM FDB DOUSER FDB XRNUM-UORIG * * ======>> 82 << * ( --- vadr ) * Pointer to last HELD character in PAD. FCB $83 FCC 'HL' ; 'HLD' FCB $C4 FDB RNUM-5 HLD FDB DOCON FDB XHLD * * ======>> 82.5 <<== SPECIAL * ( --- vadr ) * Line width of active terminal. FCB $87 FCC 'COLUMN' ; 'COLUMNS' : line width of terminal FCB $D3 FDB HLD-6 COLUMS FDB DOUSER FDB XCOLUM-UORIG * * ######>> screen 38 << ** ** An INCREMENTER probably should not be defined without a defined CONSTANT? ** ** Make an INCREMENTER compiling word (not in model): ** ( n --- ) ** { n INCREMENTER name } typical input ** CREATE a header and compile the increment constant, ** then overwrite the header with a call to DOINC. * FCB $8B * FCC 'INCREMENTE' ; 'INCREMENTER' * FCB $D2 * FDB COLUMS-10 * INCR FDB DOCOL,CON,PSCODE ** ( n --- ninc ) ** Characteristic of an INCREMENTER. ** This is too naive: * DOINC LDD ,U * ADDD NATWID,X ; Add the increment. * STD ,U * RTS * Compiling word should check that it is compiling a CONSTANT. * * ======>> 83 << * ( n --- n+1 ) FCB $82 FCC '1' ; '1+' FCB $AB FDB COLUMS-10 * Using the model keeps things semantically connected for other processors: ONEP FDB DOCOL,ONE,PLUS FDB SEMIS ** Greedy alternative: * ONEP FDB *+NATWID * LDD ,U * ADDD ONEV,PCR * STD ,U * RTS * Naive alternative: * ONEP FDB DOINC * FDB 1 * Naive alternative: * ONEP FDB *+NATWID * LDD ,U * ADDD #1 ; It's hard to imagine 1+ being other than 1. * STD ,U * RTS * * ======>> 84 << * ( n --- n+2 ) FCB $82 FCC '2' ; '2+' FCB $AB FDB ONEP-5 * Using the model keeps things semantically connected for other processors: TWOP FDB DOCOL,TWO,PLUS FDB SEMIS ** Greedy alternative: * TWOP FDB *+NATWID * LDD ,U * ADDD TWOV,PCR ; See NAT+ (NATP) * STD ,U * RTS * Naive alternative: * TWOP FDB DOINC * FDB 2 * Naive alternative: * TWOP FDB *+NATWID * LDD ,U * ADDD #2 ; See NAT+ (NATP) * STD ,U * RTS * * ======>> 85 << * ( --- adr ) * Get the DICTPT allocation, like a USER constant. * Should check the stack and heap for collision. FCB $84 FCC 'HER' ; 'HERE' FCB $C5 FDB TWOP-5 HERE FDB DOCOL,DICTPT,AT FDB SEMIS * * ======>> 86 << * ( n --- ) * Increase/decrease heap (add n to DP), * Should ERROR check stack/heap. FCB $85 FCC 'ALLO' ; 'ALLOT' FCB $D4 FDB HERE-7 ALLOT FDB DOCOL,DICTPT,PSTORE FDB SEMIS * * ======>> 87 << * ( n --- ) * Store word n at DP++, * Should ERROR check stack/heap. FCB $81 ; , (COMMA) FCB $AC FDB ALLOT-8 COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT FDB SEMIS * COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT * FDB SEMIS * * ======>> 88 << * ( b --- ) * Store byte b at DP+, * Should ERROR check stack/heap. FCB $82 FCC 'C' ; 'C,' FCB $AC FDB COMMA-4 CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT FDB SEMIS * * ======>> 89 << * ( n1 n2 --- n1-n2 ) * Subtract top two words. FCB $81 ; - FCB $AD FDB CCOMM-5 SUB FDB *+NATWID LDD NATWID,U ; #2~6 SUBD ,U++ ; #2~9 STD ,U ; #2~5 RTS ; #1~5 = #7~25 * SUB FDB DOCOL,MINUS,PLUS * FDB SEMIS ; Costs 6 bytes and lots of cycles. * * ======>> 90 << * ( n1 n2 --- n1==n2 ) * Return flag true if n1 and n2 are equal, otherwise false. FCB $81 = FCB $BD FDB SUB-4 EQUAL FDB DOCOL,SUB,ZEQU FDB SEMIS * * ======>> 91 << * ( n1 n2 --- n1> 92 << * ( n1 n2 --- n1>n2 ) * Return flag true if n1 is greater than n2, false otherwise. FCB $81 > FCB $BE FDB LESS-4 GREAT FDB DOCOL,SWAP,LESS FDB SEMIS * * ======>> 93 << * ( n1 n2 n3 --- n2 n3 n1 ) * Rotate the top three words on stack, * bringing the third word to the top. FCB $83 FCC 'RO' ; 'ROT' FCB $D4 FDB GREAT-4 ROT FDB *+NATWID PSHS Y PULU D,X,Y PSHU D,X PSHU Y PULS Y,PC * ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP * FDB SEMIS * * ======>> 94 << * ( --- ) * EMIT a SPACE. FCB $85 FCC 'SPAC' ; 'SPACE' FCB $C5 FDB ROT-6 SPACE FDB DOCOL,BL,EMIT FDB SEMIS * * ======>> 95 << * ( n0 n1 --- min(n0,n1) ) * Leave the minimum of the top two integers. * Being too greedy here, but, whatever. FCB $83 FCC 'MI' ; 'MIN' FCB $CE FDB SPACE-8 MIN FDB *+NATWID PULU D CMPD ,U BLE MINX STD ,U MINX RTS * MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN * FDB MIN2-*-NATWID * FDB SWAP * MIN2 FDB DROP * FDB SEMIS * * ======>> 96 << * ( n0 n1 --- max(n0,n1) ) * Leave the maximum of the top two integers. * Really should leave this as in the model. FCB $83 FCC 'MA' ; 'MAX' FCB $D8 FDB MIN-6 MAX FDB *+NATWID PULU D CMPD ,U BLE MAXX STD ,U MAXX RTS * MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN * FDB MAX2-*-NATWID * FDB SWAP * MAX2 FDB DROP * FDB SEMIS * * ======>> 97 << * ( 0 --- 0 ) * ( n --- n n ) * DUP if non-zero. FCB $84 FCC '-DU' ; '-DUP' FCB $D0 FDB MAX-6 DDUP FDB *+NATWID LDD ,U BEQ DDUPX PSHU D DDUPX RTS * DDUP FDB DOCOL,DUP,ZBRAN * FDB DDUP2-*-NATWID * FDB DUP * DDUP2 FDB SEMIS * * ######>> screen 39 << * ======>> 98.1 << * Supplemental: * ( n<0 --- -1 ) * ( n>=~ --- 1 ) * Change top integer to its sign. FCB $86 FCC 'SIGNU' ; 'SIGNUM' FCB $CD FDB DDUP-7 SIGNUM FDB *+NATWID SIGNUE LDB #1 LDA ,U BPL SIGNUP NEGB SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead? STD ,U ; Am I too much of a prude? RTS * 6800 model version should be something like this: * LDB #1 * CLRA * TSX * TST ,X * BPL SIGNUP * NEGB * COMA * SIGNUP JMP STABX * * ======>> 98 << * ( adr1 direction --- adr2 ) * TRAVERSE the symbol name. * If direction is 1, find the end. * If direction is -1, find the beginning. FCB $88 FCC 'TRAVERS' ; 'TRAVERSE' FCB $C5 FDB SIGNUM-9 TRAV FDB *+NATWID BSR SIGNUE ; Convert negative to -, zero or positive to 1. LDD ,U++ ; Still in D, but we have to pop it anyway. LDX ,U ; If D is 1 or -1, so is B. LDA #$7F TRAVLP LEAX B,X ; Don't look at the one we start at. CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL. BCC TRAVLP TRAVDN STX ,U RTS * Doing this in 6809 just because it can be done may be getting too greedy. * TRAV FDB DOCOL,SWAP * TRAV2 FDB OVER,PLUS,LIT8 * FCB $7F * FDB OVER,CAT,LESS,ZBRAN * FDB TRAV2-*-NATWID * FDB SWAP,DROP * FDB SEMIS * * ======>> 99 << * ( --- symptr ) * Fetch CURRENT as a per-USER constant. FCB $86 FCC 'LATES' ; 'LATEST' FCB $D4 FDB TRAV-11 LATEST FDB DOCOL,CURENT,AT,AT FDB SEMIS * LATEST FDB *+NATWID * Getting too greedy: * Version 1: * TFR DP,A * CLRB * TFR D,X * LDD CURENT+NATWID,PCR * LDX [D,X] * PSHU X ; Leave the address in X. * RTS * Version 2: * LEAX CURENT,PCR * JSR [,X] * PULU X * LDX [,X] * PSHU X * RTS * Too greedy, too many smantic holes to fall through. * If the address at the CFA is made relative, * this is part of the code that would be affected * if it is in native CPU code. * * ======>> 100 << * Wanted to do these as INCREMENTERs, * but I need to stick with the model as much as possible, * (mostly, LOL) adding code only to make the model more clear. * ( pfa --- lfa ) * Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.) FCB $83 FCC 'LF' ; 'LFA' FCB $C1 FDB LATEST-9 LFA FDB DOCOL,LIT8 * FCB 4 FCB 2*NATWID FDB SUB FDB SEMIS * * ======>> 101 << * ( pfa --- cfa ) * Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.) FCB $83 FCC 'CF' ; 'CFA' FCB $C1 FDB LFA-6 * CFA FDB DOCOL,TWO,SUB CFA FDB DOCOL,NATWC,SUB FDB SEMIS * * ======>> 102 << * ( pfa --- nfa ) * Convert PFA to NFA. (Bump back from contents to beginning of symbol name.) FCB $83 FCC 'NF' ; 'NFA' FCB $C1 FDB CFA-6 NFA FDB DOCOL,LIT8 * FCB 5 FCB NATWID*2+1 FDB SUB,ONE,MINUS,TRAV FDB SEMIS * * ======>> 103 << * ( nfa --- pfa ) * Convert NFA to PFA. (Bump up from beginning of symbol name to contents.) FCB $83 FCC 'PF' ; 'PFA' FCB $C1 FDB NFA-6 PFA FDB DOCOL,ONE,TRAV,LIT8 * FCB 5 FCB NATWID*2+1 FDB PLUS FDB SEMIS * * ######>> screen 40 << * ======>> 104 << * ( --- ) * Save the parameter stack pointer in CSP for compiler checks. FCB $84 FCC '!CS' ; '!CSP' FCB $D0 FDB PFA-6 SCSP FDB DOCOL,SPAT,CSP,STORE FDB SEMIS * * ======>> 105 << * ( 0 n --- ) ( *** ) * ( true n --- IN BLK ) ( anything *** nothing ) * If flag is false, do nothing. * If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR. * Leaves cursor position (IN) * and currently loading block number (BLK) on stack, for analysis. * * This one is too important to be high-level Forth codes. * When we have an error, we want to disturb as little as possible. * But fixing that cascades through ERROR and MESSAGE * into the disk block system. * And we aren't ready for that yet. FCB $86 FCC '?ERRO' ; '?ERROR' FCB $D2 FDB SCSP-7 * QERR FDB *+NATWID * LDD NATWID,U * BNE QERROR * LEAU 2*NATWID,U * RTS ** this doesn't work anyway: QERROR LBR ERROR QERR FDB DOCOL,SWAP,ZBRAN FDB QERR2-*-NATWID FDB ERROR,BRAN FDB QERR3-*-NATWID QERR2 FDB DROP QERR3 FDB SEMIS * * ======>> 106 << * STATE is compiling: * ( --- ) ( *** ) * STATE is compiling: * ( --- IN BLK ) ( anything *** nothing ) * ERROR if not compiling. FCB $85 FCC '?COM' ; '?COMP' FCB $D0 FDB QERR-9 QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8 FCB $11 FDB QERR FDB SEMIS * * ======>> 107 << * STATE is executing: * ( --- ) ( *** ) * STATE is executing: * ( --- IN BLK ) ( anything *** nothing ) * ERROR if not executing. FCB $85 FCC '?EXE' ; '?EXEC' FCB $C3 FDB QCOMP-8 QEXEC FDB DOCOL,STATE,AT,LIT8 FCB $12 FDB QERR FDB SEMIS * * ======>> 108 << * ( n1 n1 --- ) ( *** ) * ( n1 n2 --- IN BLK ) ( anything *** nothing ) * ERROR if top two are unequal. * MESSAGE says compiled conditionals do not match. FCB $86 FCC '?PAIR' ; '?PAIRS' FCB $D3 FDB QEXEC-8 QPAIRS FDB DOCOL,SUB,LIT8 FCB $13 FDB QERR FDB SEMIS * * ======>> 109 << * CSP and parameter stack are balanced (equal): * ( --- ) ( *** ) * CSP and parameter stack are not balanced (unequal): * ( --- IN BLK ) ( anything *** nothing ) * ERROR if return/control stack is not at same level as last !CSP. * Usually indicates that a definition has been left incomplete. FCB $84 FCC '?CS' ; '?CSP' FCB $D0 FDB QPAIRS-9 QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8 FCB $14 FDB QERR FDB SEMIS * * ======>> 110 << * Active BLK input: * ( --- ) ( *** ) * No active BLK input: * ( --- IN BLK ) ( anything *** nothing ) * ERROR if not loading, i. e., if BLK is zero. FCB $88 FCC '?LOADIN' ; '?LOADING' FCB $C7 FDB QCSP-7 QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8 FCB $16 FDB QERR FDB SEMIS * * ######>> screen 41 << * ======>> 111 << * ( --- ) * Compile an in-line literal value from the instruction stream. FCB $87 FCC 'COMPIL' ; 'COMPILE' FCB $C5 FDB QLOAD-11 * COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA * COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA FDB SEMIS * * ======>> 112 << * ( --- ) P * Clear the compile state bit(s) (shift to interpret). FCB $C1 [ immediate FCB $DB FDB COMPIL-10 LBRAK FDB DOCOL,ZERO,STATE,STORE FDB SEMIS * * ======>> 113 << * STCOMP EQU $C0 * ( --- ) * Set the compile state bit(s) (shift to compile). FCB $81 ] FCB $DD FDB LBRAK-4 RBRAK FDB DOCOL,LIT8 FCB STCOMP FDB STATE,STORE FDB SEMIS * * ======>> 114 << * ( --- ) * Toggle SMUDGE bit of LATEST definition header, * to hide it until defined or reveal it after definition. FCB $86 FCC 'SMUDG' ; 'SMUDGE' FCB $C5 FDB RBRAK-4 SMUDGE FDB DOCOL,LATEST,LIT8 FCB FSMUDG FDB TOGGLE FDB SEMIS * * ======>> 115 << * ( --- ) * Set the conversion base to sixteen (b00010000). FCB $83 FCC 'HE' ; 'HEX' FCB $D8 FDB SMUDGE-9 HEX FDB DOCOL FDB LIT8 FCB 16 ; decimal sixteen FDB BASE,STORE FDB SEMIS * * ======>> 116 << * ( --- ) * Set the conversion base to ten (b00001010). FCB $87 FCC 'DECIMA' ; 'DECIMAL' FCB $CC FDB HEX-6 DEC FDB DOCOL FDB LIT8 FCB 10 ; decimal ten FDB BASE,STORE FDB SEMIS * * ######>> screen 42 << * ======>> 117 << * ( --- ) ( IP *** ) * Pop the saved IP and use it to * compile the latest symbol as a reference to a ;CODE definition; * overwrite the code field of the symbol found by LATEST * with the address of the low-level characteristic code * provided in the defining definition. * Look closely at where things return, consider the operation of R> and >R . * * The machine-level code which follows (;CODE) in the instruction stream * is not executed by the defining symbol, * but becomes the characteristic of the defined symbol. * This is the usual way to generate the characteristics of VARIABLEs, * CONSTANTs, COLON definitions, etc., when FORTH compiles itself. * * Finally, note that, if code shifts from low level back to high * (native CPU machine code calling into a list of FORTH codes), * the low level code can't just call a high-level definition. * Leaf definitions can directly call other leaf definitions, * but not non-leafs. * It will need an anonymous list, probably embedded in the low-level code, * and Y and X will have to be set appropriately before entering the list. FCB $87 FCC '(;CODE' ; '(;CODE)' FCB $A9 FDB DEC-10 * PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment. FDB LATEST,PFA,CFA,STORE FDB SEMIS * * ======>> 118 << * ( --- ) P * ?CSP to see if there are loose ends in the defining definition * before shifting to the assembler, * compile (;CODE) in the defining definition's instruction stream, * shift to interpreting, * make the ASSEMBLER vocabulary current, * and !CSP to mark the stack * in preparation for assembling low-level code. * Note that ;CODE, unlike DOES>, is IMMEDIATE, * and compiles (;CODE), * which will do the actual work of changing * the LATEST definition's characteristic when the defining word runs. * Assembly is done by the interpreter, rather than the compiler. * I could have avoided the anomalous three-byte code fields by * * Note that the ASSEMBLER is not part of the model (at this time). * That means that, until the assembler is ready, * if you want to define low-level words, * you have to poke (comma) in hand-assembled stuff. * 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 << * ( --- ) C * Make the word currently being defined * build a header for DOES> definitions. * Actually just compiles a CONSTANT zero * which can be overwritten later by DOES>. * Since the fig models were established, this technique has been deprecated. * * Note that executes. * The name > 120 << * ( --- ) ( IP *** ) C * Define run-time behavior of definitions compiled/defined * by a high-level defining definition -- * the FORTH equivalent of a compiler-compiler. * DOES> assumes that the LATEST symbol table entry * has at least one word of parameter field, * which is also not IMMEDIATE. * * When the defining word containing DOES> executes the DOES> icode, * it overwrites the LATEST symbol's CFA with jsr in the stream * do not execute at the defining word's run-time. * * Examining XDOES in the virtual machine shows * that the defined word will execute those icodes * which follow DOES> at its own run-time. * * The advantage of this kind of behaviour, * which you will also note in ;CODE, * is that the defined word can contain * both operations and data to be operated on. * This is how FORTH data objects define their own behavior. * * Finally, note that the effective parameter field for DOES> definitions * starts two NATWID words after the CFA, instead of just one * (four bytes instead of two in a sixteen-bit addressing Forth). * * VOCABULARYs will use this. See definition of word FORTH. FCB $85 FCC 'DOES' ; 'DOES>' FCB $BE FDB BUILDS-10 * DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment. FDB LATEST,PFA,STORE FDB PSCODE * * ( --- PFA+NATWID ) ( *** IP ) * Characteristic of a DOES> defined word. * The characteristics of DOES> definitions are written in high-level * Forth codes rather than native CPU machine level code. * The first parameter word points to the high-level characteristic. * This routine's job is to push the IP, * load the high level characteristic pointer in IP, * and leave the address following the characteristic pointer on the stack * so the parameter field can be accessed. DODOES LDD ,S ; Keep the return address. STY ,S ; Save/nest the current IP on the return stack. LDY NATWID,X ; First parameter is new IP. LEAX 2*NATWID,X ; Address of second parameter. PSHU X TFR D,PC ; Synthetic return. * * From the 6800 model: * 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 << * ( strptr --- strptr+1 count ) * Convert counted string to string and count. * (Fetch the byte at strptr, post-increment.) FCB $85 FCC 'COUN' ; 'COUNT' FCB $D4 FDB DOES-8 COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT FDB SEMIS * * ======>> 122 << * ( strptr count --- ) * EMIT count characters at strptr. FCB $84 FCC 'TYP' ; 'TYPE' FCB $C5 FDB COUNT-8 TYPE FDB DOCOL,DDUP,ZBRAN FDB TYPE3-*-NATWID FDB OVER,PLUS,SWAP,XDO TYPE2 FDB I,CAT,EMIT,XLOOP FDB TYPE2-*-NATWID FDB BRAN FDB TYPE4-*-NATWID TYPE3 FDB DROP TYPE4 FDB SEMIS * * ======>> 123 << * ( strptr count1 --- strptr count2 ) * Supress trailing blanks (subtract count of trailing blanks from strptr). 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-*-NATWID FDB LEAVE,BRAN FDB DTRAL4-*-NATWID DTRAL3 FDB ONE,SUB DTRAL4 FDB XLOOP FDB DTRAL2-*-NATWID FDB SEMIS * * ======>> 124 << * ( --- ) * TYPE counted string out of instruction stream (updating IP). FCB $84 FCC '(."' ; '(.")' FCB $A9 FDB DTRAIL-12 * PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP * PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP FDB FROMR,PLUS,TOR,TYPE FDB SEMIS * * ======>> 125 << * ( --- ) P * { ." something-to-be-printed " } typical input * Use WORD to parse to trailing quote; * if compiling, compile XDOTQ and string parsed, * otherwise, TYPE string. FCB $C2 immediate FCC '.' ; '."' FCB $A2 FDB PDOTQ-7 DOTQ FDB DOCOL FDB LIT8 FCB $22 ascii quote FDB STATE,AT,ZBRAN FDB DOTQ1-*-NATWID FDB COMPIL,PDOTQ,WORD FDB HERE,CAT,ONEP,ALLOT,BRAN FDB DOTQ2-*-NATWID DOTQ1 FDB WORD,HERE,COUNT,TYPE DOTQ2 FDB SEMIS * * ######>> screen 45 << * ======>> 126 <<== MACHINE DEPENDENT * ( --- ) ( *** ) * ( --- IN BLK ) ( anything *** nothing ) * ERROR if parameter stack out of bounds. * * But checking whether the stack is in bounds or not * really should not use the stack. * And there really should be a ?RSTACK, as well. FCB $86 FCC '?STAC' ; '?STACK' FCB $CB FDB DOTQ-5 QSTACK FDB DOCOL,LIT8 * FCB $12 FCB SINIT-ORIG * But why use that instead of XSPZER (S0)? * Multi-user or multi-tasking would not want that. * CMPU > 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,LIT8 * FCB $80 * FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID! * * ######>> screen 46 << * ======>> 128 << * ( buffer n --- ) * ***** Check that this is how it works here: * Get up to n-1 characters from the keyboard, * storing at buffer and echoing, with backspace editing, * quitting when a CR is read. * Terminate it with a NUL. FCB $86 FCC 'EXPEC' ; 'EXPECT' FCB $D4 FDB QSTACK-9 EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area * EXPEC2 FDB KEY,DUP,LIT8 EXPEC2 FDB KEY * FDB LIT,$1C,SHOTOS ; DBG FDB DUP,LIT8 FCB BACKSP-ORIG FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing FDB EXPEC3-*-NATWID FDB DROP,LIT8 FCB 8 ( backspace character to emit ) FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters FDB TOR,SUB,BRAN FDB EXPEC6-*-NATWID EXPEC3 FDB DUP,LIT8 FCB $D ( carriage return ) FDB EQUAL,ZBRAN FDB EXPEC4-*-NATWID FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator. FDB EXPEC5-*-NATWID EXPEC4 FDB DUP EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE EXPEC6 FDB EMIT,XLOOP FDB EXPEC2-*-NATWID FDB DROP FDB SEMIS * * ======>> 129 << * ( --- ) * EXPECT 128 (TWID) characters to TIB. 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 << * ( --- ) P * End interpretation of a line or screen, and/or prepare for a new block. * Note that the name of this definition is an empty string, * so it matches on the terminating NUL in the terminal or block buffer. FCB $C1 immediate < carriage return > FCB $80 FDB QUERY-8 NULL FDB DOCOL,BLK,AT,ZBRAN FDB NULL2-*-NATWID FDB ONE,BLK,PSTORE FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD FDB ZEQU * check for end of screen FDB ZBRAN FDB NULL1-*-NATWID FDB QEXEC,FROMR,DROP NULL1 FDB BRAN FDB NULL3-*-NATWID NULL2 FDB FROMR,DROP NULL3 FDB SEMIS * * ######>> screen 47 << * ======>> 133 << * ( adr n b --- ) * Fill n bytes at adr with b. * This relies on CMOVE having a certain lack of parameter checking, * where overlapping regions are not properly inverted in copy. * And this really should be done in low-level. * None of the advantages of doing things in high-level apply to fill. 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 << * ( adr n --- ) * Fill n bytes with 0. FCB $85 FCC 'ERAS' ; 'ERASE' FCB $C5 FDB FILL-7 ERASE FDB DOCOL,ZERO,FILL FDB SEMIS * * ======>> 135 << * ( adr n --- ) * Fill n bytes with ASCII SPACE. FCB $86 FCC 'BLANK' ; 'BLANKS' FCB $D3 FDB ERASE-8 BLANKS FDB DOCOL,BL,FILL FDB SEMIS * * ======>> 136 << * ( c --- ) * Format a character at the left of the HLD output buffer. FCB $84 FCC 'HOL' ; 'HOLD' FCB $C4 FDB BLANKS-9 HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE FDB SEMIS * * ======>> 137 << * ( --- adr ) * Give the address of the output PAD buffer. * PAD points to the end of a 68 byte buffer for numeric conversion. FCB $83 FCC 'PA' ; 'PAD' FCB $C4 FDB HOLD-7 PAD FDB DOCOL,HERE,LIT8 FCB $44 FDB PLUS FDB SEMIS * * ######>> screen 48 << * ======>> 138 << * ( c --- ) * Scan a string terminated by the character c or ASCII NUL out of input; * store symbol at WORDPAD with leading count byte and trailing ASCII NUL. * Leading c are passed over, per ENCLOSE. * Scans from BLK, or from TIB if BLK is zero. * May overwrite the numeric conversion pad, * if really long (length > 31) symbols are scanned. FCB $84 FCC 'WOR' ; 'WORD' FCB $C4 FDB PAD-6 WORD FDB DOCOL,BLK,AT,ZBRAN FDB WORD2-*-NATWID FDB BLK,AT,BLOCK,BRAN FDB WORD3-*-NATWID WORD2 FDB TIB,AT WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8 FCB 34 FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE FDB SEMIS * * ######>> screen 49 << * ======>> 139 << * ( d1 string --- d2 adr ) * Convert the text at string into a number, accumulating the result into d1, * leaving adr pointing to the first character not converted. * If DPL is non-negative at entry, * accumulates the number of characters converted into DPL. 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-*-NATWID FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN FDB PNUMB3-*-NATWID FDB ONE,DPL,PSTORE PNUMB3 FDB FROMR,BRAN FDB PNUMB2-*-NATWID PNUMB4 FDB FROMR FDB SEMIS * * ======>> 140 << * ( ctstr --- d ) * Convert text at ctstr to a double integer, * taking the 0 ERROR if the conversion is not valid. * If a decimal point is present, * accumulate the count of digits to the decimal point's right into DPL * (negative DPL at exit indicates single precision). * ctstr is a counted string * -- the first byte at ctstr is the length of the string, * but NUMBER ignores the count and expects a NUL terminator instead. FCB $86 FCC 'NUMBE' ; 'NUMBER' FCB $D2 FDB PNUMB-11 NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8 FCC "-" minus sign FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB FDB ZBRAN FDB NUMB2-*-NATWID FDB DUP,CAT,LIT8 FCC "." FDB SUB,ZERO,QERR,ZERO,BRAN FDB NUMB1-*-NATWID NUMB2 FDB DROP,FROMR,ZBRAN FDB NUMB3-*-NATWID FDB DMINUS NUMB3 FDB SEMIS * * ======>> 141 << * ( --- locptr length true ) { -FIND name } typical input * ( --- false ) * Parse a word, then FIND, * first in the definition vocabulary, * then in the CONTEXT (interpretation) vocabulary, if necessary. * Returns what (FIND) returns, flag and optional location and length. 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-*-NATWID FDB DROP,HERE,LATEST,PFIND DFIND2 FDB SEMIS * * ######>> screen 50 << * ======>> 142 << * ( anything --- nothing ) ( anything *** nothing ) * An indirection for ABORT, for ERROR, * which may be modified carefully. 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 * This really should not be high level, according to best practices. * But fixing that cascades through MESSAGE, * requiring re-architecting the disk block system. * First, we need to get this transliteration running. ERROR FDB DOCOL,WARN,AT,ZLESS FDB ZBRAN FDB ERROR2-*-NATWID * note: WARNING is * -1 to abort, * 0 to print error # * and 1 to print error message from disc FDB PABORT ERROR2 FDB HERE,COUNT,TYPE,PDOTQ FCB 4,7 ( bell ) FCC " ? " FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT FDB SEMIS * * ======>> 144 << * ( n adr --- ) * Mask byte at adr with n. * Not in FIG, don't need it for 8 bit characters after all. * FCB $85 * FCC 'CMAS' ; 'CMASK' * FCB $CB ; 'K' * FDB ERROR-8 * CMASK FDB *+NATWID * LDX ,U++ ; adr * LDD ,U++ ; mask * ANDB ,X * STB ,X * RTS * * ( adr --- adr ) * Mask high bit of tail of name in PAD buffer. * Not in FIG, need it for 8 bit characters. FCB $86 FCC 'IDFLA' ; 'IDFLAT' FCB $D4 ; 'T' FDB ERROR-8 IDFLAT FDB *+NATWID LDX ,U LDB ,X ; get the count ANDB #CTMASK LDA B,X ; point to the tail ANDA #$7F ; Clear the EndOfName flag bit. STA B,X RTS * * ( symptr --- ) * Print definition's name from its NFA. FCB $83 FCC 'ID' ; 'ID.' FCB $AE FDB IDFLAT-9 IDDOT FDB DOCOL,PAD,LIT8 FCB 32 FDB LIT8 FCB $5F ( underline ) FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD * FDB SWAP,CMOVE,PAD,COUNT,LIT8 FDB SWAP,CMOVE,PAD FDB IDFLAT FDB COUNT,LIT8 FCB 31 FDB AND,TYPE,SPACE FDB SEMIS * * ######>> screen 51 << * ======>> 145 << * ( --- ) { CREATE name } input * Parse a name (length < 32 characters) and create a header, * reporting first duplicate found in either the defining vocabulary * or the context (interpreting) vocabulary. * Install the header in the defining vocabulary * with CFA dangerously pointing to the parameter field. * Leave the name SMUDGEd. FCB $86 FCC 'CREAT' ; 'CREATE' FCB $C5 FDB IDDOT-6 CREATE FDB DOCOL,DFIND,ZBRAN FDB CREAT2-*-NATWID FDB DROP,PDOTQ FCB 8 FCB 7 ( bel ) FCC "redef: " FDB NFA,IDDOT,LIT8 FCB 4 FDB MESS,SPACE CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN FDB ONEP,ALLOT,DUP,LIT8 FCB ($80|FSMUDG) ; Bracket the name. FDB TOGGLE,HERE,ONE,SUB,LIT8 FCB $80 FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE * FDB HERE,TWOP,COMMA FDB HERE,NATP,COMMA FDB SEMIS * * ######>> screen 52 << * ======>> 146 << * ( --- ) P * { [COMPILE] name } typical use * -DFIND next WORD and COMPILE it, literally; * used to compile immediate definitions into words. FCB $C9 immediate FCC '[COMPILE' ; '[COMPILE]' FCB $DD FDB CREATE-9 BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA FDB SEMIS * * ======>> 147 << * ( n --- ) if compiling. P * ( n --- n ) if interpreting. * Compile n as a literal, if compiling. FCB $C7 immediate FCC 'LITERA' ; 'LITERAL' FCB $CC FDB BCOMP-12 LITER FDB DOCOL,STATE,AT,ZBRAN FDB LITER2-*-NATWID FDB COMPIL,LIT,COMMA LITER2 FDB SEMIS * * ======>> 148 << * ( d --- ) if compiling. P * ( d --- d ) if interpreting. * Compile d as a double literal, if compiling. FCB $C8 immediate FCC 'DLITERA' ; 'DLITERAL' FCB $CC FDB LITER-10 DLITER FDB DOCOL,STATE,AT,ZBRAN FDB DLITE2-*-NATWID FDB SWAP,LITER,LITER ; Just two literals in the right order. DLITE2 FDB SEMIS * * ######>> screen 53 << * ======>> 149 << * ( --- ) * Interpret or compile, according to STATE. * Searches words parsed in dictionary first, via -FIND, * then checks for valid NUMBER. * Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative. * ERROR checks the stack via ?STACK before returning to its caller. FCB $89 FCC 'INTERPRE' ; 'INTERPRET' FCB $D4 FDB DLITER-11 INTERP FDB DOCOL INTER2 FDB DFIND,ZBRAN FDB INTER5-*-NATWID FDB STATE,AT,LESS FDB ZBRAN FDB INTER3-*-NATWID FDB CFA,COMMA,BRAN FDB INTER4-*-NATWID INTER3 FDB CFA,EXEC INTER4 FDB BRAN FDB INTER7-*-NATWID INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN FDB INTER6-*-NATWID FDB DLITER,BRAN FDB INTER7-*-NATWID INTER6 FDB DROP,LITER INTER7 FDB QSTACK,BRAN FDB INTER2-*-NATWID * FDB SEMIS never executed * * ######>> screen 54 << * ======>> 150 << * ( --- ) * Toggle precedence bit of LATEST definition header. * During compiling, most symbols scanned are compiled. * IMMEDIATE definitions execute whenever the outer INTERPRETer scans them, * but may be compiled via ' (TICK). FCB $89 FCC 'IMMEDIAT' ; 'IMMEDIATE' FCB $C5 FDB INTERP-12 IMMED FDB DOCOL,LATEST,LIT8 FCB FIMMED FDB TOGGLE FDB SEMIS * * ======>> 151 << * ( --- ) { VOCABULARY name } input * Create a vocabulary entry with a flag for terminating vocabulary searches. * Store the current search context in it for linking. * At run-time, VOCABULARY makes itself the CONTEXT vocabulary. 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 DOVOC FDB NATP,CONTXT,STORE FDB SEMIS * * ======>> 152 << * * Note: FORTH does not go here in the rom-able dictionary, * since FORTH is a type of variable. * * (Should make a proper architecture for this at some point.) * * * ======>> 153 << * ( --- ) * Makes the current interpretation CONTEXT vocabulary * also the CURRENT defining vocabulary. FCB $8B FCC 'DEFINITION' ; 'DEFINITIONS' FCB $D3 FDB VOCAB-13 DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE FDB SEMIS * * ======>> 154 << * ( --- ) * Parse out a comment and toss it away. * Leaves the first 32 characters in WORDPAD, which may or may not be useful. FCB $C1 immediate ( FCB $A8 FDB DEFIN-14 PAREN FDB DOCOL,LIT8 FCC ")" FDB WORD FDB SEMIS * * ######>> screen 55 << * ======>> 155 << * ( anything *** nothing ) * Clear return stack. * Then INTERPRET and, if not compiling, prompt with OK, * in infinite loop. 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-*-NATWID FDB PDOTQ FCB 3 FCC ' OK' ; ' OK' QUIT3 FDB BRAN FDB QUIT2-*-NATWID * FDB SEMIS ( never executed ) * * ======>> 156 << * ( anything --- nothing ) ( anything *** nothing ) * Clear parameter stack, * set STATE to interpret and BASE to DECIMAL, * return to input from terminal, * restore DRIVE OFFSET to 0, * print out "Forth-68", * set interpret and define vocabularies to FORTH, * and finally, QUIT. * Used to force the system to a known state * and return control to the initial INTERPRETer. FCB $85 FCC 'ABOR' ; 'ABORT' FCB $D4 FDB QUIT-7 ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ FCB 10 FCC "Forth-6809" 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 *+NATWID * Ultimately, we want position indepence, * so I'm using PCR where it seems reasonable. CENT LDS SINIT,PCR ; Get a useable return stack, at least. LDA #IUPDP ; This is not relative to PC. TFR A,DP ; And a useable direct page, too. SETDP IUPDP ; (For good measure.) * * We'll keep this here for the time being. * There are better ways to do this, of course. * Re-architect, re-architect. LEAX ERAM,PCR ; end of stuff to move STX > (152) << * ( --- ) P * Makes FORTH the current interpretation vocabulary. * In order to make this ROMmable, this entry is set up as the tail-end, * and copied to RAM in the start-up code. * We want a more elegant solution to this, too. Greedy, maybe. FCB $C5 immediate FCC 'FORT' ; 'FORTH' FCB $C8 FDB NOOP-7 ; Note that this does not link to COLD! RFORTH FDB DODOES,DOVOC,$81A0,TASK-7 FDB 0 FCC "Copyright 1979 Forth Interest Group, David Lion," FCB $0D FCC "Parts Copyright 2019 Joel Matthew Rees" FCB $0D FCB $84 FCC 'TAS' ; 'TASK' FCB $CB FDB FORTH-8 RTASK FDB DOCOL,SEMIS ERAM EQU * ERAMSZ EQU *-RAM ; So we can get a look at it. PAGE * * ######>> screen 57 << * ======>> 158 << * ( n0 --- d0 ) * Sign extend n0 to a double integer. FCB $84 FCC 'S->' ; 'S->D' FCB $C4 FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)! STOD FDB DOCOL,DUP,ZLESS,MINUS FDB SEMIS * * ======>> 159 << * ( multiplier multiplicand --- product ) * Signed word multiply. FCB $81 ; * FCB $AA FDB STOD-7 STAR FDB *+NATWID LBSR USTAR+NATWID ; or [USTAR,PCR]? LEAU NATWID,U ; Drop high word. RTS * JSR USTARS * LEAS 1,S ; * LEAS 1,S ; * JMP NEXT * * ======>> 160 << * ( dividend divisor --- remainder quotient ) * M/ in word-only form, i. e., signed division of 2nd word by top word, * yielding signed word quotient and remainder. * Except *BUG* it isn't signed. FCB $84 FCC '/MO' ; '/MOD' FCB $C4 FDB STAR-4 SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH FDB SEMIS * * ======>> 161 << * ( dividend divisor --- quotient ) * Signed word divide without remainder. * Except *BUG* it isn't signed. FCB $81 ; / FCB $AF FDB SLMOD-7 SLASH FDB DOCOL,SLMOD,SWAP,DROP FDB SEMIS * * ======>> 162 << * ( dividend divisor --- remainder ) * Remainder function, result takes sign of dividend. FCB $83 FCC 'MO' ; 'MOD' FCB $C4 FDB SLASH-4 MOD FDB DOCOL,SLMOD,DROP FDB SEMIS * * ======>> 163 << * ( multiplier multiplicand divisor --- remainder quotient ) * Signed precise division of product: * multiply 2nd and 3rd words on stack * and divide the 31-bit product by the top word, * leaving both quotient and remainder. * Remainder takes sign of product. * Guaranteed not to lose significant bits in 16 bit integer math. FCB $85 FCC '*/MO' ; '*/MOD' FCB $C4 FDB MOD-6 SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH FDB SEMIS * * ======>> 164 << * ( multiplier multiplicand divisor --- quotient ) * */MOD without remainder. FCB $82 FCC '*' ; '*/' FCB $AF FDB SSMOD-8 SSLASH FDB DOCOL,SSMOD,SWAP,DROP FDB SEMIS * * ======>> 165 << * ( ud1 u1 --- u2 ud2 ) * U/ with an (unsigned) double quotient. * Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math, * if you are prepared to deal with the extra 16 bits of result. 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 << * ( n>=0 --- n ) * ( n<0 --- -n ) * Convert the top of stack to its absolute value. FCB $83 FCC 'AB' ; 'ABS' FCB $D3 FDB MSMOD-8 ABS FDB DOCOL,DUP,ZLESS,ZBRAN FDB ABS2-*-NATWID FDB MINUS ABS2 FDB SEMIS * * ======>> 167 << * ( d>=0 --- d ) * ( d<0 --- -d ) * Convert the top double to its absolute value. FCB $84 FCC 'DAB' ; 'DABS' FCB $D3 FDB ABS-6 DABS FDB DOCOL,DUP,ZLESS,ZBRAN FDB DABS2-*-NATWID FDB DMINUS DABS2 FDB SEMIS * * ######>> screen 58 << * Disc primitives : * ======>> 168 << * ( --- vadr ) * Least Recently Used buffer. * Really should be with FIRST and LIMIT in the per-task table. FCB $83 FCC 'US' ; 'USE' FCB $C5 FDB DABS-7 USE FDB DOCON FDB XUSE * ======>> 169 << * ( --- vadr ) * Most Recently Used buffer. * Really should be with FIRST and LIMIT in the per-task table. FCB $84 FCC 'PRE' ; 'PREV' FCB $D6 FDB USE-6 PREV FDB DOCON FDB XPREV * ======>> 170 << * ( buffer1 --- buffer2 f ) * Bump to next buffer, * flag false if result is PREVious buffer, * otherwise flag true. * Used in the LRU allocation routines. FCB $84 FCC '+BU' ; '+BUF' FCB $C6 FDB PREV-7 * PBUF FDB DOCOL,LIT8 * FCB $84 ; This was a hard-wiring bug. PBUF FDB DOCOL,BBUF,BCTL,PLUS ; Size of the buffer record. * FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN FDB PLUS,DUP,LIMIT,LESS,ZEQU,OVER,FIRST,LESS,OR,ZBRAN FDB PBUF2-*-NATWID ; Use defensive programming. FDB DROP,FIRST PBUF2 FDB DUP,PREV,AT,SUB FDB SEMIS * * ======>> 171 << * ( --- f ) * Flag to mark a buffer dirty, in need of being written out. * This flag limits the max number of sectors in a disk to ((256^NATWID)/2)-1. * It also hard-codes an implicit test which is used elsewhere. FCB $8A FCC 'UPDATE-BI' ; 'UPDATE-BIT' FCB $D4 FDB PBUF-7 UPDBIT FDB DOCON FDB $8000 * * ( --- ) * Mark PREVious buffer dirty, in need of being written out. FCB $86 FCC 'UPDAT' ; 'UPDATE' FCB $C5 FDB UPDBIT-13 * UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE UPDATE FDB DOCOL,PREV,AT,AT,UPDBIT,OR,PREV,AT,STORE FDB SEMIS * * ======>> 172 << * ( adr --- ) * Mark the buffer addressed as empty. * Have to add code to avoid block 0 appearing to be in a buffer from COLD. * Usually, there is no sector 0 (?), but the RAM buffers are too simple. * Note that without this block number being made illegal, * about 8 binaryMegabytes (256 bytes/block) of disk can be addressed total. * With this block number made illegal, the max is 1 block less, * still about 8 biMeg. FCB $8B FCC 'KILL-BUFFE' ; 'KILL-BUFFER' FCB $D2 FDB UPDATE-9 KILBUF FDB *+NATWID ; DOCOL,UPDBIT,ONE,SUB,SWAP,STORE PULU X LDD UPDBIT+NATWID,PCR SUBD #1 STD ,X * LBSR DBGREG RTS * * ( --- ) * Mark all buffers empty. FCB $8C FCC 'KILL-BUFFER' ; 'KILL-BUFFERS' FCB $D3 FDB KILBUF-14 KLBFS FDB *+NATWID LDD #4 PSHU D LDD FIRST+NATWID,PCR * INC > 173 << * ( --- ) * Clear the current offset to the block numbers in the drive interface. * The drives need to be re-architected. * Would be cool to have RAM and ROM drives supported * in addition to regular physical persistent store. FCB $83 FCC 'DR' ; 'DR0' FCB $B0 FDB MTBUF-16 DRZERO FDB DOCOL,ZERO,OFSET,STORE FDB SEMIS * * ======>> 174 <<== system dependant word * ( --- ) * Set the current offset in the drive interface to reference the second drive. * The hard-coded number in there needs to be in a table. FCB $83 FCC 'DR' ; 'DR1' FCB $B1 FDB DRZERO-6 DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE ; **** hard-codes the size of the disc !!!! FDB SEMIS * * ######>> screen 59 << * ======>> 175 << * ( n --- buffer ) * Get a free buffer, * assign it to block n, * return buffer address. * Will free a buffer by writing it, if necessary. * Does not actually read the block. * A bug in the fig LRU algorithm, which I have not fixed, * gives the PREVious buffer if USE gets set to PREVious. * (The bug is that USE sometimes gets set to PREVious.) * This bug sometimes causes sector moves to become sector fills. FCB $86 FCC 'BUFFE' ; 'BUFFER' FCB $D2 FDB DRONE-6 BUFFER FDB DOCOL,USE,AT,DUP,TOR BUFFR2 FDB PBUF,ZBRAN FDB BUFFR2-*-NATWID FDB USE,STORE,R,AT,ZLESS FDB ZBRAN FDB BUFFR3-*-NATWID * FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW FDB R,NATP,R,AT,UPDBIT,LNOT,AND,ZERO,RW * BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP FDB SEMIS * * ######>> screen 60 << * ======>> 176 << * ( n --- buffer ) * Get BUFFER containing block n, relative to OFFSET. * If block n is not in a buffer, bring it in. * Returns buffer address. 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-*-NATWID BLOCK3 FDB PBUF,ZEQU,ZBRAN FDB BLOCK4-*-NATWID * FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN FDB BLOCK3-*-NATWID FDB DUP,PREV,STORE * BLOCK5 FDB FROMR,DROP,TWOP BLOCK5 FDB FROMR,DROP,NATP FDB SEMIS * * ######>> screen 61 << * ======>> 177 << * ( line screen --- buffer C/L) * Bring in the sector containing the specified line of the specified screen. * Returns the buffer address and the width of the screen. * Screen number is relative to OFFSET. * The line number may be beyond screen 4, * (LINE) will get the appropriate screen. FCB $86 FCC '(LINE' ; '(LINE)' FCB $A9 FDB BLOCK-8 PLINE FDB DOCOL,TOR,LIT8 FCB $40 FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8 FCB $40 FDB SEMIS * * ======>> 178 << * ( line screen --- ) * Print the line of the screen as found by (LINE), suppress trailing BLANKS. FCB $85 FCC '.LIN' ; '.LINE' FCB $C5 FDB PLINE-9 DLINE FDB DOCOL,PLINE,DTRAIL,TYPE FDB SEMIS * * ======>> 179 << * ( n --- ) * If WARNING is 0, print "MESSAGE #n"; * otherwise, print line n relative to screen 4, * the line number may be negative. * Uses .LINE, but counter-adjusts to be relative to the real drive 0. FCB $87 FCC 'MESSAG' ; 'MESSAGE' FCB $C5 FDB DLINE-8 MESS FDB DOCOL,WARN,AT,ZBRAN FDB MESS3-*-NATWID FDB DDUP,ZBRAN FDB MESS3-*-NATWID FDB LIT8 FCB 4 FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN FDB MESS4-*-NATWID MESS3 FDB PDOTQ FCB 6 FCC 'err # ' ; 'err # ' FDB DOT MESS4 FDB SEMIS * * ======>> 180 << * ( n --- ) * Begin interpretation of screen (block) n. * See also ARROW, SEMIS, and NULL. 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 << * ( --- ) P * Continue interpreting source code on the next screen. 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 * ( --- ) No parameter stack effect. * Interfaces directly with ROM. Expects output character in D (therefore, B). * Output using rom CHROUT: redirectable to a printer on Coco. * Outputs the character on stack (low byte of 1 bit word/cell). PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.) TFR B,A ; Coco ROM wants it in A. CLRB TFR B,DP ; Give the ROM its direct page. JSR [$A002] ; Output the character in A. 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 * ( --- ) No parameter stack effect. * Returns character or break flag in D, since this interfaces with Coco ROM. * Wait for key from POLCAT on Coco. * Returns the character code for the key pressed. PKEY PSHS Y,U,DP ; Must save everything important for this one. LDA #$CF ; a cursor of sorts CLRB TFR B,DP SETDP 0 LDX <$88 ; location LDB ,X ; save glyph STA ,X PKEYLP JSR [$A000] * STA $41A ; DBG! BEQ PKEYLP * STD $418 ; DBG! STB ,X ; restore PKEYR CLRB ; for the break flag, shares code with PQTER CMPA #3 ; break key BNE PKEYGT COMB ; for the break flag PKEYGT EXG A,B ; Leave it in D for return. PULS Y,U,DP,PC ; Shares exit with PQTER SETDP IUPDP * 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 * ( --- f ) Should change this to no stack effect. * check break key using POLCAT * Returns a flag to tell whether the break key was pressed or not. PQTER PSHS Y,U,DP CLRB TFR B,DP JSR [$A000] ; Look but don't wait. BRA PKEYR * 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 * ( --- ) No stack effect. * Interfaces directly with ROM. * For Coco just output a CR. * Also subject to redirection in Coco BASIC ROM. PCR LDB #$0D BRA PEMIT ; Just steal the code. * PCR LDA #$D carriage 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 << * ( ??? ) * Query the disk, I suppose. * Not sure what the model had in mind for this stub. FCB $85 FCC '?DIS' ; '?DISC' FCB $C3 FDB ARROW-6 QDISC FDB *+NATWID JMP NEXT * * ######>> screen 67 << * ======>> 189 << * ( ??? ) * Write one block of data to disk. * Parameters unspecified in model. Stub in model. FCB $8B FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE' FCB $C5 FDB QDISC-8 BWRITE FDB *+NATWID JMP NEXT * * ######>> screen 68 << * ======>> 190 << * ( ??? ) * Read one block of data from disk. * Parameters unspecified in model. Stub in model. FCB $8A FCC 'BLOCK-REA' ; 'BLOCK-READ' FCB $C4 FDB BWRITE-14 BREAD FDB *+NATWID JMP NEXT * *The next 3 words are written to create a substitute for disc * mass memory,located between MASSLO & MASSHI in ram -- * ($3210 and $3fff in the 6800 model). * ======>> 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 or $7FFF in this version ) * * ######>> screen 69 << * ======>> 191 << * ( buffer sector f --- ) * Read or Write the specified (absolute -- ignores OFFSET) sector * from or to the specified buffer. * A zero flag specifies write, * non-zero specifies read. * Sector is an unsigned integer, * buffer is the buffer's address. * Will need to use the CoCo ROM disk routines. * For now, provides a virtual disk in RAM. 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-*-NATWID FDB PDOTQ FCB 8 FCC ' Range ?' ; ' Range ?' FDB QUIT RW2 FDB FROMR,ZBRAN FDB RW3-*-NATWID FDB SWAP RW3 FDB BBUF,CMOVE FDB SEMIS * * From BIF-6809: * RW PSHS Y,U,DP * LDY $C006 control table * LDX #DROFFS+7 ; This is BIF's table of drive sizes. * LDD 2,U * RWD SUBD ,X++ sectors * BHS RWD * BVC RWR table end? * LDD #6 * PSHU D * JMP ERROR * RWR ADDD ,--X back one * PSHS X * PSHU D * LDD #18 sectors/track * PSHU D * DOCOL * FDB SLAMOD * FDB XMACH * PULU D * STB 2,Y track * PULU D * INCB * STB 3,Y sector * PULS D table entry * SUBD #DROFFS+7 * ASRB drive # * STB 1,Y * LDD 4,U buffer * STD 4,Y * LDB #2 coco READ * LDX ,U 0? * BNE *+3 * INCB coco WRITE * STB ,Y op code * CLRA * TFR A,DP * JSR [$C004] ROM handles timeout * PULS Y,U,DP if IRQ enabled * LEAU 6,U * LDX $C006 * LDB 6,X coco status * BEQ RWE * LDX > screen 72 << * ======>> 192 << * ( --- ) compiling P * ( --- adr ) interpreting * { ' name } input * Parse a symbol name from input and search the dictionary for it, per -FIND; * compile the address as a literal if compiling, * otherwise just push it. FCB $C1 immediate FCB $A7 ' ( tick ) FDB RW-6 TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER FDB SEMIS * * ======>> 193 << * ( --- ) { FORGET name } input * Parse out name of definition to FORGET to, -DFIND it, * then lop it and everything that follows out of the dictionary. * In fig Forth, CURRENT and CONTEXT have to be the same to FORGET. FCB $86 FCC 'FORGE' ; 'FORGET' FCB $D4 FDB TICK-4 FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8 FCB $18 FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8 FCB $15 FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8 FCB $15 FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE FDB SEMIS * * ######>> screen 73 << * ======>> 194 << * ( adr --- ) C * Calculate a back reference from HERE and compile it. FCB $84 FCC 'BAC' ; 'BACK' FCB $CB FDB FORGET-9 * BACK FDB DOCOL,HERE,SUB,COMMA BACK FDB DOCOL,HERE,NATP,SUB,COMMA FDB SEMIS * * ======>> 195 << * ( --- ) runtime * typical use: BEGIN code-loop test UNTIL * typical use: BEGIN code-loop AGAIN * typical use: BEGIN code-loop test WHILE code-true REPEAT * ( --- adr n ) compile time P,C * Push HERE for BACK reference for general (non-counting) loops, * with BEGIN construct flag. * A better flag: $4245 (ASCII for 'BE'). FCB $C5 FCC 'BEGI' ; 'BEGIN' FCB $CE FDB BACK-7 BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops. FDB SEMIS * * ======>> 196 << * ( --- ) runtime * typical use: test IF code-true ELSE code-false ENDIF * ENDIF is just a sort of intersection piece, * marking where execution resumes after both branches. * ( adr n --- ) compile time * Check the mark and resolve the IF. * A better flag: $4846 (ASCII for 'IF'). FCB $C5 FCC 'ENDI' ; 'ENDIF' FCB $C6 FDB BEGIN-8 ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF. FDB OVER,NATP,SUB,SWAP,STORE FDB SEMIS * * ======>> 197 << * ( --- ) runtime * typical use: test IF code-true ELSE code-false ENDIF * ( adr n --- ) * Alias for ENDIF . FCB $C4 FCC 'THE' ; 'THEN' FCB $CE FDB ENDIF-8 THEN FDB DOCOL,ENDIF FDB SEMIS * * ======>> 198 << * ( limit index --- ) runtime * typical use: DO code-loop LOOP * typical use: DO code-loop increment +LOOP * Counted loop, index is initial value of index. * Will loop until index equals (positive going) * or passes (negative going) limit. * ( --- adr n ) compile time P,C * Compile (DO), push HERE for BACK reference, * and push DO control construct flag. * A better flag: $444F (ASCII for 'DO'). FCB $C2 FCC 'D' ; 'DO' FCB $CF FDB THEN-7 DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops. FDB SEMIS * * ======>> 199 << * ( --- ) runtime * typical use: DO code-loop LOOP * Increments the index by one and branches back to beginning of loop. * Will loop until index equals limit. * ( adr n --- ) compile time P,C * Check the mark and compile (LOOP), fill in BACK reference. * A better flag: $444F (ASCII for 'DO'). FCB $C4 FCC 'LOO' ; 'LOOP' FCB $D0 FDB DO-5 LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops. FDB SEMIS * * ======>> 200 << * ( n --- ) runtime * typical use: DO code-loop increment +LOOP * Increments the index by n and branches back to beginning of loop. * Will loop until index equals (positive going) * or passes (negative going) limit. * ( adr n --- ) compile time P,C * Check the mark and compile (+LOOP), fill in BACK reference. * A better flag: $444F (ASCII for 'DO'). FCB $C5 FCC '+LOO' ; '+LOOP' FCB $D0 FDB LOOP-7 PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops. FDB SEMIS * * ======>> 201 << * ( n --- ) runtime * typical use: BEGIN code-loop test UNTIL * Will loop until UNTIL tests true. * ( adr n --- ) compile time P,C * Check the mark and compile (0BRANCH), fill in BACK reference. * A better flag: $4245 (ASCII for 'BE'). FCB $C5 FCC 'UNTI' ; 'UNTIL' : ( same as END ) FCB $CC FDB PLOOP-8 UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops. FDB SEMIS * * ######>> screen 74 << * ======>> 202 << * ( n --- ) runtime * typical use: BEGIN code-loop test END * ( adr n --- ) * Alias for UNTIL . FCB $C3 FCC 'EN' ; 'END' FCB $C4 FDB UNTIL-8 END FDB DOCOL,UNTIL FDB SEMIS * * ======>> 203 << * ( --- ) runtime * typical use: BEGIN code-loop AGAIN * Will loop forever * (or until something uses R> DROP to force the current definition to die, * or perhaps ABORT or ERROR or some such other drastic means stops things). * ( adr n --- ) compile time P,C * Check the mark and compile (0BRANCH), fill in BACK reference. * A better flag: $4245 (ASCII for 'BE'). FCB $C5 FCC 'AGAI' ; 'AGAIN' FCB $CE FDB END-6 AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops. FDB SEMIS * * ======>> 204 << * ( --- ) runtime * typical use: BEGIN code-loop test WHILE code-true REPEAT * Will loop until WHILE tests false, skipping code-true on end. * REPEAT marks where execution resumes after the WHILE find a false flag. * ( aadr1 n1 adr2 n2 --- ) compile time P,C * Check the marks for WHILE and BEGIN, * compile BRANCH and BACK fill adr1 reference, * FILL-IN 0BRANCH reference at adr2. * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH'). FCB $C6 FCC 'REPEA' ; 'REPEAT' FCB $D4 FDB AGAIN-8 REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops. FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE. FDB SEMIS * * ======>> 205 << * ( n --- ) runtime * typical use: test IF code-true ELSE code-false ENDIF * Will pass execution to the true part on a true flag * and to the false part on a false flag. * ( --- adr n ) compile time P,C * Compile a 0BRANCH and dummy offset * and push IF reference to fill in and * IF control construct flag. * A better flag: $4946 (ASCII for 'IF'). FCB $C2 FCC 'I' ; 'IF' FCB $C6 FDB REPEAT-9 IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF. FDB SEMIS * * ======>> 206 << * ( --- ) runtime * typical use: test IF code-true ELSE code-false ENDIF * ELSE is just a sort of intersection piece, * marking where execution resumes on a false branch. * ( adr1 n --- adr2 n ) compile time P,C * Check the marks, * compile BRANCH with dummy offset, * resolve IF reference, * and leave reference to BRANCH for ELSE. * A better flag: $4946 (ASCII for 'IF'). 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 ; TWO is a flag for IF. FDB SEMIS * * ======>> 207 << * ( n --- ) runtime * typical use: BEGIN code-loop test WHILE code-true REPEAT * Will loop until WHILE tests false, skipping code-true on end. * ( --- adr n ) compile time P,C * Compile 0BRANCH with dummy offset (using IF), * push WHILE reference. * BEGIN flag will sit underneath this. * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH'). FCB $C5 FCC 'WHIL' ; 'WHILE' FCB $C5 FDB ELSE-7 WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE. FDB SEMIS * * ######>> screen 75 << * ======>> 208 << * ( count --- ) * EMIT count spaces, for non-zero, non-negative counts. FCB $86 FCC 'SPACE' ; 'SPACES' FCB $D3 FDB WHILE-8 SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN FDB SPACE3-*-NATWID FDB ZERO,XDO SPACE2 FDB SPACE,XLOOP FDB SPACE2-*-NATWID SPACE3 FDB SEMIS * * ======>> 209 << * ( --- ) * Initialize HLD for converting a double integer. * Stores the PAD address in HLD. FCB $82 FCC '<' ; '<#' FCB $A3 FDB SPACES-9 BDIGS FDB DOCOL,PAD,HLD,STORE FDB SEMIS * * ======>> 210 << * ( d --- string length ) * Terminate numeric conversion, * drop the number being converted, * leave the address of the conversion string and the length, ready for TYPE. FCB $82 FCC '#' ; '#>' FCB $BE FDB BDIGS-5 EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB FDB SEMIS * * ======>> 211 << * ( n d --- d ) * Put sign of n (as a flag) at the head of the conversion string. * Drop the sign flag. FCB $84 FCC 'SIG' ; 'SIGN' FCB $CE FDB EDIGS-5 SIGN FDB DOCOL,ROT,ZLESS,ZBRAN FDB SIGN2-*-NATWID FDB LIT8 FCC "-" FDB HOLD SIGN2 FDB SEMIS * * ======>> 212 << * ( d --- d/base ) * Generate next most significant digit in the conversion BASE, * putting the digit at the head of the conversion string. FCB $81 # FCB $A3 FDB SIGN-7 DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8 FCB 9 FDB OVER,LESS,ZBRAN FDB DIG2-*-NATWID FDB LIT8 FCB 7 FDB PLUS DIG2 FDB LIT8 FCC "0" ascii zero FDB PLUS,HOLD FDB SEMIS * * ======>> 213 << * ( d --- dzero ) * Convert d to a numeric string using # until the result is zero. * Leave the double result on the stack for #> to drop. FCB $82 FCC '#' ; '#S' FCB $D3 FDB DIG-4 DIGS FDB DOCOL DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN FDB DIGS2-*-NATWID FDB SEMIS * * ######>> screen 76 << * ======>> 214 << * ( n width --- ) * Print n on the output device in the current conversion base, * with sign, * right aligned in a field at least width wide. FCB $82 FCC '.' ; '.R' FCB $D2 FDB DIGS-5 DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR FDB SEMIS * * ======>> 215 << * ( d width --- ) * Print d on the output device in the current conversion base, * with sign, * right aligned in a field at least width wide. 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 << * D. ( d --- ) * Print d on the output device in the current conversion base, * with sign, * in free format with trailing space. FCB $82 FCC 'D' ; 'D.' FCB $AE FDB DDOTR-6 DDOT FDB DOCOL,ZERO,DDOTR,SPACE FDB SEMIS * * ======>> 217 << * ( n --- ) * Print n on the output device in the current conversion base, * with sign, * in free format with trailing space. FCB $81 . FCB $AE FDB DDOT-5 DOT FDB DOCOL,STOD,DDOT FDB SEMIS * * ======>> 218 << * ( adr --- ) * Print signed word at adr, per DOT. FCB $81 ? FCB $BF FDB DOT-4 QUEST FDB DOCOL,AT,DOT FDB SEMIS * * ######>> screen 77 << * ======>> 219 << * ( n --- ) * Print out screen n as a field of ASCII, * with line numbers in decimal. * Needs a console more than 70 characters wide. FCB $84 FCC 'LIS' ; 'LIST' FCB $D4 FDB QUEST-4 LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ FCB 6 FCC "SCR # " FDB DOT,LIT8 FCB $10 FDB ZERO,XDO LIST2 FDB CR,I,THREE FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP FDB LIST2-*-NATWID FDB CR FDB SEMIS * * ======>> 220 << * ( start end --- ) * Print comment lines (line 0, and line 1 if C/L < 41) of screens * from start to end. * Needs a console more than 70 characters wide. 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-*-NATWID FDB LEAVE INDEX3 FDB XLOOP FDB INDEX2-*-NATWID FDB SEMIS * * ======>> 221 << * ( n --- ) * List a printer page full of screens. * Line and screen number are in current base. * Needs a console more than 70 characters wide. 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-*-NATWID FDB LEAVE TRIAD3 FDB XLOOP FDB TRIAD2-*-NATWID FDB CR,LIT8 FCB $0F FDB MESS,CR FDB SEMIS * * ######>> screen 78 << * ======>> 222 << * ( --- ) * Alphabetically list the definitions in the current vocabulary. * Expects to output to printer, not TRS80 Color Computer screen. FCB $85 FCC 'VLIS' ; 'VLIST' FCB $D4 FDB TRIAD-8 VLIST FDB DOCOL,LIT8 FCB $80 FDB OUT,STORE,CONTXT,AT,AT VLIST1 FDB OUT,AT,COLUMS,AT,LIT8 FCB 32 FDB SUB,GREAT,ZBRAN FDB VLIST2-*-NATWID FDB CR,ZERO,OUT,STORE VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT FDB DUP,ZEQU,QTERM,OR,ZBRAN FDB VLIST1-*-NATWID FDB DROP FDB SEMIS * * Need some utility stuff that isn't in the fig FORTH: * ( c --- ) * Emit dot if c is less than blank, else emit c FCB $85 FCC 'BEMI' ; 'BEMIT' FCB $D4 ; 'T' FDB VLIST-8 BEMIT FDB DOCOL FDB DUP,BL,LESS,ZBRAN FDB BEMITO-*-NATWID FDB DROP,LIT8 FCB $2e ; '.' BEMITO FDB EMIT FDB SEMIS * * ( n width --- ) * Output n in hexadecimal field width. FCB $83 FCC 'X.' ; 'X.R' FCB $D2 ; 'R' FDB BEMIT-8 XDOTR FDB DOCOL FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE FDB SEMIS * * ( adr --- ) * Dump a line of 4 bytes in memory, in hex and as characters. FCB $85 FCC 'BLIN' ; 'BLINE' FCB $C5 ; 'E' FDB XDOTR-6 BLINE FDB DOCOL FDB DUP,LIT8 FCB 4 FDB PLUS,OVER,XDO BLINEX FDB I,CAT,THREE,XDOTR,XLOOP FDB BLINEX-*-NATWID FDB SPACE,SPACE FDB DUP,LIT8 FCB 4 FDB PLUS,SWAP,XDO BLINEC FDB I,CAT,BEMIT,XLOOP FDB BLINEC-*-NATWID FDB SEMIS * * ( start end --- ) * Dump 4 byte lines from start to end. FCB $85 FCC 'BDUM' ; 'BDUMP' FCB $D0 ; '5' FDB BLINE-8 BDUMP FDB DOCOL FDB CR,XDO BDUMPL FDB I,LIT8 FCB 4 FDB XDOTR,LIT8 FCB $3A FDB EMIT,SPACE FDB I,BLINE,CR,LIT8 FCB 4 FDB XPLOOP FDB BDUMPL-*-NATWID FDB SEMIS * * ======>> XX << * ( --- ) * Mostly for place holding (fig Forth). FCB $84 FCC 'NOO' ; 'NOOP' FCB $D0 FDB BDUMP-8 NOOP FDB *+NATWID RTS * Without the RTS, would misalign the stack. * NOOP NEXT a useful no-op ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program PAGE * These things, up through the lable 'REND', are overwritten * at time of cold load and should have the same contents * as shown here: * * This can be moved whereever the bottom of the * user's dictionary is going to be put. * RBEG EQU * FCB $C5 immediate FCC 'FORT' ; 'FORTH' FCB $C8 FDB NOOP-7 FORTH FDB DODOES,DOVOC,$81A0,TASK-7 FDB 0 * FCC "Copyright 1979 Forth Interest Group, David Lion," FCB $0D FCC "Parts Copyright 2019 Joel Matthew Rees" FCB $0D * FCB $84 FCC 'TAS' ; 'TASK' FCB $CB FDB FORTH-8 TASK FDB DOCOL,SEMIS * REND EQU * ( first empty location in dictionary ) RSIZE EQU *-RBEG ; So we can look at it. PAGE ORG RAMDSK * "0 1 2 3 4 5 6 " ; * "0123456789012345678901234567890123456789012345678901234567890123" ; FCC " 0) Index page " ; 0 FCC " 1) empty line on line 1 of screen 0 block 0 " ; 1 FCC " 2) Title and copyright " ; 2 FCC " 3) empty line on line 3 of screen 0 block 0 " ; 3 FCC " 4) Error messages 1st screen " ; 4 FCC " 5) Error messages 2nd screen " ; 5 FCC " 6) empty line 3 screen 0 block 1 " ; 6 FCC " 7) empty line 4 " ; 7 FCC " 8) and line 1 of block 2 " ; 8 FCC " 9) line 2 of block 2 screen 0 is pretty much empty too " ; 9 FCC " 10) listen to this. Line three of block two is too " ; 10 FCC " 11) and so is line 4 4 4 4 4 4 4 4 4 4 b2s0 " ; 11 FCC " 12) screen zero block three first line " ; 12 FCC " 13) second line fourth block (block three) screen 0 " ; 13 FCC " 14) block three screen zero line 3 3 3 3 3 3 3 3 3 " ; 14 FCC " 15) fourth line block three screen 0 0 0 0 0 0 0 0 0 0 " ; 15 * "0 1 2 3 4 5 6 " ; * "0123456789012345678901234567890123456789012345678901234567890123" ; FCC " test 10 b0s1 aaaa " ; 0 FCC " test 11 b0s1 ee ee ee ee " ; 1 FCC " test 12 b0s1 oo oo oo oo oo " ; 2 FCC " test 13 b0s1 eh ehe he eh eh " ; 3 FCC " ( block 1 ) b1s1 oh ohoo oh oh oh " ; 4 FCC " 15 test b1s1 " ; 5 FCC " 16 test b1s1 " ; 6 FCC " 17 test b1s1 " ; 7 FCC " 18 test b2s1 " ; 8 FCC " 19 test b2s1 " ; 9 FCC " 1A test b2s1 " ; 10 FCC " 1B test b2ws1 " ; 11 FCC " 1C test b3s1 " ; 12 FCC " 1D test b3s1 " ; 13 FCC " 1e this completes our second screen b3s1 " ; 14 FCC " 1F test b3s1 " ; 15 * "0 1 2 3 4 5 6 " ; * "0123456789012345678901234567890123456789012345678901234567890123" ; FCC " " ; 0 FCC " fig Forth High Level Model Code " ; 1 FCC " " ; 2 FCC " Copyright 2018 Joel Matthew Rees " ; 3 FCC " ( block 2 ) " ; 4 FCC " " ; 5 FCC " " ; 6 FCC " " ; 7 FCC " " ; 8 FCC " " ; 9 FCC " " ; 10 FCC " " ; 11 FCC " " ; 12 FCC " " ; 13 FCC " " ; 14 FCC " " ; 15 * "0 1 2 3 4 5 6 " ; * "0123456789012345678901234567890123456789012345678901234567890123" ; FCC " " ; 0 FCC " " ; 1 FCC " " ; 2 FCC " " ; 3 FCC " ( block 3 ) " ; 4 FCC " " ; 5 FCC " " ; 6 FCC " " ; 7 FCC " " ; 8 FCC " " ; 9 FCC " " ; 10 FCC " " ; 11 FCC " " ; 12 FCC " " ; 13 FCC " " ; 14 FCC " " ; 15 * "0 1 2 3 4 5 6 " ; * "0123456789012345678901234567890123456789012345678901234567890123" ; FCC " " ; 0 FCC " " ; 1 FCC " " ; 2 FCC " " ; 3 FCC " ( block 4 ) " ; 4 FCC " " ; 5 FCC " " ; 6 FCC " " ; 7 FCC " " ; 8 FCC " " ; 9 FCC " " ; 10 FCC " " ; 11 FCC " " ; 12 FCC " " ; 13 FCC " " ; 14 FCC " " ; 15 * "0 1 2 3 4 5 6 " ; * "0123456789012345678901234567890123456789012345678901234567890123" ; FCC " ( ERROR MESSAGES ) " ; 0 FCC " DATA STACK UNDERFLOW " ; 1 FCC " DICTIONARY FULL " ; 2 FCC " ADDRESS RESOLUTION ERROR " ; 3 FCC " HIDES DEFINITION IN " ; 4 FCC " " ; 5 FCC " " ; 6 FCC " " ; 7 FCC " " ; 8 FCC " " ; 9 FCC " " ; 10 FCC " " ; 11 FCC " " ; 12 FCC " " ; 13 FCC " " ; 14 FCC " " ; 15 * "0 1 2 3 4 5 6 " ; * "0123456789012345678901234567890123456789012345678901234567890123" ; FCC " more test data 2 3 4 5 6 " ; 0 FCC "0123456789012345678901234567890123456789012345678901234567890123" ; 1 FCC "Test data for the RAM disc emulator buffers. " ; 2 FCC " " ; 3 FCC " ( block 6 ) " ; 4 FCC " " ; 5 FCC " " ; 6 FCC " " ; 7 FCC " " ; 8 FCC " " ; 9 FCC " " ; 10 FCC " " ; 11 FCC " " ; 12 FCC " " ; 13 FCC " " ; 14 FCC " end" ; 15 RAMDND EQU * PAGE OPT L END