From 5ae2128e57e528c48f0b757c4e44f39ec7113200 Mon Sep 17 00:00:00 2001 From: Joel Matthew Rees Date: Tue, 5 Feb 2019 17:39:56 +0900 Subject: [PATCH] moving to non-rts mode to try to ferret out a Long lasting bug that disappears when debugging, probably stack related. Maybe. Optinal approach might be to synthesize a temporaries stack using a direct-page variable. --- commands.text | 11 +- fig-forth-auto6809.asm | 5790 +++++++++++++++++++++++++++++++++++++++++++++ fig-forth-auto6809opt.asm | 268 ++- 3 files changed, 6013 insertions(+), 56 deletions(-) create mode 100644 fig-forth-auto6809.asm diff --git a/commands.text b/commands.text index 57c1dd6..c5437e1 100644 --- a/commands.text +++ b/commands.text @@ -7,7 +7,7 @@ imgtool put coco_jvc_rsdos figauto6809opt.dsk figao09.bin FIGAO09.BIN imgtool put coco_jvc_rsdos workfig.dsk a.out FIG.BIN -../lwtools-4.14/lwasm/lwasm --list=fig-forth-auto6809opt.list fig-forth-auto6809opt.asm +../../lwtools-4.14/lwasm/lwasm --list=fig-forth-auto6809opt.list fig-forth-auto6809opt.asm ../lwtools-4.14/lwasm/lwasm --list=figao.list figao.asm for name in bif-6809lw/*.ASM ; do echo $name :\\n ; cat $name | tr '\r' '\n' | grep "BACK" ; done @@ -16,14 +16,16 @@ for name in bif-6809lw/*.ASM ; do echo $name :\\n ; cat $name | tr '\r' '\n' | xroar-0.34.7/src/xroar -machine coco2bus -bas roms/Color\ Basic\ v1.3\ \(1982\)\(Tandy\).rom -extbas roms/Extended\ Colour\ Basic\ v1.0\ \(1981\)\(Tandy\)/coco.rom -cart rsdos -cart-rom roms/Color\ Computer\ Controller\ \(1982\)\ \(26-3022\).rom -keymap us -kbd-translate +git push reiisi@git.osdn.net:/gitroot/fig-forth-6809/fig-forth-6809.git + hex -: bemit dup bl < +: bemit dup bl < over 7f < 0= or if drop 2e endif emit ; -: x.r base @ swap hex .r base ! ; +: x.r base @ >r hex .r r> base ! ; : bline @@ -31,8 +33,9 @@ dup 4 + over do i c@ 3 x.r loop space space dup 4 + swap do -i c@ bout loop ; +i c@ bemit loop ; : bdump cr do i 4 x.r 3a emit space i bline cr 4 +loop ; + diff --git a/fig-forth-auto6809.asm b/fig-forth-auto6809.asm new file mode 100644 index 0000000..c377273 --- /dev/null +++ b/fig-forth-auto6809.asm @@ -0,0 +1,5790 @@ + OPT PRT + +* fig-FORTH FOR 6809 +* ASSEMBLY SOURCE LISTING + +* RELEASE 0 +* JAN 2019 +* WITH COMPILER SECURITY +* AND VARIABLE LENGTH NAMES +* +* 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 +* +* +* +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 + BLT ZBYES ; signed +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 + BGT ZBYES ; signed + BRA XLOOPN ; This path is 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 +* + 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 diff --git a/fig-forth-auto6809opt.asm b/fig-forth-auto6809opt.asm index bb43beb..c377273 100644 --- a/fig-forth-auto6809opt.asm +++ b/fig-forth-auto6809opt.asm @@ -463,8 +463,8 @@ 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 +* 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.) @@ -480,7 +480,7 @@ NEXT3 ; W is X until you use X for something else. (TOS points back here.) * ; but X must be bumped NATWID to the parameters. * NOP * JMP TRACE ( an alternate for the above ) - BSR DBGREG ( 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. @@ -1455,25 +1455,39 @@ CR FDB *+NATWID FCB $C5 FDB CR-5 CMOVE FDB *+NATWID - PSHS Y ; +* 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 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 R-4 + FDB LNOT-6 ZEQU FDB *+NATWID LDD #0 LDX ,U @@ -2544,7 +2554,7 @@ LIMIT FDB DOCON * ( --- sectorsize ) * The size, in bytes, of a buffer control region. FCB $85 - FCC 'B/CTL' ; 'B/CTL' : (bytes/control region) + FCC 'B/CT' ; 'B/CTL' : (bytes/control region) FCB $CC FDB LIMIT-8 BCTL FDB DOCON @@ -3737,7 +3747,7 @@ QSTAC3 FDB SEMIS 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 LIT,$1C,SHOTOS ; DBG FDB DUP,LIT8 FCB BACKSP-ORIG FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing @@ -4565,31 +4575,93 @@ PREV FDB DOCON * 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 PBUF2-*-NATWID +* 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 PBUF-7 -UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE + 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 +* + 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 << @@ -4613,7 +4685,8 @@ DRZERO FDB DOCOL,ZERO,OFSET,STORE FCC 'DR' ; 'DR1' FCB $B1 FDB DRZERO-6 -DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE +DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE +; **** hard-codes the size of the disc !!!! FDB SEMIS * * ######>> screen 59 << @@ -4639,7 +4712,7 @@ BUFFR2 FDB PBUF,ZBRAN FDB ZBRAN FDB BUFFR3-*-NATWID * FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW - FDB R,NATP,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 @@ -4790,9 +4863,9 @@ PKEY PSHS Y,U,DP ; Must save everything important for this one. LDB ,X ; save glyph STA ,X PKEYLP JSR [$A000] - STA $41A ; DBG! +* STA $41A ; DBG! BEQ PKEYLP - STD $418 ; DBG! +* STD $418 ; DBG! STB ,X ; restore PKEYR CLRB ; for the break flag, shares code with PQTER CMPA #3 ; break key @@ -4899,7 +4972,8 @@ BREAD FDB *+NATWID JMP NEXT * *The next 3 words are written to create a substitute for disc -* mass memory,located between $3210 & $3FFF in ram. +* mass memory,located between MASSLO & MASSHI in ram -- +* ($3210 and $3fff in the 6800 model). * ======>> 190.1 << FCB $82 FCC 'L' ; 'LO' @@ -5584,11 +5658,101 @@ RSIZE EQU *-RBEG ; So we can look at it. ORG RAMDSK * "0 1 2 3 4 5 6 " ; * "0123456789012345678901234567890123456789012345678901234567890123" ; - FCC "HEX ( THIS IS SOME TEST STUFF. ) " ; 0 - FCC ": STAR 42 EMIT ; ( With some randome comments. ) " ; 1 - FCC ": STARS 0 DO I EMIT LOOP ; ;S " ; 2 + 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 " " ; 4 + 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 @@ -5606,7 +5770,7 @@ RSIZE EQU *-RBEG ; So we can look at it. FCC "0123456789012345678901234567890123456789012345678901234567890123" ; 1 FCC "Test data for the RAM disc emulator buffers. " ; 2 FCC " " ; 3 - FCC " " ; 4 + FCC " ( block 6 ) " ; 4 FCC " " ; 5 FCC " " ; 6 FCC " " ; 7 -- 2.11.0