--- /dev/null
+ OPT LIST,SYMTAB\r
+ MACHINE MC68000\r
+ OPT DEBUG\r
+ OUTPUT\r
+* fig-FORTH FOR 68000\r
+* ASSEMBLY SOURCE LISTING\r
+\r
+* RELEASE 0\r
+* JAN-FEB 2023\r
+* WITH COMPILER SECURITY\r
+* AND VARIABLE LENGTH NAMES\r
+* Try again with literal subroutine substitution mode, one step at a time.\r
+*\r
+* Adapted by Joel Matthew Rees \r
+* from fig-FORTH for 6800 (via buggy fig-FORTH for 6809) by Dave Lion, et. al.\r
+\r
+* This free/libre/open source publication is provided\r
+* through the courtesy of:\r
+* FORTH\r
+* INTEREST\r
+* GROUP\r
+* fig\r
+* and other interested parties.\r
+\r
+* Ancient address:\r
+* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668\r
+* URL: http://www.forth.org\r
+* Further distribution must include this notice.\r
+ PAGE\r
+ TTL Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees\r
+* OPT NOG,PAG\r
+* filename fig-forth-hand68000.asm\r
+* === FORTH-68000 {date} {time}\r
+\r
+\r
+* Permission is hereby granted, free of charge, to any person obtaining a copy\r
+* of this software and associated documentation files (the "Software"), to deal\r
+* in the Software without restriction, including without limitation the rights\r
+* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell\r
+* copies of the Software, and to permit persons to whom the Software is\r
+* furnished to do so, subject to the following conditions:\r
+*\r
+* The above copyright notice and this permission notice shall be included in\r
+* all copies or substantial portions of the Software.\r
+\r
+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR\r
+* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,\r
+* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE\r
+* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER\r
+* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,\r
+* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN\r
+* THE SOFTWARE.\r
+*\r
+* "Associated documentation" for this declaration of license\r
+* shall be interpreted to include only the comments in this file,\r
+* or, if the code is split into multiple files,\r
+* all files containing the complete source.\r
+* \r
+* This is the MIT model license, as published by the Open Source Consortium,\r
+* with associated documentation defined.\r
+* It was chosen to reflect the spirit of the original \r
+* terms of use, which used archaic legal terminology.\r
+*\r
+* Authors of the 6800 model:\r
+* === Primary: Dave Lion,\r
+* === with help from\r
+* === Bob Smith,\r
+* === LaFarr Stuart,\r
+* === The Forth Interest Group\r
+* === PO Box 1105\r
+* === San Carlos, CA 94070\r
+* === and\r
+* === Unbounded Computing\r
+* === 1134-K Aster Ave.\r
+* === Sunnyvale, CA 94086\r
+*\r
+ PAGE\r
+\r
+*********\r
+* NOTICE! the fig Forth model has problems, \r
+* including known bugs and unknown, \r
+* and including vulnerabilities.\r
+*\r
+* While it might be used to bootstrap more correct and secure systems,\r
+* it should be primarily used for study, practice, and research.\r
+*********\r
+\r
+* Some processor-specific stuff:\r
+NATWID EQU 4 ; bytes per natural integer/pointer\r
+* The assembler ought to have defined these, but I don't see them in the manual:\r
+* User program condition codes:\r
+F_CARY EQU $0001\r
+F_OVER EQU $0002\r
+F_ZERO EQU $0004\r
+F_NEG EQU $0008\r
+F_EXT EQU $0010\r
+* System status flags (68000/68010/CPU32):\r
+F_SYS EQU $2000\r
+F_TRAC EQU $8000\r
+* Ignoring the interrupt flags for now\r
+*\r
+* The original version was developed on an AMI EVK 300 PROTO\r
+* system using an ACIA for the I/O.\r
+* This version is developed targeting the Atar ST.\r
+\r
+* All terminal 1/0\r
+* is done in three subroutines:\r
+* PEMIT ( word # 182 )\r
+* PKEY ( 183 )\r
+* PQTERM ( 184 )\r
+*\r
+* The FORTH words for disc related I/O follow the model\r
+* of the FORTH Interest Group, but have not yet been\r
+* tested using a real disc.\r
+*\r
+* Addresses in the 6800 implementation reflect the fact that,\r
+* on the development system, it was convenient to\r
+* write-protect memory at hex 1000, and leave the first\r
+* 4K bytes write-enabled. As a consequence, code from\r
+* location $1000 to label ZZZZ could be put in ROM.\r
+* Minor deviations from the model were made in the\r
+* initialization and words ?STACK and FORGET\r
+* in order to do this.\r
+*\r
+* Those definitions will be altered somewhat in this \r
+* implementation for the 68000 -- Atari ST.\r
+* \r
+ PAGE\r
+* MEMORY MAP for this approximately 128K system:\r
+* ( arranged for systems with high-memory ROM/write-protect )\r
+*\r
+* Won't be using the ACIA directly, no need to define addresses.\r
+* ACIAC EQU $XXXXXXXX the ACIA control address and\r
+* ACIAD EQU ACIAC+1 data address for PROTO\r
+*\r
+* Moving the definitions of the memory area since the usual 68000 assemblers are \r
+* so kind as to make sure that definitions dependent on negative offsets and such\r
+* are not supported as ORG arguments, etc.\r
+*\r
+* These will be defined elsewhere:\r
+*\r
+* NBLK EQU 4 # of disc buffer blocks for virtual memory\r
+* MEMEND EQU 132*NBLK+ENDofCODE end of ram\r
+* each block is 132 bytes in size,\r
+* holding 128 characters\r
+*\r
+* MEMTOP EQU $WAYupHIGH absolute end of all ram\r
+* MEMORY MAP for this 16K system:\r
+* ( positioned so that systems with 4k byte write-\r
+* protected segments can write protect FORTH )\r
+*\r
+* addr. contents pointer init by\r
+* **** ******************************* ******* ******\r
+* MEMTOP HI\r
+* substitute for disc mass memory\r
+* MEMEND LO\r
+* MEMEND-1\r
+* 4 buffer sectors of VIRTUAL MEMORY\r
+* ENDofCODE+1 FIRST\r
+* >>>>>> memory from here up must be RAM <<<<<<\r
+*\r
+* ENDofCODE\r
+* >>>>>>--------Two words to start RAMmable dictionary--------<<<<<<\r
+*\r
+* ~12k of romable "FORTH" <== IP ABORT\r
+* <== W\r
+* the VIRTUAL FORTH MACHINE\r
+*\r
+* ENTRY+4 <<< WARM START ENTRY >>>\r
+* ENTRY <<< COLD START ENTRY >>>\r
+*\r
+* >>>>>> memory from here down must be RAM <<<<<<\r
+* IRP RETURN STACK base <== RP RINIT\r
+*\r
+* SFTBND\r
+* INPUT LINE BUFFER\r
+* holds up to 132 characters\r
+* and is scanned upward by IN\r
+* starting at TIB\r
+* ITIB <== IN TIB\r
+* IPSP DATA STACK <== SP SP0,SINIT\r
+* | grows downward from here\r
+* v\r
+* - -\r
+* ^\r
+* | DICTIONARY grows upward\r
+* \r
+* These two entries will be copied from the end of the "ROMmable" dictionary\r
+* into the bottom of the "RAMmable" dictionary area to link the two parts together.\r
+* \r
+* end of ram-dictionary. <== DP DPINIT\r
+* "TASK"\r
+*\r
+* "FORTH" ( a word ) <=, <== CONTEXT\r
+* `==== CURRENT\r
+* start of RAM dictionary area.\r
+*\r
+* RTDICT+(something) "FORTH" ( definition ) <=, <== CONTEXT\r
+* `==== CURRENT\r
+* RTDICT start of ram-dictionary.\r
+*\r
+* USERSP user #1 table of variables <= UP DPINIT\r
+* --- No need for registers & pointers for the virtual machine\r
+* No need for scratch area used by various words\r
+* --- lowest address used by FORTH\r
+* Linker/loader structures produced by assembler and linker\r
+* CODEBEG\r
+* >>>>>> memory from here down left alone <<<<<<\r
+* >>>>>> so we can safely call ROM routines <<<<<<\r
+*\r
+* UNK don't care stuff, if anything\r
+*\r
+* $400\r
+* EXCVCT 68000 exception vectors\r
+* 0000==RSTVCT\r
+\r
+ PAGE\r
+\r
+* ORG $30000 ; Not on the Atari ST under EMUTOS.\r
+\r
+* Edit this according to the desired size for the dictionary.\r
+RTDCSZ EQU 8*1024 ; Must be even on 68000. For now, keep total size under 32K.\r
+\r
+* This should be adjusted to the target:\r
+* CODEBG EQU $800\r
+CODEBG EQU * ; On the Atari ST, the assembler should determine this.\r
+*\r
+* per-task (per-user) tables\r
+USERAL EQU 64*NATWID ; allocatable\r
+USERCT EQU 4 ; maybe, someday?\r
+*\r
+* USERSP EQU * ; (task-local variable space, addressable by UP) ; NOPE!\r
+USERSP EQU USERAL*USERCT ; (task-local variable space, addressable by UP)\r
+* IUP EQU USERSP ; USERSZ*USERCT ; Nope!\r
+* The per-user (or task-local) table definitions are moved to the end \r
+* to avoid using BSS segments, because I don't know how well they are \r
+* supported in various 68K assemblers.\r
+\r
+* This system is built for one "user", or task, \r
+* but additional users (tasks) may be added\r
+* by allocating additional user tables.\r
+*\r
+* Some of this stuff gets initialized during\r
+* COLD start and WARM start:\r
+* [ names correspond to FORTH words of similar (no X) name ]\r
+*\r
+* A few useful VM variables --\r
+* Will be removed when they are no longer needed.\r
+* All are replaced by 68000 registers.\r
+\r
+* The Atari apparently wants the beginning of the image to be a jump to the entry point.\r
+* Put a jump around stuff here, anyway.\r
+START:\r
+* MOVE.L #ORIG-SURPRISE,D7\r
+* SURPRISE:\r
+* JMP (PC,D7) ; monku monku mutter mutter mumble mumble butsu butsu\r
+ JMP ORIG ; In case the distance is greater than 32K.\r
+* And this is why people don't understand true position independent coding.\r
+RSRV DS.L 8\r
+N DS.L 8 ; might be used as scratch if we really needed it.\r
+\r
+* These locations could be used by a TRACE routine :\r
+TRLIM DS.W 1 ; the count for tracing without user intervention\r
+TRACEM DS.W 1 ; non-zero = trace mode\r
+BRKPT DS.L 1 ; the breakpoint address at which\r
+* the program will go into trace mode\r
+VECT DS.L 1 ; vector to machine code\r
+* (only needed if the TRACE routine is resident)\r
+\r
+* Registers used by the FORTH virtual machine:\r
+* Starting at $OOFO in the 6800, unneeded here:\r
+*\r
+* All of these are defined below, with explanation.\r
+* W RMB NATWID ; the instruction register remembers IP.\r
+* IP RMB NATWID ; the instruction pointer points to pointer to 6800 code\r
+* RP RMB NATWID ; the return stack pointer\r
+* PSP RMB NATWID ; the parameter stack pointer (Forth SP)\r
+* UP RMB NATWID ; the pointer to base of current user's 'USER' table\r
+* ( altered by a task switch )\r
+*\r
+GAP EQU *\r
+ DS.B USERAL-(GAP-START)\r
+*\r
+UORIG DS.L 3 ; 3 reserved variables\r
+XSPZER DS.L 1 ; initial top of data stack for this user\r
+XRZERO DS.L 1 ; initial top of return stack\r
+XTIB DS.L 1 ; start of terminal input buffer\r
+XWIDTH DS.L 1 ; name field width ****** could be byte\r
+XWARN DS.L 1 ; warning message mode (0 = no disc) ****** could be byte\r
+XFENCE DS.L 1 ; fence for FORGET\r
+XDICTP DS.L 1 ; dictionary pointer\r
+XVOCL DS.L 1 ; vocabulary linking\r
+XBLK DS.L 1 ; disc block being accessed\r
+XIN DS.L 1 ; scan pointer into the block ****** could be 16-bit\r
+XOUT DS.L 1 ; cursor position ****** could be 16-bit\r
+XSCR DS.L 1 ; disc screen being accessed ( O=terminal )\r
+XOFSET DS.L 1 ; disc sector offset for multi-disc\r
+XCONT DS.L 1 ; last word in primary search vocabulary\r
+XCURR DS.L 1 ; last word in extensible vocabulary\r
+XSTATE DS.L 1 ; flag for 'interpret' or 'compile' modes ****** could be byte?\r
+XBASE DS.L 1 ; number base for I/O numeric conversion ****** could be byte\r
+XDPL DS.L 1 ; decimal point place ****** could be 16-bit\r
+XFLD DS.L 1 ; conversion field ****** could be 16-bit\r
+XCSP DS.L 1 ; current stack position, for compile checks\r
+XRNUM DS.L 1 ; ****** could be 16-bit? \r
+XHLD DS.L 1 ; ****** could be 16-bit?\r
+XDELAY DS.L 1 ; carriage return delay count ****** could be byte\r
+XCOLUM DS.L 1 ; carriage width ****** could be 16-bit\r
+IOSTAT DS.L 1 ; last acia status from write/read ****** could be byte or 16-bit\r
+*\r
+* end of user table, start of (theoretical) common system variables\r
+*\r
+* These need to be moved to where they will be \r
+* initialized globals in variable space, not in the USER table.\r
+* Or, more accurately, need to be turned into monitored or semaphored resources.\r
+XUSE DS.L 1\r
+XPREV DS.L 1\r
+ DS.L 2 ( spares )\r
+*\r
+XUCURR DS.L 1 ; user table current allocation\r
+*\r
+XDEF EQU *\r
+ DS.B USERAL-(XDEF-UORIG) ; allocatable\r
+*\r
+*USERSZ EQU *-UORIG\r
+ DS.B USERAL*(USERCT-1)\r
+*\r
+ PAGE\r
+***** Need to come back to these later.\r
+VOCFLG EQU $832020A0 ; flag (dummy) entry to switch vocabularies by.\r
+* These things, up through the label 'REND', are overwritten\r
+* at time of cold load and should have the same contents\r
+* as shown here:\r
+*\r
+ EVEN\r
+RBEG EQU *\r
+ DC.B $C5 immediate\r
+ DC.B 'FORT' ; 'FORTH'\r
+ DC.B 'H'|$80\r
+ DC.L NOOP-5-NATWID\r
+FORTH: DC.L DODOES,DOVOC,VOCFLG,TASK-5-NATWID\r
+ DC.L 0\r
+*\r
+ DC.B "Copyright 1979 Forth Interest Group, David Lion,"\r
+ DC.B $0D\r
+ DC.B "Parts Copyright 2019 Joel Matthew Rees"\r
+ DC.B $0D\r
+*\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'TAS' ; 'TASK'\r
+ DC.B 'K'|$80\r
+ DC.L FORTH-6-NATWID\r
+TASK: DC.L DOCOL,SEMIS\r
+* \r
+REND EQU * ( first empty location in dictionary )\r
+RSIZE EQU *-RBEG ; So we can look at it.\r
+ PAGE\r
+***\r
+*\r
+* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :\r
+*\r
+* IP points to the next FORTH VM instruction ( pre-increment mode )\r
+IP EQUR A5 ; post-inc mode, as opposed to 6800 model.\r
+* RP points to last return address pushed on return stack\r
+RP EQUR A7 ; Yes, we are going to break with fig false traditions.\r
+* PSP points to last item pushed on data (parameter) stack\r
+PSP EQUR A6 ; SP is already defined as A7 on 68K.\r
+* may conflict with using A6 as frame pointer? Not really.\r
+* Note that 6800 S points one below last byte pushed. We don't have to do that.\r
+*\r
+* A5 must be IP when NEXT is entered (when using the inner loop).\r
+*\r
+* D0 handles all of what is A:B on 6801/6809.\r
+*\r
+* UP (could be DP on 6809) is the base of per-task ("user") variables.\r
+UP EQUR A3\r
+* (Be careful of the stray semantics of "user".)\r
+*\r
+* W (hardware X) is the pointer to the "code field" address of native CPU\r
+* But W is now ephemeral, maybe in VEC, but always top of return stack at entry.\r
+W EQUR A4 \r
+* Points to pointer to machine code to be executed for the definition \r
+* of the dictionary word to be executed/currently executing.\r
+* The following natural integer (word) begins any "parameter section" \r
+* (body) -- similar to a "this" pointer, but not the same.\r
+* It may be native CPU machine code, or it may be a global variable, \r
+* or it may be a list of Forth definition words (addresses).\r
+*\r
+* Since we have it, give it a handle. The execute vector:\r
+* (Only valid until used elsewhere.)\r
+VEC EQUR A2\r
+*\r
+* A0 and A1 used as scratch indexes.\r
+* D0 through D7 used as scratch registers.\r
+* Some related routines (for example, LOOP) use D0 as a shared parameter.\r
+*\r
+* Except that I want to keep this close to the fig model:\r
+** We've got the registers, might as well use 'em.\r
+** Defined for the I-level loop variables:\r
+* LUPLIM EQUR D5 ; limit was pushed first, \r
+* LUPCT EQUR D4 ; then index/count\r
+** J-level is on the return stack.\r
+*\r
+* ======\r
+* This implementation uses the indirect subroutine architecture \r
+* -- a postponed-push call that the 6800 model VM also uses\r
+* to save code and time in leaf routines. \r
+*\r
+* It won't allow mixing assembly language directly into Forth word lists.\r
+* ======\r
+*\r
+* boolean flags:\r
+* 0 is false, anything else is true.\r
+* Most places in this model that set a boolean flag set true as 1.\r
+* This is in contrast to many models that set a boolean flag as -1.\r
+*\r
+***\r
+\r
+* The run-time dictionary allocation area begins here, \r
+* initialized with the FORTH and TASK definitions that will be \r
+* actually used.\r
+\r
+RTDICT DS.B RTDCSZ ; dictionary allocation space\r
+*\r
+PSPSPC EQU 256*NATWID ; for the parameter stack\r
+ DS.B PSPSPC\r
+SPBUMP EQU 4*NATWID\r
+IPSP DS.L SPBUMP ; initial PSP below, bumper zone above\r
+*\r
+* Don't want terminal input and parameter underflow collisions\r
+TIBSZ EQU 80 ; bytes of input buffer, must be even on 68000.\r
+ITIB DS.B TIBSZ ; Also, must match terminal width. (Bad design.)\r
+*\r
+* *** This is quite clearly a vulnerability! ***\r
+SFTBND EQU * ; (pseudo boundary between TIB and return stack)\r
+*\r
+RPSPAC EQU 128*NATWID ; for the return stack\r
+ DS.B RPSPAC\r
+RPBUMP EQU 4*NATWID\r
+IRP DS.B RPBUMP ; initial RP below, bumper zone above\r
+\r
+ PAGE\r
+* Expecting 8K to 12K for the kernel, because pointers are 4 bytes.\r
+VMBASE EQU *\r
+\r
+* "ROMmable" init tables and pre-compiled dictionary\r
+*\r
+* The FORTH interpreter will be organized\r
+* so that it can be in a ROM, or write-protected if desired,\r
+* but right now we're just getting it running.\r
+\r
+* ######>> screen 3 <<\r
+*\r
+***************************\r
+** C O L D E N T R Y **\r
+***************************\r
+*\r
+ORIG NOP\r
+ BRA.W CENT ; ROMmable dictionary size is less than 32K\r
+***************************\r
+** W A R M E N T R Y **\r
+***************************\r
+ NOP\r
+ BRA.W WENT warm-start code, keeps current dictionary intact\r
+\r
+*\r
+MAXNML EQU 32 ; max name length of words (symbols) in the dictionary\r
+NMLMSK EQU MAXNML-1 ; MAXNML must be a power of 2.\r
+******* startup parmeters **************************\r
+*\r
+ DC.L $68000,00000000 ; cpu & revision\r
+ DC.L 0 ; topmost word in FORTH vocabulary\r
+* BACKSP DC.L $7F ; backspace character for editing \r
+BACKSP DC.L $08 ; backspace character for editing \r
+UPINIT DC.L UORIG ; initial user area\r
+SINIT DC.L IPSP ; initial top of data stack\r
+RINIT DC.L IRP ; initial top of return stack\r
+ DC.L ITIB ; terminal input buffer\r
+IWIDTH DC.L MAXNML ; initial name field width\r
+ DC.L 0 ; initial warning mode (0 = no disc)\r
+FENCIN DC.L REND ; initial fence\r
+DPINIT DC.L REND ; cold start value for DICTPT\r
+BUFINT DC.L BUFBAS ; Start of the disk buffers area \r
+VOCINT DC.L FORTH+4*NATWID \r
+COLINT DC.L TIBSZ ; initial terminal carriage width\r
+DELINT DC.L 4 ; initial carriage return delay\r
+****************************************************\r
+*\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 13 <<\r
+* These are of questionable use anyway, \r
+* and are too much trouble to use with native subroutine call anyway.\r
+* POPD0X MOVE.L (PSP)+,D0 ; These may actually not end up being used.\r
+* STD0X MOVE.L D0,(A0)\r
+* BRA.S NEXT\r
+* GETX MOVE.L (A0),D0\r
+* PUSHD0 MOVE.L D0,-(PSP) ; fall through to NEXT\r
+\r
+* "NEXT" takes ?? cycles if TRACE is removed,\r
+*\r
+* and ?? cycles if trace is present and NOT tracing.\r
+*\r
+* = = = = = = = t h e v i r t u a l m a c h i n e = = = = =\r
+* =\r
+* NEXT itself might just completely go away.\r
+* About the only reason to keep it is to allow executing a list\r
+* which allows a cheap TRACE routine.\r
+*\r
+* NEXT is a loop which implements the Forth VM.\r
+* It basically cycles through calling the code out of code lists,\r
+* one at a time.\r
+* Using a native CPU return for this uses a few extra cycles per call,\r
+* compared to simply jumping to each definition and jumping back \r
+* to the known beginning of the loop,\r
+* but the loop itself is really only there for convenience,\r
+* in the first place.\r
+* \r
+* This implementation uses indirect threading,\r
+* leaving a wall between Forth VM code and non-Forth VM code.\r
+*\r
+NEXT: ; IP is a register.\r
+NEXT2 MOVE.L (IP)+,VEC ; IP is list of code pointers, W is now ephemeral (top of R at entry)\r
+* NEXT2 MOVE.L (IP)+,W ; get W which points to CFA of word to be done\r
+* NEXT3 MOVE.L (W)+,VEC ; get characteristic address, point to Parameter Field.\r
+* These NOPs can be patched at run-time to JMP TRACE =\r
+* if a TRACE routine is available: =\r
+* NOP = \r
+* NOP =\r
+* NOP =\r
+* NOP =\r
+* NOP =\r
+ TST.W TRACEM-UORIG(UP) =\r
+ BEQ.S NEXTJ =\r
+ BSR.W PTRACE =\r
+NEXTJ: JSR (VEC) =\r
+ BRA.S NEXT =\r
+* In other words, with the call and the NOP,\r
+* there is room to patch the loop with a call to your TRACE \r
+* routine, which you have to provide.\r
+* =\r
+* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =\r
+\r
+ PAGE\r
+*\r
+* ======>> 1 <<\r
+* ( --- n )\r
+* Pushes the following natural width integer from the instruction stream\r
+* as a literal, or immediate value.\r
+*\r
+* DC.L {OP}\r
+* DC.L {OP}\r
+* DC.L LIT\r
+* DC.L LITERAL-TO-BE-PUSHED\r
+* DC.L {OP}\r
+*\r
+* In native processor code, there should be a better way, use that instead.\r
+* More specifically, DO NOT CALL THIS from assembly language code.\r
+* (Note that there is no compile-only flag in the fig model.)\r
+*\r
+* See (FIND), or PFIND , for layout of the header format.\r
+*\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'LI' ; 'LIT' : NOTE: this is different from LITERAL\r
+ DC.B 'T'|$80 ; character code for T, with high bit set.\r
+ DC.L 0 ; link of zero to terminate dictionary scan\r
+*LIT DC.L *+NATWID ; Note also that LIT is meaningless in native code.\r
+* And, in fact, we simply should not be using it in this version.\r
+* But if we were to use it, it would look like this:\r
+LIT MOVE.L (IP)+,-(PSP)\r
+ RTS\r
+*\r
+* ######>> screen 14 <<\r
+* ======>> 2 <<\r
+* ( --- n )\r
+* Save a little dictionary space by pushing a half-width value as a full-width value.\r
+* LIT8 won't really work with the 68000 because of alignment problems,\r
+* but LIT16 will save a little space.\r
+* Pushes the following 16-bit word from the instruction stream\r
+* as a literal, or immediate value.\r
+*\r
+* If this is kept, it should have a header for TRACE to read.\r
+* If the data bus is wider than a byte, consider whether you want to do this.\r
+* Byte shaving like this is often counter-productive anyway.\r
+* Changing the name to LIT16, hoping that will be more understandable.\r
+* Also, see comments for LIT: DO NOT CALL THIS from assembly language code.\r
+* (Note that there is no compile-only flag in the fig model.)\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'LIT1' ; 'LIT16' ; half a LIT\r
+ DC.B '6'|$80\r
+ DC.L LIT-4-NATWID\r
+*LIT16 DC.L *+NATWID ; (this was an invisible word, with no header)\r
+* See comments on LIT. If we were to use it, it would look like this:\r
+LIT16 CLR.L -(PSP) ; The fig model does not sign extend.\r
+ MOVE.W (IP)+,NATWID/2(PSP)\r
+ RTS\r
+*\r
+* ======>> 3 <<\r
+* ( adr --- )\r
+* Jump to address on stack. Used by the "outer" interpreter to\r
+* interactively invoke routines. \r
+* Might be useful to have EXECUTE test the pointer, as done in BIF-6809.\r
+ EVEN\r
+ DC.B $87\r
+ DC.B 'EXECUT' ; 'EXECUTE'\r
+ DC.B 'E'|$80 ; $C5\r
+ DC.L LIT16-6-NATWID\r
+*EXEC DC.L *+NATWID\r
+* MOVE.L (PSP)+,W ; Get the adr parameter.\r
+* MOVE.L (W)+,VEC ; Or, pretend we are the inner interpreter\r
+EXEC MOVE.L (PSP)+,VEC ; The adr parameter now points directly to code.\r
+ JMP (VEC) ; tail return\r
+* \r
+*\r
+* ######>> screen 15 <<\r
+* ======>> 4 <<\r
+*\r
+* *** Since we are using NEXT (i-code lists), we are using BRANCH, et. al.\r
+\r
+* ( --- ) C\r
+* Add the following word from the instruction stream to the\r
+* instruction pointer (Y++). Causes a program branch in Forth code stream.\r
+*\r
+* In native processor code, there should be a better way, use that instead.\r
+* More specifically, DO NOT CALL THIS from assembly language code.\r
+* This is only for Forth code stream.\r
+* Also, see comments for LIT.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'BRANC' ; 'BRANCH'\r
+ DC.B 'H'|$80\r
+ DC.L EXEC-8-NATWID\r
+*BRAN DC.L *+NATWID\r
+*ZBYES: ; No more code stealing needed here.\r
+BRAN MOVE.L (IP)+,D1\r
+ LEA (IP,D1.L),IP ; IP is postinc\r
+ RTS\r
+* ======>> 5 <<\r
+* ( f --- ) C\r
+* BRANCH if flag is zero.\r
+*\r
+* In native processor code, there should be a better way, use that instead.\r
+* More specifically, DO NOT CALL THIS from assembly language code.\r
+* This is only for Forth code stream.\r
+* Also, see comments for LIT.\r
+ EVEN\r
+ DC.B $87\r
+ DC.B '0BRANC' ; '0BRANCH'\r
+ DC.B 'H'|$80\r
+ DC.L BRAN-7-NATWID\r
+*ZBRAN DC.L *+NATWID\r
+* No more code stealing needed here.\r
+*ZBRAN TST.L (PSP)+\r
+* BNE.S ZBNO\r
+*ZBYES MOVE.L (IP)+,D0\r
+* LEA (IP,D0.L),IP ; IP is postinc\r
+* RTS\r
+*ZBNO LEA NATWID(IP),IP ; No branch.\r
+* RTS\r
+ZBRAN MOVE.L (IP)+,D1 ; Grab offset and update IP first.\r
+ TST.L (PSP)+\r
+ BNE.S ZBNO\r
+ LEA (IP,D1.L),IP ; IP is postinc\r
+ZBNO RTS\r
+*\r
+\r
+* ######>> screen 16 <<\r
+\r
+* ======>> 6 <<\r
+* ( --- ) ( limit index *** limit index+1) C\r
+* ( limit index *** )\r
+* Counting loop primitive. The counter and limit are the top two\r
+* words on the return stack. If the updated index/counter does\r
+* not exceed the limit, a branch occurs. If it does, the branch\r
+* does not occur, and the index and limit are dropped from the\r
+* return stack.\r
+*\r
+* Loop words share the counter increment via D0.\r
+*\r
+* In native processor code, there should be a better way, use that instead.\r
+* More specifically, DO NOT CALL THIS from assembly language code.\r
+* This is only for Forth code stream.\r
+* Also, see comments for LIT.\r
+* D0 and various code paths are shared with XPLOOP.\r
+* Having to dodge the return address on the stack might be reason\r
+* for loop variables in registers, but not yet.\r
+LUPLIM EQU NATWID*2 ; limit was pushed first, \r
+LUPCT EQU NATWID ; then index/count\r
+* \r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B '(LOOP' ; '(LOOP)'\r
+ DC.B ')'|$80\r
+ DC.L ZBRAN-8-NATWID\r
+*XLOOP DC.L *+NATWID\r
+*XLOOP MOVEQ #1,D0 ; Loop counter and limit on return stack.\r
+*XLOOPA ADD.L LUPCT(RP),D0\r
+* MOVE.L D0,LUPCT(RP)\r
+* CMP.L LUPLIM(RP),D0\r
+* BMI.S ZBYES ; pseudo-signed-unsigned\r
+*XLOOPN LEA NATWID(IP),IP\r
+* MOVE.L (RP),A0 ; Get the return to NEXT.\r
+* LEA LUPLIM+NATWID(RP),RP ; drop loop control variables\r
+* JMP (A0)\r
+XLOOP MOVEQ #1,D0 ; Loop counter and limit on return stack.\r
+XLOOPA MOVE.L (IP)+,D1 ; Grab offset and update IP first.\r
+ ADD.L LUPCT(RP),D0\r
+ MOVE.L D0,LUPCT(RP)\r
+ CMP.L LUPLIM(RP),D0\r
+ BPL.S XLOOPN ; pseudo-signed-unsigned\r
+XLOOPY LEA (IP,D1.L),IP ; IP is postinc\r
+ RTS\r
+XLOOPN MOVE.L (RP),A0 ; Get the return to NEXT.\r
+ LEA LUPLIM+NATWID(RP),RP ; drop loop control variables, too\r
+ JMP (A0)\r
+*\r
+* Old notes for loop counter and limit in registers:\r
+* MOVEQ #1,D0 ; Loop counter and limit in registers.\r
+* XLOOPA ADD.L D0,LUPCT\r
+* CMP.L LUPLIM,LUPCT\r
+* BMI.S ZBYES ; pseudo-signed-unsigned\r
+* XLOOPN LEA NATWID(IP),IP\r
+* MOVEM.L (RP)+,LUPLIM/LUPCT ; restore possible outer loop controls\r
+* RTS \r
+*\r
+* ======>> 7 <<\r
+* ( n --- ) ( limit index *** limit index+n ) C\r
+* ( limit index *** )\r
+* Loop with a variable increment. Terminates when the index\r
+* crosses the boundary from one below the limit to the limit. A\r
+* positive n will cause termination if the result index equals the\r
+* limit. A negative n must cause the index to become less than\r
+* the limit to cause loop termination.\r
+*\r
+* Note that the end conditions are not symmetric around zero.\r
+*\r
+* In native processor code, there should be a better way, use that instead.\r
+* More specifically, DO NOT CALL THIS from assembly language code.\r
+* This is only for Forth code stream.\r
+* Also, see comments for LIT.\r
+* D0 and various code paths are shared with XLOOP.\r
+ EVEN\r
+ DC.B $87\r
+ DC.B '(+LOOP' ; '(+LOOP)'\r
+ DC.B ')'|$80\r
+ DC.L XLOOP-7-NATWID\r
+*XPLOOP DC.L *+NATWID ; Loop counter and limit in registers.\r
+XPLOOP MOVE.L (PSP)+,D0 ; inc val\r
+ BPL.S XLOOPA ; Steal plain loop code for forward count.\r
+ ADD.L LUPCT(RP),D0\r
+ MOVE.L D0,LUPCT(RP)\r
+ CMP.L LUPLIM(RP),D0\r
+ BPL.S XLOOPY ; pseudo-signed-unsigned\r
+ BRA.S XLOOPN ; Which path is less time-sensitive?\r
+*\r
+* Notes for loop counter and limit in registers:\r
+* MOVE.L (PSP)+,D0 ; inc val\r
+* BPL.S XLOOPA ; Steal plain loop code for forward count.\r
+* ADD.L D0,LUPCT\r
+* CMP.L LUPLIM,LUPCT\r
+* BPL.S ZBYES ; pseudo-signed-unsigned\r
+* BRA.S XLOOPN ; This path might be less time-sensitive.\r
+*\r
+* ######>> screen 17 <<\r
+* ======>> 8 <<\r
+* ( limit index --- ) ( *** outerlimit outerindex )\r
+* Save whatever is in limit and index registers, Load the loop parameters. \r
+* This would NOT be a synonym for D>R (2>R) if we were keeping the control variables in registers.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B '(DO' ; '(DO)'\r
+ DC.B ')'|$80\r
+ DC.L XPLOOP-8-NATWID\r
+*XDO DC.L *+NATWID ; This is the RUNTIME DO, not the COMPILING DO\r
+XDO MOVEM.L (PSP)+,D0/D1 ; MOVEM preserves the order.\r
+ MOVE.L (RP)+,A0 ; get the return to NEXT out of the way.\r
+ MOVEM.L D0/D1,-(RP) ; Control variables are now on the return stack.\r
+ JMP (A0) ; Back to NEXT\r
+*\r
+* Notes for loop counter and limit in registers:\r
+* MOVE.L (RP)+,A0 ; Get the reurn to NEXT out of the way\r
+* MOVEM.L LUPLIM/LUPCT,-(RP) ; save possible outer loop limit and count\r
+* MOVEM.L (PSP)+,LUPLIM/LUPCT ; limit must be higher register number to be deeper in stack. \r
+* JMP (A0) ; Back to NEXT\r
+*\r
+* ======>> 9 <<\r
+* ( --- index ) ( limit index *** limit index )\r
+* Copy the loop index from the index register. \r
+* This would NOT be a synonym for R if we were keeping the control variables in registers.\r
+ EVEN\r
+ DC.B $81\r
+ DC.B 'I'|$80 ; I\r
+ DC.L XDO-5-NATWID \r
+*I DC.L *+NATWID\r
+I MOVE.L LUPCT(RP),-(PSP) ; hide dodge in LUPCT\r
+ RTS\r
+*\r
+* Notes for loop counter and limit in registers:\r
+* MOVE.L LUPCT,-(PSP) ; nothing to dodge\r
+* RTS\r
+*\r
+* ######>> screen 18 <<\r
+* ======>> 10 <<\r
+* ( c base --- false )\r
+* ( c base --- n true )\r
+* Translate C in base, yielding a translation valid flag. \r
+* If the translation is not valid in the specified base,\r
+* only the false flag is returned.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'DIGI' ; 'DIGIT'\r
+ DC.B 'T'|$80\r
+ DC.L I-2-NATWID\r
+*DIGIT DC.L *+NATWID ; NOTE: legal input range is 0-9, A-Z\r
+DIGIT MOVE.L NATWID(PSP),D0 ; Check the whole 32 bits.\r
+ CMP.L #'Z',D0 ; Allow byte width from here.\r
+ BHI.S DIGITN\r
+ SUB.L #'0',D0 ; ascii zero\r
+ BLO.S DIGITN ; IF LESS THAN '0', ILLEGAL\r
+ CMP.B #9,D0\r
+ BLS.S DIGITB ; IF '9' OR LESS\r
+ SUB.B #'A'-('9'+1),D0 ; translate 'A' thru 'Z'\r
+ CMP.B #$A,D0 ; between '9' and 'A'?\r
+ BLO.S DIGITN ; if less than 'A'\r
+DIGITB CMP.B NATWID-1(PSP),D0 ; Check the base.\r
+ BHS.S DIGITN ; error if not less than the base\r
+ MOVE.L D0,NATWID(PSP) ; Store converted digit. (High bytes known zero.)\r
+ MOVE.L #1,(PSP) ; store valid flag \r
+ RTS\r
+DIGITN LEA NATWID(PSP),PSP ; pop base\r
+ MOVE.L #0,(PSP) ; set not valid flag\r
+ RTS\r
+*\r
+* ######>> screen 19 <<\r
+*\r
+* The word definition format in the dictionary:\r
+*\r
+* (Symbol names are bracketed by bytes with the high bit set, rather than linked.)\r
+*\r
+* EVEN address alignment on 68K.\r
+* Optional byte of zero for odd name fields on 68K.\r
+* NFA (name field address):\r
+* char-count + $80 Length of symbol name, flagged with high bit set.\r
+* char 1 Characters of symbol name.\r
+* char 2\r
+* ...\r
+* char n + $80 symbol termination flag (char set < 128 code points)\r
+* LFA (link field address):\r
+* link high byte \\r
+* ... inner byte \___pointer to previous word in list\r
+* ... inner byte / (List is combined allocation/dictionary list.)\r
+* link low byte /\r
+* The definition label is now the code field.\r
+* Code follows immediately after the allocation link.\r
+* When there is a parameter field, the code here is a branch to the characteristic code.\r
+* When the characteristic is near, use/look for BSR.W.\r
+* Figure out far/intermodule characteristics later.\r
+* A BSR.W is 16-bit op-code and 16-bit address == 32 bits, so --\r
+* PFA (parameter field address) is NATWID after the definition label in the near case:\r
+* parameter fields -- Machine code for low-level native machine CPU code starts at label,\r
+* " instruction list for high-level Forth code,\r
+* " constant data for constants, pointers to per task variables,\r
+* " space for variables, for global variables, etc.\r
+*\r
+* Note that CFA and PFA entanglement is now much tighter.\r
+\r
+* Definition attributes:\r
+FIMMED EQU $40 ; Immediate word flag.\r
+FSMUDG EQU $20 ; Smudged => definition not ready.\r
+CTMASK EQU ($FF&(~($80|FIMMED))) ; For unmasking the length byte.\r
+* Note that the SMUDGE bit is not masked out.\r
+*\r
+* But we really want more flags (Thinking for a new model, need one more byte):\r
+* FCOMPI EQU $10 ; Compile-time-only.\r
+* FASSEM EQU $08 ; Assembly-language code only.\r
+* F4THLV EQU $04 ; Must not be called from assembly language code.\r
+* These would require some significant adjustments to the model.\r
+* We also want to put the low-level VM stuff in its own vocabulary, eventually.\r
+*\r
+* ======>> 11 <<\r
+* (FIND) ( name vocptr --- locptr length true )\r
+* ( name vocptr --- false )\r
+* Search vocabulary for a symbol called name. \r
+* name is a pointer to a high-bit bracketed string with length head.\r
+* vocptr is a pointer to the NFA of the tail-end (LATEST) definition \r
+* in the vocabulary to be searched.\r
+* Hidden (SMUDGEd) definitions are lexically not equal to their name strings.\r
+* Use the stack and registers instead of temp area N.\r
+PA0 EQU NATWID ; pointer to the length byte of name being searched against\r
+YPA0 EQUR A2 ; ditto\r
+PD EQU 0 ; pointer to NFA of dict word being checked\r
+XPD EQUR A1 ; ditto\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B '(FIND' ; '(FIND)'\r
+ DC.B ')'|$80\r
+ DC.L DIGIT-6-NATWID\r
+*PFIND DC.L *+NATWID\r
+PFIND MOVE.L PD(PSP),XPD ; Start in on the vocabulary (NFA).\r
+PFNDLP MOVE.L PA0(PSP),YPA0 ; Point to the name to check against.\r
+ MOVE.B (XPD)+,D1 ; get dict name length byte\r
+ MOVE.B D1,D0 ; Save it in case it matches.\r
+ AND.B #CTMASK,D1 \r
+ CMP.B (YPA0)+,D1 ; Compare lengths\r
+ BNE.S PFNDUN\r
+PFNDBR MOVE.B (XPD)+,D1 ; Is high bit of character in dictionary entry set?\r
+ BPL.S PFNDCH\r
+ AND.B #$7F,D1 ; Clear high bit in char from dictionary.\r
+ CMP.B (YPA0)+,D1 ; Compare "last" characters.\r
+ BEQ.S PFOUND ; Matches even if dictionary actual length is shorter.\r
+PFNDLN MOVE.L (XPD)+,D0 ; Get previous link in vocabulary. (Note flag entry to switch vocabularies by.)\r
+ MOVE.L D0,XPD ; On 68K, flags not in effect for MOVEA, TST not available, and this is what we wanted.\r
+ BNE.S PFNDLP ; Continue if link not=0\r
+*\r
+* not found :\r
+ LEA NATWID(PSP),PSP ; Return only false flag.\r
+ CLR.L (PSP)\r
+ RTS\r
+*\r
+PFNDCH CMP.B (YPA0)+,D1 ; Compare characters.\r
+ BEQ.S PFNDBR\r
+PFNDUN:\r
+PFNDSC MOVE.B (XPD)+,D1 ; scan forward to end of this name in dictionary\r
+ BPL.S PFNDSC\r
+ BRA.S PFNDLN\r
+*\r
+* found :\r
+*\r
+PFOUND LEA 2*NATWID(XPD),XPD ; point to parameter field\r
+ MOVE.L XPD,NATWID(PSP)\r
+ CLR.L D1 ; make sure count is valid\r
+ MOVE.B D0,D1\r
+ MOVE.L D1,(PSP)\r
+ MOVEQ #1,D1 ; set a true flag\r
+ MOVE.L D1,-(PSP)\r
+ RTS\r
+*\r
+* ######>> screen 20 <<\r
+* ======>> 12 <<\r
+* ( buffer ch --- buffer symboloffset delimiteroffset scancount )\r
+* ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )\r
+* ( buffer ch --- buffer nuloffset onepast scancount )\r
+* Scan buffer for a symbol delimited by ch or ASCII NUL, \r
+* return the length of the buffer region scanned,\r
+* the offset to the trailing delimiter,\r
+* and the offset of the first character of the symbol. \r
+* Leave the buffer on the stack.\r
+* Scancount is also offset to first character not yet looked at.\r
+* If no symbol in buffer, scancount and symboloffset point to NUL\r
+* and delimiteroffset points one beyond for some reason. \r
+* On trailing NUL, delimiteroffset == scancount.\r
+* (Buffer is the address of the buffer array to scan.)\r
+* (This is a bit too tricky, really.)\r
+* NOTE :\r
+* FC means offset (bytes) to First Character of next word\r
+* EW " " to End of Word\r
+* NC " " to Next Character to start next enclose at\r
+ EVEN\r
+ DC.B $87\r
+ DC.B 'ENCLOS' ; 'ENCLOSE'\r
+ DC.B 'E'|$80\r
+ DC.L PFIND-7-NATWID\r
+*ENCLOS DC.L *+NATWID\r
+ENCLOS MOVE.B NATWID-1(PSP),D0 ; Delimiter character to match against in D0.\r
+ MOVE.L NATWID(PSP),A0 ; Buffer to scan in.\r
+ CLR.L D1 ; Initialize offset. (No particular limit on Buffer width.)\r
+* Scan to a non-delimiter or a NUL\r
+ENCDEL TST.B (A0,D1.W) ; NUL ?\r
+ BEQ.S ENCNUL\r
+ CMP.B (A0,D1.W),D0 ; Delimiter?\r
+ BNE.S ENC1ST\r
+ ADDQ.L #1,D1 ; count character\r
+ BRA.S ENCDEL\r
+* Found first character. Save the offset.\r
+ENC1ST MOVE.L D1,(PSP) ; Found first non-delimiter character -- store the count.\r
+* Scan to a delimiter or a NUL\r
+ENCSYM TST.B (A0,D1.W) ; NUL ?\r
+ BEQ.S ENC0TR\r
+ CMP.B (A0,D1.W),D0 ; delimiter?\r
+ BEQ.S ENCEND\r
+ ADDQ.L #1,D1\r
+ BRA.S ENCSYM\r
+* Found end of symbol. Push offset to delimiter found.\r
+ENCEND MOVE.L D1,-(PSP) ; Offset to seen delimiter.\r
+* Advance and push address of next character to check.\r
+ ADDQ.L #1,D1 ; one past \r
+ MOVE.L D1,-(PSP)\r
+ RTS\r
+* Found NUL before non-delimiter, therefore there is no word\r
+ENCNUL MOVE.L D1,(PSP) ; offset to NUL.\r
+ ADDQ.L #1,D1 ; Point after NUL to allow (FIND) to match it.\r
+ MOVE.L D1,-(PSP) ;\r
+ SUBQ.L #1,D1 ; Next is not passed NUL.\r
+ MOVE.L D1,-(PSP) ; Stealing code will save only one byte.\r
+ RTS\r
+* Found NUL following the word instead of delimiter.\r
+ENC0TR\r
+ MOVE.L D1,-(PSP) ; Save offset to first after symbol (NUL)\r
+ MOVE.L D1,-(PSP) ; and count scanned.\r
+ RTS\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 21 <<\r
+* The next 4 words call system dependant I/O routines\r
+* which are listed after word "-->" ( label: "arrow" )\r
+* in the dictionary.\r
+*\r
+* ======>> 13 <<\r
+* ( c --- )\r
+* Write c to the output device (screen or printer).\r
+******* Need to write this for the ST ROM BIOS.\r
+******* Probably want to go ahead and define PEMIT, PKEY, PQTER, and PCR.\r
+******* Also might want to tune UORIG variable sizes.\r
+******* Need to find a way to set default operand size to Long.\r
+* ROM Uses the ECB device number at address $6F,\r
+* -2 is printer, 0 is screen.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'EMI' ; 'EMIT'\r
+ DC.B 'T'|$80\r
+ DC.L ENCLOS-8-NATWID\r
+*EMIT DC.L *+NATWID\r
+EMIT MOVE.L (PSP)+,D1\r
+ BSR.W PEMIT ; PEMIT expects the character in D1.\r
+ ADDQ.L #1,XOUT-UORIG(UP) ; Bump the output count.\r
+EMITDN RTS\r
+*\r
+* ======>> 14 <<\r
+* ( --- c )\r
+* ( --- BREAK )\r
+* Wait for a key from the keyboard. \r
+* If the key is BREAK, set the high byte (result $FF03).\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'KE' ; 'KEY'\r
+ DC.B 'Y'|$80\r
+ DC.L EMIT-5-NATWID\r
+*KEY DC.L *+NATWID\r
+KEY BSR.W PKEY ; PKEY leaves the scancode|key/break in D1.\r
+ AND.L #$000000FF,D1\r
+ MOVE.L D1,-(PSP)\r
+ RTS\r
+*\r
+* ======>> 15 <<\r
+* ( --- f )\r
+* Scan keyboard, but do not wait. \r
+* Return 0 if no key,\r
+* BREAK ($ff03) if BREAK is pressed,\r
+* or key currently pressed. \r
+ EVEN\r
+ DC.B $89\r
+ DC.B '?TERMINA' ; '?TERMINAL'\r
+ DC.B $CC\r
+ DC.L KEY-4-NATWID\r
+*QTERM DC.L *+NATWID\r
+QTERM BSR.W PQTER ; PQTER leaves the flag/key in D1.\r
+ MOVE.L D1,-(PSP)\r
+ RTS\r
+*\r
+* ======>> 16 <<\r
+* ( --- )\r
+* EMIT a Carriage Return (ASCII CR).\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'C' ; 'CR'\r
+ DC.B 'R'|$80\r
+ DC.L QTERM-10-NATWID\r
+*CR DC.L *+NATWID\r
+CR BSR.W PCR ; Nothing really to do here.\r
+ RTS\r
+*\r
+* ######>> screen 22 <<\r
+* ======>> 17 <<\r
+* ( source target count --- )\r
+* Copy/move count bytes from source to target. \r
+* Moves ascending addresses,\r
+* so that overlapping only works if the source is above the destination.\r
+* CMOVE provides a nice testbed for the intersection between clever and real.\r
+* It also raises questions about why one might want to move all of memory.\r
+* The 68000 DBF instruction only does up to 2^16 moves, which is probably a reasonable limit;\r
+* but, rather than answer that question and/or the logic of split count, use a straight count.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'CMOV' ; 'CMOVE' : source, destination, count\r
+ DC.B 'E'|$80\r
+ DC.L CR-3-NATWID\r
+*CMOVE DC.L *+NATWID\r
+CMOVE MOVEM.L (PSP)+,D1/A0/A1 ; No effect in flags.\r
+ TST.L D1 ; Don't let zero count equal 2^32.\r
+ BEQ.S CMOVEX ; Stack clean.\r
+CMOVEL MOVE.B (A1)+,(A0)+\r
+ SUBQ.L #1,D1\r
+ BNE.S CMOVEL\r
+CMOVEX RTS\r
+*\r
+** One possible way to use DBcc (untested):\r
+* MOVEM.L (PSP)+,D1/A0/A1 ; No effect in flags.\r
+* TST.L D1 ; Don't let zero count equal 2^32.\r
+* BEQ.L CMOVEX ; Stack clean.\r
+* SUBQ.W #1,D1 ; Adjust for DBcc\r
+*CMOVEL MOVE.B (A1)+,(A0)+\r
+* DBF D1,CMOVEL\r
+* SUB.L #$10000,D1\r
+* BCC.S CMOVEL\r
+*CMOVEX RTS ;\r
+*\r
+* ( source target count --- )\r
+* Copy/move count bytes from source to target. \r
+* Moves descending addresses,\r
+* so that overlapping does work if the source is below the destination.\r
+* And, conversely, does not work if the source is above the destination.\r
+* Not in fig, provided here for aligning header names in CREATE.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'CMOVE' ; 'CMOVED' : source, destination, count\r
+ DC.B 'D'|$80\r
+ DC.L CMOVE-6-NATWID\r
+*CMOVD DC.L *+NATWID\r
+CMOVD MOVEM.L (PSP)+,D1/A0/A1 ; No effect in flags.\r
+ TST.L D1 ; Don't let zero count equal 2^32.\r
+ BEQ.S CMOVDX ; Stack clean.\r
+ LEA (A1,D1.L),A1 ; Point to (one past) the ends.\r
+ LEA (A0,D1.L),A0\r
+CMOVDL MOVE.B -(A1),-(A0)\r
+ SUBQ.L #1,D1\r
+ BNE.S CMOVDL\r
+CMOVDX RTS\r
+* Could use MOVE.B (A1,D0.L),(A0,D0.L), too, but that would take extra cycles.\r
+*\r
+* ######>> screen 23 <<\r
+* ======>> 18 <<\r
+* ( u1 u2 --- ud )\r
+* Multiplies the top two unsigned integers,\r
+* yielding a double integer product.\r
+* Word at a time, but significantly faster than bit-at-a-time.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'U' ; 'U*'\r
+ DC.B '*'|$80\r
+ DC.L CMOVD-7-NATWID\r
+*USTAR DC.L *+NATWID\r
+USTAR MOVEM.W (PSP),D0/D1/D2/D3 ; MOVEM is a cheap way to split the low and high words.\r
+ MULU.W D3,D1 ; U2 low by U1 low, and it's in place\r
+ MULU.W D2,D0 ; U2 high by U1 high, and it's in place\r
+ MULU.W NATWID/2(PSP),D2 ; U1 high by U2 low\r
+ MULU.W (PSP),D3 ; U1 low by U2 high\r
+ ADD.L D3,D2 ; sum of inner products\r
+ CLR.L D3 ; X-carry is not affected\r
+ ADDX.L D3,D3 ; grab the X-carry (no ADDX #0!)\r
+ SWAP D3 ; move the carry into place\r
+ SWAP D2 ; fast 16 bit rotate\r
+ MOVE.W D2,D3 ; high half of inner product, carry in place\r
+ AND.L #$FFFF0000,D2 ; low half of inner product\r
+ ADD.L D2,D1\r
+ ADDX.L D3,D0 ; along with both carries!\r
+ MOVEM.L D0/D1,(PSP) ; stack is as we want it.\r
+ RTS\r
+*\r
+*\r
+* ######>> screen 24 <<\r
+* ======>> 19 <<\r
+* ( ud u --- uremainder uquotient )\r
+* Divides the top unsigned integer\r
+* into the second and third words on the stack\r
+* as a single unsigned double integer,\r
+* leaving the remainder and quotient (quotient on top)\r
+* as unsigned integers.\r
+*\r
+* The reason for this oddity is that U/ was intended to be the inverse of U* :\r
+* in other words, \r
+* U/ can only divide without overflow if the dividend is the result of \r
+* the divisor multiplied by the quotient using U* , \r
+* with an added constant less than the divisor (the remainder portion).\r
+*\r
+* This is particularly useful in columnar division,\r
+* when the divisor fits within the defined column:\r
+* \r
+* The smaller the divisor, the more likely dropping the high word \r
+* of the quotient loses significant bits. See M/MOD .\r
+*\r
+* An example of a dividend/divisor pair that would not work:\r
+* HEX 200000000 2 U/\r
+* -- The largest multiple of 2 that U* could produce in a 32-bit environment would be\r
+* HEX 1FFFFFFFE\r
+* Thus, HEX 1FFFFFFFF would be the maximum 64-bit number\r
+* that U/ would divide by 2 without overflow.\r
+*\r
+* Note (from M/MOD) that U/ can be chained, as long as the divisor is single-width.\r
+*\r
+* For a library routine, I would probably want to run-time optimize the divide,\r
+* following four paths:\r
+* If divisor is zero, (1) give saturation result of max quotient, max remainder --\r
+* else if divisor fits in 16 bits, \r
+* if dividend fits in 16 bits, (2) use native DIVU --\r
+* else (3) use chained native DIVU (can be one less than full divide);\r
+* else, (4) for each 16-bit column,\r
+* use native DIVU to guess high word of quotient\r
+* multiply and subtract intermediate product\r
+* if too guess too large, decrement guess and add divisor to get remainder\r
+* shift to the next right column\r
+* But light testing would not be sufficient.\r
+* Each path would need to be tested against its next more optimal path.\r
+* And the resulting routine could be full M/MOD, if paths 3 and 4 are fully worked out.\r
+*\r
+* For now, for the fig model --\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'U' ; 'U/'\r
+ DC.B '/'|$80\r
+ DC.L USTAR-3-NATWID\r
+* Using the bit divide to reduce testing burden, working in registers.\r
+USLASH:\r
+* DC.L *+NATWID\r
+ MOVEM.L (PSP),D0/D1/D2 ; D1:D2 by D0 (40~ ignore attempts to count cycles)\r
+ MOVE.W #32,D3 ; bit ct for DBcc (8~)\r
+USLDIV:\r
+ CMP.L D0,D1 ; divisor (6~)\r
+ BHS.S USLSUB (8/10~)\r
+ AND #~F_EXT,CCR ; X-carry clear (20~)\r
+ BRA.S USLBIT (10~)\r
+USLSUB:\r
+ SUB.L D0,D1 (6~)\r
+ OR #F_EXT,CCR ; quotient, (X-carry set) (20~)\r
+USLBIT:\r
+ ROXL.L #1,D2 ; save it (8~)\r
+ DBF D3,USLMOR ; more bits? Don't mess with CCR ((12/14)/10~)\r
+USLR:\r
+ LEA NATWID(PSP),PSP (8~)\r
+ MOVE.L D1,NATWID(PSP) (16~)\r
+ MOVE.L D2,(PSP) (12~)\r
+ RTS\r
+USLMOR:\r
+ ROXL.L #1,D1 ; remainder (8~)\r
+ BCC.S USLDIV (8/10~)\r
+ BRA.S USLSUB (10~) (~90*32=~2880+entry+exit, about 800 μS at 4 MHz)\r
+\r
+* The following is not yet functional, only here to help me remember:\r
+* cUSLASH DC.L *+NATWID\r
+* MOVE.W (PSP)+,D0\r
+* BNE USL32\r
+* MOVE.W (PSP)+,D0 ; stack pre-adjusted\r
+* BNE USL16 ; avoid DIV by 0 exception\r
+* MOVE.L #-1,(PSP) ; quotient too large\r
+* MOVE.L #-1,NATWID(PSP) ; remainder too large\r
+* RTS\r
+* cUSL16 CLR.L D1\r
+* MOVE.W (PSP),D1 ; start with highest half\r
+* DIVU.W D0,D1 ; can't overflow\r
+* MOVE.W D1,(PSP) ; remainder in high half\r
+* MOVE.W NATWID/2(PSP),D1 ; 2nd half\r
+* DIVU.W D0,D1\r
+* MOVE.W D1,NATWID/2(PSP)\r
+* MOVE.W NATWID(PSP),D1 ; 3rd half\r
+* DIVU.W D0,D1\r
+* MOVE.W D1,NATWID(PSP)\r
+* MOVE.W 3*NATWID/2(PSP),D1 ; lowest half\r
+* DIVU.W D0,D1 ; (140~) (~140*4=560+smallstuff)\r
+* MOVE.W D1,3*NATWID/2(PSP) \r
+* CLR.W D1\r
+* SWAP.W D1\r
+* RTS\r
+* cUSL32\r
+*\r
+* Following the 6809 code, working on the stack.\r
+* Untested:\r
+* B0USLASH:\r
+* DC.L *+NATWID\r
+* MOVE.W #33,D3 ; bit ct\r
+* MOVE.L NATWID(PSP),D2 ; dividend\r
+* B0USLDIV:\r
+* CMP.L (PSP),D2 ; divisor\r
+* BHS.S B0USLSUB\r
+* AND #~F_EXT,CCR ; X-carry clear\r
+* BRA.S B0USLBIT\r
+* B0USLSUB:\r
+* SUB.L (PSP),D2\r
+* OR #F_EXT,CCR ; quotient, (X-carry set)\r
+* B0USLBIT:\r
+* ROXL.W 2*NATWID+NATWID/2(PSP) ; save it\r
+* ROXL.W 2*NATWID(PSP) ; in memory has only 16-bit by 1 bit form\r
+* SUBQ.W #1,D3 ; more bits?\r
+* BEQ.S B0USLR\r
+* ROXL.L D2 ; remainder\r
+* BCC.S B0USLDIV\r
+* BRA.S B0USLSUB\r
+* B0USLR:\r
+* LEA NATWID(PSP),PSP\r
+* MOVE.L NATWID(PSP),D1\r
+* MOVEM.L D1/D2,(PSP)\r
+* RTS\r
+*\r
+\r
+ PAGE\r
+* ######>> screen 25 <<\r
+* ======>> 20 <<\r
+* ( n1 n2 --- n )\r
+* Bitwise and the top two integers.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'AN' ; 'AND'\r
+ DC.B "D"|$80\r
+* DC.L I-2-NATWID ; ***** debug link *****\r
+ DC.L USLASH-3-NATWID ; correct link\r
+*AND DC.L *+NATWID\r
+AND MOVE.L (PSP)+,D0\r
+ AND.L D0,(PSP)\r
+ RTS\r
+*\r
+* ======>> 21 <<\r
+* ( n1 n2 --- n )\r
+* Bitwise or the top two integers.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'O' ; 'OR'\r
+ DC.B 'R'|$80\r
+ DC.L AND-4-NATWID\r
+*OR DC.L *+NATWID\r
+OR MOVE.L (PSP)+,D0\r
+ OR.L D0,(PSP)\r
+ RTS\r
+* \r
+* ======>> 22 <<\r
+* ( n1 n2 --- n )\r
+* Bitwise exclusive or the top two integers.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'XO' ; 'XOR'\r
+ DC.B 'R'|$80\r
+ DC.L OR-3-NATWID\r
+*XOR DC.L *+NATWID\r
+XOR MOVE.L (PSP)+,D0\r
+ EOR.L D0,(PSP)\r
+ RTS\r
+*\r
+* Not in fig,\r
+* for CPUs that don't like odd addresses.\r
+* Test whether top of stack is odd, push flag: 0 => even, 1 => odd.\r
+* ( n --- n f )\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B '?OD' ; '?ODD'\r
+ DC.B 'D'|$80\r
+ DC.L XOR-4-NATWID\r
+*QODD DC.L *+NATWID\r
+QODD MOVE.L (PSP),-(PSP)\r
+ AND.L #1,(PSP)\r
+ RTS\r
+* MOVE.L (PSP),D0\r
+* AND.L #1,D0\r
+* MOVE.L D0,-(PSP)\r
+* RTS\r
+*\r
+* Not in fig --\r
+* Calculate the bump adjustment necessary for odd or even alignment.\r
+* Odd for odd alignment, even for even.\r
+* bump is 0 (no adjustment) or 1 (adjustment needed)\r
+* ( n alignment --- n bump )\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $8A\r
+ DC.B 'ALIGN-BUM' ; 'ALIGN-BUMP'\r
+ DC.B 'P'|$80\r
+ DC.L QODD-5-NATWID\r
+*ALGNB DC.L *+NATWID\r
+ALGNB MOVE.L (PSP),D0\r
+ AND.L #1,D0 ; Even or odd alignment?\r
+ MOVE.L NATWID(PSP),D1\r
+ AND.W #1,D1 ; Even address or odd?\r
+ EOR.W D0,D1 ; odd on even or even on odd is 1, else 0\r
+ MOVE.L D1,(PSP)\r
+ RTS\r
+*\r
+** Not in fig,\r
+** for CPUs that don't like odd addresses.\r
+** Floor top of stack even.\r
+** ( n --- even )\r
+* EVEN\r
+* DC.B 0\r
+* DC.B $86\r
+* DC.B 'FLOOR' ; 'FLOOR2'\r
+* DC.B '2'|$80\r
+* DC.L ALGNB-11-NATWID\r
+** FLOOR2 DC.L *+NATWID\r
+* FLOOR2 AND.W #$FFFE,NATWID/2(PSP)\r
+* RTS\r
+**\r
+** Not in fig,\r
+** for CPUs that don't like odd addresses.\r
+** Make top of stack even by adjusting it up.\r
+** ( n --- even )\r
+* EVEN\r
+* DC.B 0\r
+* DC.B $88\r
+* DC.B 'CIELING' ; 'CIELING2'\r
+* DC.B '2'|$80\r
+* DC.L FLOOR2-7-NATWID\r
+** CIEL2 DC.L *+NATWID\r
+* CIEL2 BCLR #0,NATWID-1(PSP)\r
+* BEQ.S CIEL2X\r
+* ADDQ.L #2,(PSP)\r
+* CIEL2X RTS\r
+*\r
+* ######>> screen 26 <<\r
+* ======>> 23 <<\r
+* ( anything --- anything adr )\r
+* Fetch the parameter stack pointer (before it is pushed).\r
+* This points at whatever was on the top of stack before.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'SP' ; 'SP@'\r
+ DC.B '@'|$80\r
+ DC.L ALGNB-11-NATWID\r
+*SPAT DC.L *+NATWID\r
+SPAT MOVE.L PSP,-(PSP)\r
+ RTS\r
+*\r
+* ======>> 24 <<\r
+* ( whatever --- nothing )\r
+* Initialize the parameter stack pointer from the USER variable S0. \r
+* Effectively clears the stack.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'SP' ; 'SP!'\r
+ DC.B $A1\r
+ DC.L SPAT-4-NATWID\r
+*SPSTOR DC.L *+NATWID\r
+SPSTOR MOVE.L XSPZER-UORIG(UP),PSP\r
+ RTS\r
+*\r
+ PAGE\r
+*\r
+* ======>> 25 <<\r
+* ( whatever *** nothing )\r
+* Initialize the return stack pointer from the initialization table\r
+* instead of the user variable R0, for some reason.\r
+* Quite possibly, this should be from R0.\r
+* Effectively aborts all in-process definitions, except the active one. \r
+* An emergency measure, to be sure.\r
+* The routine that calls this must never execute a return.\r
+* So this should never be executed from the terminal, I guess.\r
+* This is another that should be compile-time only, and in a separate vocabulary.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'RP' ; 'RP!'\r
+ DC.B '!'|$80\r
+ DC.L SPSTOR-4-NATWID\r
+*RPSTOR DC.L *+NATWID\r
+RPSTOR MOVE.L RINIT(PC),RP\r
+ BRA.W NEXT ; This is correct here, but what will we do when NEXT goes away?\r
+*\r
+* ======>> 26 <<\r
+* ( ip *** )\r
+* Pop IP from return stack (return from high-level definition).\r
+* Can be used in a screen to force interpretion to terminate.\r
+* Must not be executed when temporaries are saved on top of the return stack.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B ';' ; ';S'\r
+ DC.B 'S'|$80\r
+ DC.L RPSTOR-4-NATWID\r
+*SEMIS DC.L *+NATWID\r
+SEMIS MOVEM.L (RP)+,A0/IP ; A0 will be TOS\r
+ JMP (A0) ; return to NEXT\r
+* ; SEMIS will almost disappear when NEXT goes away.\r
+* MOVE.L (RP)+,A0\r
+* MOVE.L (RP)+,IP\r
+* JMP (A0)\r
+*\r
+* ######>> screen 27 <<\r
+* ======>> 27 <<\r
+* ( limit index *** index index )\r
+* Force the terminating condition for the innermost loop by\r
+* copying its index to its limit. \r
+* Termination is postponed until the next\r
+* LOOP or +LOOP instruction is executed. \r
+* The index remains available for use until\r
+* the LOOP or +LOOP instruction is encountered.\r
+* Note that the assumption is that the current count is the correct count \r
+* to end at, rather than pushing the count to the final count.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'LEAV' ; 'LEAVE'\r
+ DC.B 'E'|$80\r
+ DC.L SEMIS-3-NATWID\r
+*LEAVE DC.L *+NATWID\r
+LEAVE MOVE.L LUPCT(RP),LUPLIM(RP) ; Return address hidden in offset EQUs.\r
+ RTS\r
+*\r
+* Notes for loop counter and limit in registers:\r
+* MOVE.L LUPCT,LUPLIM ; No return address to dodge.\r
+* RTS\r
+*\r
+* ======>> 28 <<\r
+* ( n --- ) \r
+* ( *** n ) \r
+* Move top of parameter stack to top of return stack.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '>' ; '>R'\r
+ DC.B 'R'|$80\r
+ DC.L LEAVE-6-NATWID\r
+*TOR DC.L *+NATWID\r
+TOR MOVE.L (RP),A0\r
+ MOVE.L (PSP)+,(RP)\r
+ JMP (A0)\r
+*\r
+* ======>> 29 <<\r
+* ( --- n ) \r
+* ( n *** ) \r
+* Move top of return stack to top of parameter stack.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'R' ; 'R>'\r
+ DC.B '>'|$80\r
+ DC.L TOR-3-NATWID\r
+*FROMR DC.L *+NATWID\r
+* MOVEM.L (RP)+,A0/A1 ; A0 will be TOS\r
+* MOVE.L A1,-(PSP)\r
+* JMP (A0)\r
+FROMR MOVE.L (RP)+,A0\r
+ MOVE.L (RP)+,-(PSP)\r
+ JMP (A0)\r
+*\r
+* ======>> 30 <<\r
+* ( --- n ) \r
+* ( n *** n )\r
+* Copy the top of return stack to top of parameter stack. \r
+* This would NOT be a synonym for I if we were keeping the control variables in registers.\r
+ EVEN\r
+ DC.B $81 ; R\r
+ DC.B 'R'|$80\r
+ DC.L FROMR-3-NATWID\r
+*R DC.L I+NATWID ; Can't do as synonym any more.\r
+R MOVE.L NATWID(RP),-(PSP) ; dodge return address\r
+ RTS\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 28 <<\r
+* ======>> 31 <<\r
+* ( n --- ~n )\r
+* Bit-invert top.\r
+* Not part of fig model.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'NO' ; 'NOT'\r
+ DC.B 'T'|$80\r
+ DC.L R-2-NATWID\r
+*LNOT DC.L *+NATWID\r
+LNOT NOT (PSP)\r
+ RTS\r
+*\r
+* ( n --- n=0 )\r
+* Logically invert top of stack;\r
+* or flag true if top is zero, otherwise false.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '0' ; '0='\r
+ DC.B '='|$80\r
+ DC.L LNOT-4-NATWID\r
+*ZEQU DC.L *+NATWID\r
+ZEQU CLR.L D0\r
+ TST.L (PSP)\r
+ SEQ D0 ; faster than branch\r
+ZEQMSK AND.W #1,D0\r
+ MOVE.L D0,(PSP)\r
+ RTS\r
+*\r
+* Option using branch and increment:\r
+** ZEQU DC.L *+NATWID\r
+* ZEQU CLR.L D0\r
+* TST.L (PSP)\r
+* BEQ.S ZEQUS\r
+* MOVEQ #1,D0 ; ADDQ.W would work. ADDQ.L takes 8 cycles instead of 4.\r
+* ZEQUS MOVE.L D0,(PSP)\r
+* RTS\r
+*\r
+* If TRUE were -1:\r
+** ZEQU DC.L *+NATWID\r
+* ZEQU TST.L (PSP)\r
+* SEQ D0\r
+* EXT.B D0\r
+* EXT.W D0\r
+* MOVE.L D0,(PSP)\r
+* RTS\r
+*\r
+* ======>> 32 <<\r
+* ( n --- n<0 )\r
+* Flag true if top is negative (MSbit set), otherwise false.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '0' ; '0<'\r
+ DC.B '<'|$80\r
+ DC.L ZEQU-3-NATWID\r
+*ZLESS DC.L *+NATWID\r
+ZLESS CLR.L D0\r
+ TST.L (PSP)\r
+ SMI D0\r
+ BRA.S ZEQMSK ; trade a few cycles for several bytes\r
+*\r
+* ######>> screen 29 <<\r
+* ======>> 33 <<\r
+* ( n1 n2 --- n1+n2 )\r
+* Add top two words.\r
+ EVEN\r
+ DC.B $81 ; '+'\r
+ DC.B '+'|$80\r
+ DC.L ZLESS-3-NATWID\r
+*PLUS DC.L *+NATWID\r
+PLUS MOVE.L (PSP)+,D0 ; Addition is commutative.\r
+ ADD.L D0,(PSP) ; This order will not work for subtraction.\r
+ RTS ; Remember, my son --\r
+* ; the left hand operator is one deeper in the stack,\r
+* ; and it is the target.\r
+*\r
+* ======>> 34 <<\r
+* ( d1 d2 --- d1+d2 )\r
+* Add top two double integers.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'D' ; 'D+'\r
+ DC.B '+'|$80\r
+ DC.L PLUS-2-NATWID\r
+*DPLUS DC.L *+NATWID\r
+DPLUS MOVEM.L (PSP)+,D0/D1/D2/D3 ; ADDX memory requires too much setup\r
+ ADD.L D1,D3 ; This order will work for subtraction, too.\r
+ ADDX.L D0,D2\r
+ MOVEM.L D2/D3,-(PSP)\r
+ RTS\r
+*\r
+* ======>> 35 <<\r
+* ( n --- -n )\r
+* Negate (two's complement) top of stack.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'MINU' ; 'MINUS'\r
+ DC.B 'S'|$80\r
+ DC.L DPLUS-3-NATWID\r
+*MINUS DC.L *+NATWID\r
+MINUS NEG.L (PSP)\r
+ RTS\r
+*\r
+* ======>> 36 <<\r
+* ( d --- -d )\r
+* Negate (two's complement) top two words on stack as a double integer.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'DMINU' ; 'DMINUS'\r
+ DC.B 'S'|$80\r
+ DC.L MINUS-6-NATWID\r
+*DMINUS DC.L *+NATWID\r
+DMINUS NEG.L NATWID(PSP)\r
+ NEGX.L (PSP)\r
+ RTS\r
+*\r
+* ######>> screen 30 <<\r
+* ======>> 37 <<\r
+* ( n1 n2 --- n1 n2 n1 )\r
+* Push a copy of the second word on stack.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'OVE' ; 'OVER'\r
+ DC.B 'R'|$80\r
+ DC.L DMINUS-7-NATWID\r
+*OVER DC.L *+NATWID\r
+OVER MOVE.L NATWID(PSP),-(PSP)\r
+ RTS\r
+*\r
+* ======>> 38 <<\r
+* ( n --- )\r
+* Discard the top word on stack.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'DRO' ; 'DROP'\r
+ DC.B 'P'|$80\r
+ DC.L OVER-5-NATWID\r
+*DROP DC.L *+NATWID\r
+DROP LEA NATWID(PSP),PSP\r
+ RTS\r
+*\r
+* ======>> 39 <<\r
+* ( n1 n2 --- n2 n1 )\r
+* Swap the top two words on stack.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'SWA' ; 'SWAP'\r
+ DC.B 'P'|$80\r
+ DC.L DROP-5-NATWID\r
+*SWAP DC.L *+NATWID\r
+SWAP MOVEM.L (PSP),D0/D1\r
+ EXG D0,D1\r
+ MOVEM.L D0/D1,(PSP)\r
+ RTS\r
+* MOVE.L (PSP),D0\r
+* MOVE.L NATWID(PSP),(PSP)\r
+* MOVE.L D0,NATWID(POS)\r
+* RTS\r
+*\r
+* ======>> 40 <<\r
+* ( n1 --- n1 n1 )\r
+* Push a copy of the top word on stack.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'DU' ; 'DUP'\r
+ DC.B 'P'|$80\r
+ DC.L SWAP-5-NATWID\r
+*DUP DC.L *+NATWID\r
+DUP MOVE.L (PSP),-(PSP)\r
+ RTS\r
+*\r
+* ######>> screen 31 <<\r
+* ======>> 41 <<\r
+* ( n adr --- )\r
+* Add the second word on stack to the word at the adr on top of stack.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '+' ; '+!'\r
+ DC.B '!'|$80\r
+ DC.L DUP-4-NATWID\r
+*PSTORE DC.L *+NATWID\r
+PSTORE MOVEM.L (PSP)+,D0/A0\r
+ EXG D0,A0\r
+ ADD.L D0,(A0)\r
+ RTS\r
+*\r
+* ======>> 42 <<\r
+* ( adr b --- )\r
+* Exclusive or byte at adr with low byte of top word.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'TOGGL' ; 'TOGGLE'\r
+ DC.B 'E'|$80\r
+ DC.L PSTORE-3-NATWID\r
+*TOGGLE DC.L *+NATWID\r
+TOGGLE MOVEM.L (PSP)+,D0/A0\r
+ EOR.B D0,(A0)\r
+ RTS\r
+* Using the model code would be less likely to introduce bugs, \r
+* but that would sort-of defeat my purposes here.\r
+* Anyway, I can imitate known good bif-6809 code\r
+* and it's fewer bytes and much faster code this way.\r
+* TOGGLE\r
+* DC.L DOCOL,OVER,CAT,XOR,SWAP,CSTORE\r
+* DC.L SEMIS\r
+*\r
+* ######>> screen 32 <<\r
+* ======>> 43 <<\r
+* ( adr --- n )\r
+* Replace address on stack with the word at the address.\r
+ EVEN\r
+ DC.B $81 ; @\r
+ DC.B '@'|$80\r
+ DC.L TOGGLE-7-NATWID\r
+*AT DC.L *+NATWID\r
+AT MOVE.L (PSP),A0\r
+ MOVE.L (A0),(PSP)\r
+ RTS\r
+*\r
+* ======>> 44 <<\r
+* ( adr --- b )\r
+* Replace address on top of stack with the byte at the address.\r
+* High byte of result is clear.\r
+* Unfortunate naming. 8 bits doth not a character code point make.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'C' ; 'C@'\r
+ DC.B '@'|$80\r
+ DC.L AT-2-NATWID\r
+**CAT DC.L *+NATWID\r
+*CAT MOVE.L (PSP),A0 ; Memory indirect is 68020 and after, but not CPU32.\r
+* CLR.L D0 ; Reduce bus activity and un-aligned access.\r
+* MOVE.B (A0),D0\r
+* MOVE.L D0,(PSP)\r
+* RTS\r
+CAT MOVE.L (PSP),A0\r
+ CLR.L (PSP)\r
+ MOVE.B (A0),NATWID-1(PSP)\r
+ RTS\r
+* But optimization is not my primary purpose here, \r
+* so I'm not going to count bytes and cycles and compare.\r
+*\r
+* ( adr --- h )\r
+* Yeah, we're gonna need this.\r
+* Replace address on top of stack with the 16-bit half-word at the address.\r
+* High half-word of result is clear.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'H' ; 'H@'\r
+ DC.B '@'|$80\r
+ DC.L CAT-3-NATWID\r
+**HAT DC.L *+NATWID\r
+*HAT MOVE.L (PSP),A0 ; Memory indirect is 68020 and after, but not CPU32.\r
+* CLR.L D0 ; Reduce bus activity.\r
+* MOVE.W (A0),D0\r
+* MOVE.L D0,(PSP)\r
+* RTS\r
+HAT MOVE.L (PSP),A0\r
+ CLR.L (PSP)\r
+ MOVE.W (A0),NATWID/2(PSP)\r
+ RTS\r
+*\r
+* ======>> 45 <<\r
+* ( n adr --- )\r
+* Store second word on stack at address on top of stack.\r
+ EVEN\r
+ DC.B $81 ; !\r
+ DC.B '!'|$80\r
+ DC.L HAT-3-NATWID\r
+**STORE DC.L *+NATWID\r
+*STORE MOVEM.L (PSP)+,D0/A0\r
+* EXG D0,A0\r
+* MOVE.L D0,(A0)\r
+* RTS\r
+STORE MOVE.L (PSP)+,A0\r
+ MOVE.L (PSP)+,(A0)\r
+ RTS\r
+*\r
+* ======>> 46 <<\r
+* ( b adr --- )\r
+* Store low byte of second word on stack at address on top of stack. \r
+* High byte is ignored.\r
+* Unfortunate naming. 8 bits doth not a character code point make.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'C' ; 'C!'\r
+ DC.B '!'|$80\r
+ DC.L STORE-2-NATWID\r
+**CSTORE DC.L *+NATWID\r
+*CSTORE MOVEM.L (PSP)+,D0/A0\r
+* EXG D0,A0\r
+* MOVE.B D0,(A0)\r
+* RTS\r
+CSTORE MOVE.L (PSP)+,A0\r
+ MOVE.L (PSP)+,D0\r
+ MOVE.B D0,(A0)\r
+ RTS\r
+*\r
+* ( b adr --- )\r
+* Yeah, we're gonna need this.\r
+* Store low 16-bit half-word of second word on stack at address on top of stack. \r
+* High half-word is ignored.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'H' ; 'H!'\r
+ DC.B '!'|$80\r
+ DC.L CSTORE-3-NATWID\r
+**HSTORE DC.L *+NATWID\r
+*HSTORE MOVEM.L (PSP)+,D0/A0\r
+* EXG D0,A0\r
+* MOVE.W D0,(A0)\r
+* RTS\r
+HSTORE MOVE.L (PSP)+,A0\r
+ MOVE.L (PSP)+,D0\r
+ MOVE.B D0,(A0)\r
+ RTS\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 33 <<\r
+* ======>> 47 <<\r
+* ( --- ) P\r
+* { : name sundry-activities ; } typical input\r
+* ( Termination of recursive definition, or eating our own dogfood --\r
+* lots of forward references here.)\r
+* If executing (not compiling), \r
+* record the data stack mark in CSP,\r
+* Set the CONTEXT vocabulary to CURRENT,\r
+* CREATE a header,\r
+* set state to compile,\r
+* and compile the call to the trailing native CPU machine code DOCOL.\r
+*\r
+* This would not be hard to flatten to native code,\r
+* especially in the 6809 or 68000.\r
+* But that's not the purpose of a model.\r
+*\r
+ EVEN\r
+ DC.B $C1 ; : immediate\r
+ DC.B ':'|$80\r
+ DC.L HSTORE-3-NATWID\r
+*COLON DC.L DOCOL\r
+COLON BSR.S DOCOL\r
+ DC.L QEXEC,SCSP,CURENT,AT,CONTXT,STORE\r
+ DC.L CREATE,RBRAK\r
+ DC.L PSCODE\r
+*COLON BSR.W QEXEC\r
+* BSR.W SCSP\r
+* MOVE.L XCURR-UORIG(UP),XCONT-UORIG(UP)\r
+* BSR.W CREATE\r
+* BSR.W RBRAK\r
+* BSR.W PSCODE\r
+\r
+* Here is the IP pusher for allowing\r
+* nested words in the virtual machine:\r
+* ( ;S is the equivalent un-nester )\r
+\r
+* ( *** oldIP ) \r
+* Characteristic of a colon (:) definition. \r
+* Begins execution of a high-level definition,\r
+* i. e., nests the definition and begins processing icodes. \r
+* Mechanically, it pushes the IP \r
+* and loads the Parameter Field Address of the definition which\r
+* called it into the IP.\r
+*DOCOL MOVE.L (RP),A0\r
+* MOVE.L IP,(RP)\r
+* MOVE.L W,IP\r
+* JMP (A0) ; Return to NEXT.\r
+DOCOL MOVEM.L (RP)+,A0/A1 ; new i-code list address and return to NEXT\r
+ MOVE.L IP,-(RP) ; nest IP\r
+ MOVE.L A0,IP ; address of list saved by call here\r
+ JMP (A1) ; Return to caller, usually or often NEXT.\r
+*\r
+* ======>> 48 <<\r
+* ( --- ) P\r
+* { : name sundry-activities ; } typical input\r
+* ERROR check data stack against mark in CSP,\r
+* compile ;S,\r
+* unSMUDGE LATEST definition,\r
+* and set state to interpretation.\r
+ EVEN\r
+ DC.B $C1 ; ; imnediate code\r
+ DC.B ';'|$80\r
+ DC.L COLON-2-NATWID\r
+*SEMI DC.L DOCOL\r
+SEMI BSR.S DOCOL\r
+ DC.L QCSP,COMPIL,SEMIS,SMUDGE,LBRAK\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 34 <<\r
+* ======>> 49 <<\r
+* ( n --- )\r
+* { value CONSTANT name } typical input\r
+* CREATE a header,\r
+* unSMUDGE it,\r
+* compile the constant value,\r
+* and compile the call to the trailing native CPU machine code DOCON.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $88\r
+ DC.B 'CONSTAN' ; 'CONSTANT'\r
+ DC.B 'T'|$80\r
+ DC.L SEMI-2-NATWID\r
+*CON DC.L DOCOL\r
+CON BSR.S DOCOL\r
+ DC.L CREATE,SMUDGE,COMMA,PSCODE\r
+* ( --- n ) \r
+* Characteristic of a CONSTANT. \r
+* A CONSTANT simply loads its value from its parameter field\r
+* and pushes it on the stack.\r
+DOCON MOVE.L (RP)+,A0 ; Get fake return address pushed by call here.\r
+ MOVE.L (A0),-(PSP) ; Push the first natural width word of the parameter field.\r
+ RTS ; Return to caller, usually or often NExT\r
+*\r
+* Tempting to do a space-saving DOHCON:\r
+* DOHCON MOVE.L (RP)+,A0 ; Get fake return address pushed by call here.\r
+* MOVE.W (A0),-(PSP) ; Push the first half-width word of the parameter field.\r
+* MOVEQ.W #0,-(PSP) ; zero extend the half-width value on stack\r
+* RTS ; Return to caller, usually or often NExT\r
+* But, as you can see, it'll be a bit slower,\r
+* and it just may not be worth it for the number of times it would be used.\r
+* And there's a bettwer way lurking around the corner.\r
+*\r
+* ======>> 50 <<\r
+* ( init --- )\r
+* { init VARIABLE name } typical input\r
+* Use CONSTANT to CREATE a header and compile the initial value, init, \r
+* then overwrite the characteristic to point to DOVAR.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $88\r
+ DC.B 'VARIABL' ; 'VARIABLE'\r
+ DC.B 'E'|$80\r
+ DC.L CON-9-NATWID\r
+*VAR DC.L DOCOL\r
+VAR BSR.S DOCOL\r
+ DC.L CON,PSCODE\r
+* ( --- vadr ) \r
+* Characteristic of a VARIABLE. \r
+* A VARIABLE pushes its PFA address on the stack. \r
+* The parameter field of a VARIABLE is the actual allocation of the variable,\r
+* so that pushing its address allows its contents to be @ed (fetched). \r
+* Ordinary arrays and strings that do not subscript themselves\r
+* may be allocated by defining a variable\r
+* and immediately ALLOTting the remaining needed space.\r
+* VARIABLES are global to all users,\r
+* and thus should be hidden in resource monitors, but aren't.\r
+DOVAR MOVE.L (RP)+,-(PSP) ; Get and push fake return address pushed by call here, \r
+ RTS ; as address of first natural width word of the parameters.\r
+*\r
+* ======>> 51 <<\r
+* ( ub --- )\r
+* { uboffset USER name } typical input\r
+* CREATE a header and compile the unsigned byte offset in the per-USER table, \r
+* then overwrite the header with a call to DOUSER.\r
+* The USER is entirely responsible for maintaining allocation!\r
+* (We really need a word that controls allocation of these.)\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'USE' ; 'USER'\r
+ DC.B 'R'|$80\r
+ DC.L VAR-9-NATWID\r
+*USER DC.L DOCOL\r
+USER BSR.S DOCOL\r
+ DC.L CON,PSCODE\r
+* ( --- vadr ) \r
+* Characteristic of a per-USER variable. \r
+* USER variables are similiar to VARIABLEs,\r
+* but are allocated (by hand!) in the per-user table. \r
+* A USER variable's parameter field contains its offset in the per-user table.\r
+DOUSER MOVE.L (RP)+,A0 ; Get fake return address pushed by call here.\r
+ MOVE.L (A0),D0 ; Offset into the table.\r
+ LEA (UP,D0.L),A0\r
+ MOVE.L A0,-(PSP)\r
+ RTS\r
+* Hey, the per-user table can actually be larger than 256 bytes!\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 35 <<\r
+*\r
+* Some (theoretically) useful constants:\r
+* ======>> 52 <<\r
+* ( --- 0 )\r
+ EVEN\r
+ DC.B $81 ; 0\r
+ DC.B '0'|$80\r
+ DC.L USER-5-NATWID\r
+*ZERO DC.L DOCON\r
+ZERO BSR.S DOCON\r
+ DC.L 0000\r
+*\r
+* ======>> 53 <<\r
+* ( --- 1 )\r
+ EVEN\r
+ DC.B $81 ; 1\r
+ DC.B '1'|$80\r
+ DC.L ZERO-2-NATWID\r
+*ONE BSR.S DOCON\r
+ONE DC.L DOCON\r
+ONEV DC.L 1\r
+*\r
+* ======>> 54 <<\r
+* ( --- 2 )\r
+ EVEN\r
+ DC.B $81 ; 2\r
+ DC.B '2'|$80\r
+ DC.L ONE-2-NATWID\r
+*TWO DC.L DOCON\r
+TWO BSR.S DOCON\r
+TWOV DC.L 2\r
+*\r
+* ======>> 55 <<\r
+* ( --- 3 )\r
+ EVEN\r
+ DC.B $81 ; 3\r
+ DC.B '3'|$80\r
+ DC.L TWO-2-NATWID\r
+*THREE DC.L DOCON\r
+THREE BSR.W DOCON\r
+ DC.L 3\r
+*\r
+*mOVE NATWC into BSR.S range, in front of THREE? Maybe not.\r
+* Useful constant, not in model, needed for abstraction:\r
+* The standard name is CELL, however.\r
+* ( --- NATWID )\r
+* The byte width of objects on stack.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'NATWI' ; 'NATWID'\r
+ DC.B 'D'|$80\r
+ DC.L THREE-2-NATWID\r
+*NATWC DC.L DOCON\r
+NATWC BSR.W DOCON\r
+NATWCV DC.L NATWID\r
+*\r
+* Not in model, wanted for abstraction:\r
+* Note that this is not defined as an instance of an INCREMENTER here!\r
+* Coded to increment by the exact constant returned by NATWID\r
+* ( n --- n+NATWID )\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'NAT' ; 'NAT+'\r
+ DC.B '+'|$80\r
+ DC.L NATWC-7-NATWID\r
+*NATP DC.L *+NATWID\r
+NATP MOVE.L (PSP),D0\r
+ ADD.L NATWCV(PC),D0 ; late binding?\r
+ MOVE.L D0,(PSP)\r
+ RTS\r
+*\r
+* Useful constant, not in model, needed for abstraction:\r
+* ( --- NATWID/2 )\r
+* Half the byte width of objects on stack.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $8A\r
+ DC.B 'HALFNATWI' ; 'HALFNATWID'\r
+ DC.B 'D'|$80\r
+ DC.L NATP-5-NATWID\r
+*HNATWC DC.L DOCON\r
+HNATWC BSR.W DOCON\r
+HNATWCV DC.L NATWID/2\r
+*\r
+ PAGE\r
+*\r
+* ======>> 56 <<\r
+* ( --- SP ) \r
+* ASCII SPACE character\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'B' ; 'BL'\r
+ DC.B 'L'|$80\r
+ DC.L HNATWC-11-NATWID\r
+*BL DC.L DOCON ; ascii blank\r
+BL BSR.W DOCON ; ascii blank\r
+ DC.L $20\r
+*\r
+* ======>> 57 <<\r
+* This really shouldn't be a CONSTANT.\r
+* ( --- adr ) \r
+* The base of the disk buffer space.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'FIRS' ; 'FIRST'\r
+ DC.B 'T'|$80\r
+ DC.L BL-3-NATWID\r
+*FIRST DC.L DOCON\r
+FIRST BSR.W DOCON\r
+ DC.L BUFBAS\r
+* FDB MEMEND-528 ; (132 * NBLK)\r
+*\r
+* ======>> 58 <<\r
+* This really shouldn't be a CONSTANT.\r
+* ( --- adr ) \r
+* The limit of the disk buffer space.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'LIMI' ; 'LIMIT' : ( the end of memory +1 )\r
+ DC.B 'T'|$80\r
+ DC.L FIRST-6-NATWID\r
+*LIMIT DC.L DOCON\r
+LIMIT BSR.W DOCON\r
+ DC.L BUFBAS+BUFSZ\r
+* In 6800 model, was\r
+* FDB MEMEND\r
+*\r
+* ======>> 59 <<\r
+* ( --- sectorsize )\r
+* The size, in bytes, of a buffer control region.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'B/CT' ; 'B/CTL' : (bytes/control region)\r
+ DC.B 'L'|$80\r
+ DC.L LIMIT-6-NATWID\r
+*BCTL DC.L DOCON\r
+BCTL BSR.W DOCON\r
+ DC.L SECTRL\r
+*\r
+* ( --- sectorsize )\r
+* The size, in bytes, of a buffer.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'B/BU' ; 'B/BUF' : (bytes/buffer)\r
+ DC.B 'F'|$80\r
+ DC.L BCTL-6-NATWID\r
+*BBUF DC.L DOCON\r
+BBUF BSR.W DOCON\r
+ DC.L SECTSZ\r
+* Hardcoded in 6800 model:\r
+* FDB 128\r
+*\r
+* ======>> 60 <<\r
+* ( --- blocksperscreen ) \r
+* The size, in blocks, of a screen.\r
+* Should this be the same as NBLK, the number of block buffers maintained?\r
+* Only if you want to have a full screen in buffers at a time,\r
+* which might induce some bugs -- erk.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'B/SC' ; 'B/SCR' : (blocks/screen)\r
+ DC.B 'R'|$80\r
+ DC.L BBUF-6-NATWID\r
+*BSCR DC.L DOCON\r
+BSCR DBSR.W DOCON\r
+ DC.L SCRSZ/SECTSZ\r
+* Hardcoded in 6800 model as:\r
+* FDB 8\r
+* blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.\r
+*\r
+* ======>> 61 <<\r
+* ( n --- adr )\r
+* Calculate the address of entry (#n/NATWID) in the boot-up parameter table. \r
+* (Adds the base of the boot-up table to n.)\r
+ EVEN\r
+ DC.B $87\r
+ DC.B '+ORIGI' ; '+ORIGIN'\r
+ DC.B 'N'|$80\r
+ DC.L BSCR-6-NATWID\r
+*PORIG DC.L DOCOL\r
+PORIG BSR.W DOCOL\r
+ DC.L LIT,ORIG,PLUS\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 36 <<\r
+* ======>> 62 <<\r
+* ( n --- adr )\r
+* This is the per-task variable recording the initial parameter stack pointer.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'S' ; 'S0'\r
+ DC.B '0'|$80\r
+ DC.L PORIG-8-NATWID\r
+*SZERO DC.L DOUSER\r
+SZERO BSR.W DOUSER\r
+ DC.L XSPZER-UORIG\r
+*\r
+* ======>> 63 <<\r
+* ( n --- adr )\r
+* This is the per-task variable recording the initial return stack pointer.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'R' ; 'R0'\r
+ DC.B '0'|$80\r
+ DC.L SZERO-3-NATWID\r
+*RZERO DC.L DOUSER\r
+RZERO BSR.W DOUSER\r
+ DC.L XRZERO-UORIG\r
+*\r
+* ======>> 64 <<\r
+* ( --- vadr ) \r
+* Terminal Input Buffer address. \r
+* Note that this is a variable, so users may allocate their own buffers, but it must be @ed.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'TI' ; 'TIB'\r
+ DC.B 'B'|$80\r
+ DC.L RZERO-3-NATWID\r
+*TIB DC.L DOUSER\r
+TIB BSR.W DOUSER\r
+ DC.L XTIB-UORIG\r
+*\r
+* ======>> 65 <<\r
+* ( --- maxnamewidth )\r
+* This is the maximum width to which symbol names will be recorded.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'WIDT' ; 'WIDTH'\r
+ DC.B 'H'|$80\r
+ DC.L TIB-4-NATWID\r
+*WIDTH DC.L DOUSER\r
+WIDTH BSR.W DOUSER\r
+ DC.L XWIDTH-UORIG\r
+*\r
+* ======>> 66 <<\r
+* ( --- vadr ) \r
+* Availability of error messages on disk.\r
+* Contains 1 if messages available, \r
+* 0 if not,\r
+* -1 if a disk error has occurred.\r
+ EVEN\r
+ DC.B $87\r
+ DC.B 'WARNIN' ; 'WARNING'\r
+ DC.B 'G'|$80\r
+ DC.L WIDTH-6-NATWID\r
+*WARN DC.L DOUSER\r
+WARN BSR.W DOUSER\r
+ DC.L XWARN-UORIG\r
+*\r
+* ======>> 67 <<\r
+* ( --- vadr ) \r
+* Boundary for FORGET.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'FENC' ; 'FENCE'\r
+ DC.B 'E'|$80\r
+ DC.L WARN-8-NATWID\r
+*FENCE DC.L DOUSER\r
+FENCE BSR.W DOUSER\r
+ DC.L XFENCE-UORIG\r
+*\r
+* ======>> 68 <<\r
+* ( --- vadr ) \r
+* Dictionary pointer, fetched by HERE.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'D' ; 'DP' : points to first free byte at end of dictionary\r
+ DC.B 'P'|$80\r
+ DC.L FENCE-6-NATWID\r
+*DICTPT DC.L DOUSER\r
+DICTPT BSR.W DOUSER\r
+ DC.L XDICTP-UORIG\r
+*\r
+* ======>> 68.5 <<\r
+* ( --- vadr ) ******* Need to check what this is!\r
+* Used in maintaining vocabularies.\r
+* I think it points to the current "parent" vocabulary, but I'm not sure.\r
+* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****\r
+* According to the fig glossary, it is the pointer to the link field (parent link?)\r
+* of the most recently created vocabulary.\r
+* The glossary indicates that FORGET would use this to \r
+* "allow control for FORGETting thru multiple vocabularys",\r
+* which I am now guessing does not mean what I at one time thought it should mean.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $88\r
+ DC.B 'VOC-LIN' ; 'VOC-LINK'\r
+ DC.B 'N'|$80\r
+ DC.L DICTPT-3-NATWID\r
+*VOCLIN DC.L DOUSER\r
+VOCLIN BSR.W DOUSER\r
+ DC.L XVOCL-UORIG\r
+*\r
+* ======>> 69 <<\r
+* ( --- vadr ) \r
+* Disk block being interpreted. \r
+* Zero refers to terminal.\r
+* ******** Should be made a 64 bit user variable! ********\r
+* But the base system needs to have full 64 bit support, div and mul, etc.\r
+* before we can do that.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'BL' ; 'BLK'\r
+ DC.B 'K'|$80\r
+ DC.L VOCLIN-9-NATWID\r
+*BLK DC.L DOUSER\r
+BLK BSR.W DOUSER\r
+ DC.L XBLK-UORIG\r
+*\r
+* ======>> 70 <<\r
+* ( --- vadr ) \r
+* Input buffer offset/cursor.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'I' ; 'IN' : scan pointer for input line buffer\r
+ DC.B 'N'|$80\r
+ DC.L BLK-4-NATWID\r
+*IN DC.L DOUSER\r
+IN BSR.W DOUSER\r
+ DC.L XIN-UORIG\r
+*\r
+* ======>> 71 <<\r
+* ( --- vadr ) \r
+* Output buffer offset/cursor.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'OU' ; 'OUT'\r
+ DC.B 'T'|$80\r
+ DC.L IN-3-NATWID\r
+*OUT DC.L DOUSER\r
+OUT BSR.W DOUSER\r
+ DC.L XOUT-UORIG\r
+*\r
+* ======>> 72 <<\r
+* ( --- vadr ) \r
+* Screen currently being edited, once we have an editor running. \r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'SC' ; 'SCR'\r
+ DC.B 'R'|$80\r
+ DC.L OUT-4-NATWID\r
+*SCR DC.L DOUSER\r
+SCR BSR.W DOUSER\r
+ DC.L XSCR-UORIG\r
+* ######>> screen 37 <<\r
+*\r
+* ======>> 73 <<\r
+* ( --- vadr ) \r
+* Sector offset for LOADing screens,\r
+* set by DRIVE to make a new drive the default.\r
+* This should also be 64 bit, if we had full 64-bit math.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'OFFSE' ; 'OFFSET'\r
+ DC.B 'T'|$80\r
+ DC.L SCR-4-NATWID\r
+*OFSET DC.L DOUSER\r
+OFSET BSR.W DOUSER\r
+ DC.L XOFSET-UORIG\r
+*\r
+* ======>> 74 <<\r
+* ( --- vadr ) \r
+* Current context of interpretation (vocabulary root).\r
+ EVEN\r
+ DC.B $87\r
+ DC.B 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first\r
+ DC.B 'T'|$80\r
+ DC.L OFSET-7-NATWID\r
+*CONTXT DC.L DOUSER\r
+CONTXT BSR.W DOUSER\r
+ DC.L XCONT-UORIG\r
+*\r
+* ======>> 75 <<\r
+* ( --- vadr ) \r
+* Current context of definition (vocabulary root).\r
+ EVEN\r
+ DC.B $87\r
+ DC.B 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended\r
+ DC.B 'T'|$80\r
+ DC.L CONTXT-8-NATWID\r
+*CURENT DC.L DOUSER\r
+CURENT BSR.W DOUSER\r
+ DC.L XCURR-UORIG\r
+*\r
+* ======>> 76 <<\r
+* ( --- vadr ) \r
+* Compiler/interpreter state.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'STAT' ; 'STATE' : 1 if compiling, 0 if not\r
+ DC.B 'E'|$80\r
+ DC.L CURENT-8-NATWID\r
+*STATE DC.L DOUSER\r
+STATE BSR.W DOUSER\r
+ DC.L XSTATE-UORIG\r
+*\r
+* ======>> 77 <<\r
+* ( --- vadr ) \r
+* Numeric conversion base.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'BAS' ; 'BASE' : number base for all input & output\r
+ DC.B 'E'|$80\r
+ DC.L STATE-6-NATWID\r
+*BASE DC.L DOUSER\r
+BASE BSR.W DOUSER\r
+ DC.L XBASE-UORIG\r
+*\r
+* ======>> 78 <<\r
+* ( --- vadr ) \r
+* Decimal point location for output.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'DP' ; 'DPL'\r
+ DC.B 'L'|$80\r
+ DC.L BASE-5-NATWID\r
+*DPL DC.L DOUSER\r
+DPL BSR.W DOUSER\r
+ DC.L XDPL-UORIG\r
+*\r
+* ======>> 79 <<\r
+* ( --- vadr ) \r
+* Field width for I/O formatting.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'FL' ; 'FLD'\r
+ DC.B 'D'|$80\r
+ DC.L DPL-4-NATWID\r
+*FLD DC.L DOUSER\r
+FLD BSR.W DOUSER\r
+ DC.L XFLD-UORIG\r
+*\r
+* ======>> 80 <<\r
+* ( --- vadr ) \r
+* Compiler stack mark for stack check.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'CS' ; 'CSP'\r
+ DC.B 'P'|$80\r
+ DC.L FLD-4-NATWID\r
+*CSP DC.L DOUSER\r
+CSP BSR.W DOUSER\r
+ DC.L XCSP-UORIG\r
+*\r
+* ======>> 81 <<\r
+* ( --- vadr ) \r
+* Editing cursor location. \r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'R' ; 'R#'\r
+ DC.B '#'|$80\r
+ DC.L CSP-4-NATWID\r
+*RNUM DC.L DOUSER\r
+RNUM BSR.W DOUSER\r
+ DC.L XRNUM-UORIG\r
+*\r
+* ======>> 82 <<\r
+* ( --- vadr ) \r
+* Pointer to last HELD character in PAD.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'HL' ; 'HLD'\r
+ DC.B 'D'|$80\r
+ DC.L RNUM-3-NATWID\r
+*HLD DC.L DOCON\r
+HLD BSR.W DOCON\r
+ DC.L XHLD\r
+*\r
+* ======>> 82.5 <<== SPECIAL\r
+* ( --- vadr ) \r
+* Line width of active terminal.\r
+ EVEN\r
+ DC.B $87\r
+ DC.B 'COLUMN' ; 'COLUMNS' : line width of terminal\r
+ DC.B 'S'|$80\r
+ DC.L HLD-4-NATWID\r
+*COLUMS DC.L DOUSER\r
+COLUMS BSR.W DOUSER\r
+ DC.L XCOLUM-UORIG\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 38 <<\r
+**\r
+** An INCREMENTER probably should not be defined without a defined CONSTANT increment?\r
+** Ergo, defined in pairs --\r
+**\r
+** Make an INCREMENTER compiling word (not in model):\r
+** ( n --- )\r
+** { n INCREMENTER name } typical input\r
+** CREATE a header and compile the increment constant, \r
+** then overwrite the header with a call to DOINC.\r
+* DC.B $8B\r
+* DC.B 'INCREMENTE' ; 'INCREMENTER'\r
+* DC.B 'R'|$80\r
+* DC.L COLUMS-8-NATWID\r
+* INCR BSR.W DOCOL\r
+* CON,PSCODE\r
+** ( n --- ninc ) \r
+** Characteristic of an INCREMENTER.\r
+** This is probably too naive:\r
+* DOINC MOVE.L (RP)+,A0\r
+* MOVE.L (A0),D0 ; Get the increment,\r
+* ADD.L D0,(PSP) ; and add it.\r
+* RTS\r
+* Compiling word should check that it is compiling a CONSTANT.\r
+* On the other hand, there are reasons not to do this:\r
+*\r
+* ======>> 83 <<\r
+* ( n --- n+1 )\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '1' ; '1+'\r
+ DC.B '+'|$80\r
+ DC.L COLUMS-8-NATWID\r
+* Using the model keeps things semantically connected for other processors:\r
+*ONEP DC.L DOCOL,ONE,PLUS\r
+ONEP BSR.W DOCOL ; ... or I shall convince myself of such for now.\r
+ DC.L ONE,PLUS\r
+ DC.L SEMIS\r
+** Greedy alternative:\r
+* ONEPG MOVE.L (PSP),D0\r
+* ADD.L ONEV(PC),D0\r
+* MOVE.L D0,(PSP)\r
+* RTS\r
+* Naive alternative:\r
+* ONEPI BSR.W DOINC\r
+* DC.L 1\r
+* Naive alternative:\r
+* ONEP1 ADDQ.L #1,(PSP) ; It's hard to imagine 1+ being other than 1.\r
+* RTS\r
+*\r
+* ======>> 84 <<\r
+* ( n --- n+2 )\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '2' ; '2+'\r
+ DC.B '+'|$80\r
+ DC.L ONEP-3-NATWID\r
+* Using the model keeps things semantically connected for other processors:\r
+*TWOP DC.L DOCOL\r
+TWOP BSR.W DOCOL\r
+ DC.L TWO,PLUS\r
+ DC.L SEMIS\r
+** Greedy alternative:\r
+* TWOPG MOVE.L (PSP),D0\r
+* ADD.L TWOV(PC),D0\r
+* MOVE.L D0,(PSP)\r
+* RTS\r
+* Naive alternative:\r
+* TWOPI BSR.W DOINC\r
+* DC.L 2\r
+* Naive alternative:\r
+* TWOP2 ADDQ.L #2,(PSP) ; It's hard to imagine 2+ being other than 2.\r
+* RTS\r
+*\r
+* ======>> 85 <<\r
+* ( --- adr )\r
+* Get the DICTPT allocation, like a USER constant. \r
+* Should check the stack and heap for collision.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'HER' ; 'HERE'\r
+ DC.B 'E'|$80\r
+ DC.L TWOP-3-NATWID\r
+*HERE DC.L DOCOL\r
+HERE BSR.W DOCOL\r
+ DC.L DICTPT,AT\r
+ DC.L SEMIS\r
+*\r
+* ======>> 86 <<\r
+* ( n --- )\r
+* Increase/decrease heap (add n to DP),\r
+* Should ERROR check stack/heap.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'ALLO' ; 'ALLOT'\r
+ DC.B 'T'|$80\r
+ DC.L HERE-5-NATWID\r
+*ALLOT DC.L DOCOL\r
+ALLOT BSR.W DOCOL\r
+ DC.L DICTPT,PSTORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 87 <<\r
+* ( n --- )\r
+* Store word n at DP++,\r
+* Should ERROR check stack/heap.\r
+ EVEN\r
+ DC.B $81 ; , (COMMA)\r
+ DC.B ','|$80\r
+ DC.L ALLOT-6-NATWID\r
+*COMMA DC.L DOCOL\r
+COMMA BSR.W DOCOL\r
+ DC.L HERE,STORE,NATWC,ALLOT ; race condition\r
+ DC.L SEMIS\r
+*\r
+* ======>> 88 <<\r
+* ( b --- )\r
+* Store byte b at DP+,\r
+* Should ERROR check stack/heap.\r
+* Unfortunate naming.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'C' ; 'C,'\r
+ DC.B ','|$80\r
+ DC.L COMMA-2-NATWID\r
+*CCOMM DC.L DOCOL\r
+CCOMM BSR.W DOCOL\r
+ DC.L HERE,CSTORE,ONE,ALLOT ; race condition\r
+ DC.L SEMIS\r
+*\r
+* ( n --- )\r
+* Bump the DICTPT if necessary to odd or even alignment, according to n,\r
+* by compiling in an extra NUL byte.\r
+* Odd n for odd alignment, even n for even.\r
+ EVEN\r
+ DC.B $8B\r
+ DC.B 'ALIGN-COMM' ; 'ALIGN-COMMA'\r
+ DC.B 'A'|$80\r
+ DC.L CCOMM-3-NATWID\r
+*ALCOM DC.L DOCOL\r
+ALCOM BSR.W DOCOL\r
+ DC.L HERE,ZERO,ALGNB,ZBRAN\r
+ DC.L ALCOMX-*-NATWID\r
+ DC.L ZERO,CCOMM\r
+ALCOMX DC.L DROP\r
+ DC.L SEMIS\r
+*\r
+* Not in model, but needed for 32-bit.\r
+* ( h --- )\r
+* Store half cell h at DP+.\r
+* Should ERROR check stack/heap.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'H' ; 'H,'\r
+ DC.B ','|$80\r
+ DC.L ALCOM-12-NATWID\r
+*HCOMM DC.L DOCOL\r
+HCOMM BSR.W DOCOL\r
+ DC.L HERE,HSTORE,HNATWC,ALLOT ; race condition\r
+ DC.L SEMIS\r
+*\r
+* ======>> 89 <<\r
+* ( n1 n2 --- n1-n2 )\r
+* Subtract top two words.\r
+ EVEN\r
+ DC.B $81 ; -\r
+ DC.B '-'|$80\r
+ DC.L HCOMM-3-NATWID\r
+*SUB DC.L *+NATWID\r
+SUB MOVE.L (PSP)+,D0 ; Subtraction is not commutative.\r
+ SUB.L D0,(PSP) ; left side operand is the deeper one on the stack.\r
+ RTS\r
+* SUB DC.L DOCOL,MINUS,PLUS\r
+* DC.L SEMIS ; Costs extra bytes and lots of cycles compared to native code.\r
+*\r
+* ( d1 d2 --- d1-d2 )\r
+* Subtract top two integers.\r
+* Yes, we do want this in the model.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'D' ; D-\r
+ DC.B '-'|$80\r
+ DC.L SUB-2-NATWID\r
+*DSUB DC.L *+NATWID\r
+DSUB MOVEM.L (PSP)+,D0/D1/D2/D3 ; ADDX memory operand requires too much setup for just two long words.\r
+ SUB.L D1,D3 ; Right order for subtraction.\r
+ SUBX.L D0,D2\r
+ MOVEM.L D2/D3,-(PSP)\r
+ RTS\r
+*\r
+* ======>> 90 <<\r
+* ( n1 n2 --- n1==n2 )\r
+* Return flag true if n1 and n2 are equal, otherwise false.\r
+ EVEN\r
+ DC.B $81 ; =\r
+ DC.B '='|$80\r
+ DC.L DSUB-3-NATWID\r
+*EQUAL DC.L DOCOL\r
+EQUAL BSR.W DOCOL\r
+ DC.L SUB,ZEQU\r
+ DC.L SEMIS\r
+*\r
+* ======>> 91 <<\r
+* ( n1 n2 --- n1<n2 )\r
+* Return flag true if n1 is less than n2, otherwise false.\r
+* Signed compare.\r
+ EVEN\r
+ DC.B $81 ; <\r
+ DC.B '<'|$80 \r
+ DC.L EQUAL-2-NATWID\r
+*LESS DC.L *+NATWID\r
+LESS CLR.L D2 ; Guess false.\r
+ MOVE.L (PSP)+,D0\r
+ MOVE.L (PSP),D1\r
+ SUB.L D0,D1\r
+ BGE.S LESSST\r
+TRUE MOVEQ #1,D2 ; MOVEQ is a little faster than ADDQ.L\r
+LESSST MOVE.L D2,(PSP)\r
+ RTS\r
+* \r
+*\r
+* ======>> 92 <<\r
+* ( n1 n2 --- n1>n2 )\r
+* Return flag true if n1 is greater than n2, false otherwise.\r
+ EVEN\r
+ DC.B $81 ; >\r
+ DC.B '>'|$80\r
+ DC.L LESS-2-NATWID\r
+GREAT DC.L DOCOL,SWAP,LESS\r
+ DC.L SEMIS\r
+*\r
+* ======>> 93 <<\r
+* ( n1 n2 n3 --- n2 n3 n1 )\r
+* Rotate the top three words on stack,\r
+* bringing the third word to the top.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'RO' ; 'ROT'\r
+ DC.B 'T'|$80\r
+ DC.L GREAT-2-NATWID\r
+ROT DC.L *+NATWID\r
+ MOVEM.L (PSP),D0/D1/D2\r
+ MOVEM.L D0/D1,NATWID(PSP)\r
+ MOVE.L D2,(PSP)\r
+ RTS\r
+*\r
+* ======>> 94 <<\r
+* ( --- )\r
+* EMIT a SPACE.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'SPAC' ; 'SPACE'\r
+ DC.B 'E'|$80\r
+ DC.L ROT-4-NATWID\r
+SPACE DC.L DOCOL,BL,EMIT\r
+ DC.L SEMIS\r
+*\r
+* ======>> 95 <<\r
+* ( n0 n1 --- min(n0,n1) )\r
+* Leave the minimum of the top two integers.\r
+* Being too greedy here, but, whatever.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'MI' ; 'MIN'\r
+ DC.B 'N'|$80\r
+ DC.L SPACE-6-NATWID\r
+MIN DC.L *+NATWID\r
+ MOVE.L (PSP)+,D0\r
+ CMP.L (PSP),D0\r
+ BGE.S MINX\r
+ MOVE.L D0,(PSP) \r
+MINX RTS \r
+* MIN DC.L DOCOL,OVER,OVER,GREAT,ZBRAN\r
+* DC.L MIN2-*-NATWID\r
+* DC.L SWAP\r
+* MIN2 DC.L DROP\r
+* DC.L SEMIS\r
+*\r
+* ======>> 96 <<\r
+* ( n0 n1 --- max(n0,n1) )\r
+* Leave the maximum of the top two integers.\r
+* Really should leave this as in the model, to reduce testing.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'MA' ; 'MAX'\r
+ DC.B 'X'|$80\r
+ DC.L MIN-4-NATWID\r
+MAX DC.L *+NATWID\r
+ MOVE.L (PSP)+,D0\r
+ CMP.L (PSP),D0\r
+ BLE.S MAXX\r
+ MOVE.L D0,(PSP) \r
+MAXX RTS \r
+* MAX DC.L DOCOL,OVER,OVER,LESS,ZBRAN\r
+* DC.L MAX2-*-NATWID\r
+* DC.L SWAP\r
+* MAX2 DC.L DROP\r
+* DC.L SEMIS\r
+*\r
+* ======>> 97 <<\r
+* ( 0 --- 0 )\r
+* ( n --- n n )\r
+* DUP if non-zero.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B '-DU' ; '-DUP'\r
+ DC.B 'P'|$80\r
+ DC.L MAX-4-NATWID\r
+DDUP DC.L *+NATWID ; Just being greedy for speed.\r
+ MOVE.L (PSP),D0\r
+ BEQ.S DDUPX\r
+ MOVE.L D0,-(PSP)\r
+DDUPX RTS\r
+* DDUP DC.L DOCOL,DUP,ZBRAN\r
+* DC.L DDUP2-*-NATWID\r
+* DC.L DUP\r
+* DDUP2 DC.L SEMIS\r
+*\r
+* ######>> screen 39 <<\r
+* ======>> 98.1 <<\r
+* Supplemental, intended to be used in refactoring TRAVERSE,\r
+* But really would not work there without more code:\r
+* ( n<0 --- -1 )\r
+* ( n>=~ --- 1 )\r
+* Change top integer to its sign.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'SIGNU' ; 'SIGNUM'\r
+ DC.B 'M'|$80\r
+ DC.L DDUP-5-NATWID\r
+SIGNUM DC.L *+NATWID\r
+SIGNUE CLR.L D0\r
+ TST.L (PSP)\r
+ SMI D0\r
+ EXT.W D0\r
+ EXT.L D0\r
+ MOVE.L D0,(PSP)\r
+ RTS\r
+*\r
+* ======>> 98 <<\r
+* ( adr1 direction --- adr2 )\r
+* TRAVERSE the symbol name.\r
+* If direction is 1, find the end.\r
+* If direction is -1, find the beginning.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $88\r
+ DC.B 'TRAVERS' ; 'TRAVERSE'\r
+ DC.B 'E'|$80\r
+ DC.L SIGNUM-7-NATWID\r
+*TRAV DC.L *+NATWID\r
+* MOVEQ #1,D1 ; Convert negative to -1, zero or positive to 1.\r
+* TST.L (PSP)+\r
+* BPL.S TRAVG\r
+* NEG.L D1\r
+*TRAVG MOVE.L (PSP),A0\r
+** MOVEQ #$7F,D0\r
+** TRAVLP LEA (A0,D1.L),A0 ; Don't look at the one we start at.\r
+** CMP.B (A0),D0 ; This follows the FORTH code, but, we could just look at sign bit.\r
+** BCC.S TRAVLP\r
+* CLR.L D0 ; Scan by indexing so we can limit it.\r
+*TRAVLP ADD.L D1,D0 ; Don't look at (A0).\r
+* TST.B (A0,D0.L)\r
+* BMI.S TRAVDN\r
+* TST.L D1 ; Limit the scan in the selected direction.\r
+* BMI.S TRAVLN\r
+* CMP.W #32,D0\r
+* BCS.S TRAVLP\r
+*TRAVLN CMP.W #-31,D0\r
+* BPL.S TRAVLP\r
+*TRAVDN LEA (A0,D0.L),A0\r
+* MOVE.L A0,(PSP)\r
+* RTS\r
+* Doing this in 68000 or 6809 just because it can be done was getting too greedy.\r
+* Or not? I needed it to test that TRAVERSE was not screwing up.\r
+TRAV DC.L DOCOL\r
+* DC.L TRON ; DBUG *****\r
+ DC.L SWAP\r
+TRAV2 DC.L OVER,PLUS,LIT16\r
+ DC.W $7F\r
+ DC.L OVER,CAT,LESS,ZBRAN\r
+ DC.L TRAV2-*-NATWID\r
+ DC.L SWAP,DROP\r
+* DC.L TROFF ; DBG *****\r
+ DC.L SEMIS\r
+*\r
+* ======>> 99 <<\r
+* ( --- symptr )\r
+* Fetch CURRENT as a per-USER constant.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'LATES' ; 'LATEST'\r
+ DC.B 'T'|$80\r
+ DC.L TRAV-9-NATWID\r
+LATEST DC.L DOCOL,CURENT,AT,AT\r
+ DC.L SEMIS\r
+* LATEST DC.L *+NATWID\r
+* Getting too greedy:\r
+* MOVE.L XCURR-UORIG(UP),D0\r
+* MOVE.L (UP,D0.L),A0\r
+* MOVE.L (A0),A0\r
+* MOVE.L A0,-(PSP)\r
+* RTS\r
+* Too greedy, still too many smantic holes in the model to fall through.\r
+* Also, if the address at the CFA is made relative, \r
+* this is part of the code that would be affected --\r
+* especially if it is in native CPU code.\r
+*\r
+* ======>> 100 <<\r
+* Wanted to do these as INCREMENTERs,\r
+* but I need to stick with the model as much as possible,\r
+* (mostly, LOL) adding code only to make the model more clear.\r
+* ( pfa --- lfa ) \r
+* Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'LF' ; 'LFA'\r
+ DC.B 'A'|$80\r
+ DC.L LATEST-7-NATWID\r
+LFA DC.L DOCOL,LIT16\r
+* DC.W 4 ; on 6800\r
+ DC.W 2*NATWID\r
+ DC.L SUB\r
+ DC.L SEMIS\r
+*\r
+* ======>> 101 <<\r
+* ( pfa --- cfa ) \r
+* Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'CF' ; 'CFA'\r
+ DC.B 'A'|$80\r
+ DC.L LFA-4-NATWID\r
+* CFA DC.L DOCOL,TWO,SUB ; on 6800\r
+CFA DC.L DOCOL,NATWC,SUB\r
+ DC.L SEMIS\r
+*\r
+* ======>> 102 <<\r
+* ( pfa --- nfa ) \r
+* Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'NF' ; 'NFA'\r
+ DC.B 'A'|$80\r
+ DC.L CFA-4-NATWID\r
+NFA DC.L DOCOL,LIT16\r
+* DC.W 5 ; on 6800\r
+ DC.W NATWID*2+1\r
+ DC.L SUB,ONE,MINUS,TRAV\r
+ DC.L SEMIS\r
+*\r
+* ======>> 103 <<\r
+* ( nfa --- pfa ) \r
+* Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'PF' ; 'PFA'\r
+ DC.B 'A'|$80\r
+ DC.L NFA-4-NATWID\r
+PFA DC.L DOCOL,ONE,TRAV,LIT16\r
+* DC.W 5 ; on 6800\r
+ DC.W NATWID*2+1\r
+ DC.L PLUS\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 40 <<\r
+* ======>> 104 <<\r
+* ( --- )\r
+* Save the parameter stack pointer in CSP for compiler checks.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B '!CS' ; '!CSP'\r
+ DC.B 'P'|$80\r
+ DC.L PFA-4-NATWID\r
+SCSP DC.L DOCOL,SPAT,CSP,STORE\r
+ DC.L SEMIS\r
+*\r
+ PAGE\r
+*\r
+* ======>> 105 <<\r
+* ( 0 n --- ) ( *** )\r
+* ( true n --- IN BLK ) ( anything *** nothing )\r
+* If flag is false, do nothing. \r
+* If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR. \r
+* Leaves cursor position (IN)\r
+* and currently loading block number (BLK) on stack, for analysis.\r
+*\r
+* This one is too important to be high-level Forth codes.\r
+* When we have an error, we want to disturb as little as possible.\r
+* But fixing that cascades through ERROR and MESSAGE \r
+* into the disk block system.\r
+* And we aren't ready for that yet.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B '?ERRO' ; '?ERROR'\r
+ DC.B 'R'|$80\r
+ DC.L SCSP-5-NATWID\r
+* QERR DC.L *+NATWID\r
+* TST.L NATWID(PSP)\r
+* BNE.S QERROR\r
+* LEA NATWID(PSP),PSP\r
+* RTS\r
+** this doesn't work anyway: \r
+* QERROR BRA.W ERROR\r
+QERR DC.L DOCOL,SWAP,ZBRAN\r
+ DC.L QERR2-*-NATWID\r
+ DC.L ERROR,BRAN\r
+ DC.L QERR3-*-NATWID\r
+QERR2 DC.L DROP\r
+QERR3 DC.L SEMIS\r
+* \r
+* ======>> 106 <<\r
+* STATE is compiling:\r
+* ( --- ) ( *** )\r
+* STATE is not compiling:\r
+* ( --- IN BLK ) ( anything *** nothing )\r
+* ERROR if not compiling.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B '?COM' ; '?COMP'\r
+ DC.B 'P'|$80\r
+ DC.L QERR-7-NATWID\r
+QCOMP DC.L DOCOL,STATE,AT,ZEQU,LIT16\r
+ DC.W $11\r
+ DC.L QERR\r
+ DC.L SEMIS\r
+*\r
+* ======>> 107 <<\r
+* STATE is executing:\r
+* ( --- ) ( *** )\r
+* STATE is not executing:\r
+* ( --- IN BLK ) ( anything *** nothing )\r
+* ERROR if not executing.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B '?EXE' ; '?EXEC'\r
+ DC.B 'C'|$80\r
+ DC.L QCOMP-6-NATWID\r
+QEXEC DC.L DOCOL,STATE,AT,LIT16\r
+ DC.W $12\r
+ DC.L QERR\r
+ DC.L SEMIS\r
+*\r
+* ======>> 108 <<\r
+* ( n1 n1 --- ) ( *** )\r
+* ( n1 n2 --- IN BLK ) ( anything *** nothing )\r
+* ERROR if top two are unequal. \r
+* MESSAGE says compiled conditionals do not match.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B '?PAIR' ; '?PAIRS'\r
+ DC.B 'S'|$80\r
+ DC.L QEXEC-6-NATWID\r
+QPAIRS DC.L DOCOL,SUB,LIT16\r
+ DC.W $13\r
+ DC.L QERR\r
+ DC.L SEMIS\r
+*\r
+* ======>> 109 <<\r
+* CSP and parameter stack are balanced (equal):\r
+* ( --- ) ( *** )\r
+* CSP and parameter stack are not balanced (unequal):\r
+* ( --- IN BLK ) ( anything *** nothing )\r
+* ERROR if return/control stack is not at same level as last !CSP.\r
+* Usually indicates that a definition has been left incomplete.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B '?CS' ; '?CSP'\r
+ DC.B 'P'|$80\r
+ DC.L QPAIRS-7-NATWID\r
+QCSP DC.L DOCOL,SPAT,CSP,AT,SUB,LIT16\r
+ DC.W $14\r
+ DC.L QERR\r
+ DC.L SEMIS\r
+*\r
+* ======>> 110 <<\r
+* Active BLK input:\r
+* ( --- ) ( *** )\r
+* No active BLK input:\r
+* ( --- IN BLK ) ( anything *** nothing )\r
+* ERROR if not loading, i. e., if BLK is zero.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $88\r
+ DC.B '?LOADIN' ; '?LOADING'\r
+ DC.B 'G'|$80\r
+ DC.L QCSP-5-NATWID\r
+QLOAD DC.L DOCOL,BLK,AT,ZEQU,LIT16\r
+ DC.W $16\r
+ DC.L QERR\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 41 <<\r
+* ======>> 111 <<\r
+* ( --- )\r
+* Compile an in-line literal value from the instruction stream.\r
+ EVEN\r
+ DC.B $87\r
+ DC.B 'COMPIL' ; 'COMPILE'\r
+ DC.B 'E'|$80\r
+ DC.L QLOAD-9-NATWID\r
+* COMPIL DC.L DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA\r
+* COMPIL DC.L DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA\r
+COMPIL DC.L DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA\r
+ DC.L SEMIS\r
+*\r
+* ======>> 112 <<\r
+* ( --- ) P\r
+* Clear the compile state bit(s) (shift to interpret).\r
+ EVEN\r
+ DC.B $C1 ; [ immediate\r
+ DC.B '['|$80\r
+ DC.L COMPIL-8-NATWID\r
+LBRAK DC.L DOCOL,ZERO,STATE,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 113 <<\r
+* \r
+STCOMP EQU $C0\r
+* ( --- )\r
+* Set the compile state bit(s) (shift to compile).\r
+ EVEN\r
+ DC.B $81 ; ]\r
+ DC.B ']'|$80\r
+ DC.L LBRAK-2-NATWID\r
+RBRAK DC.L DOCOL,LIT16\r
+ DC.W STCOMP\r
+ DC.L STATE,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 114 <<\r
+* ( --- )\r
+* Toggle SMUDGE bit of LATEST definition header,\r
+* to hide it until defined or reveal it after definition.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'SMUDG' ; 'SMUDGE'\r
+ DC.B 'E'|$80\r
+ DC.L RBRAK-2-NATWID\r
+SMUDGE DC.L DOCOL,LATEST,LIT16\r
+ DC.W FSMUDG\r
+ DC.L TOGGLE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 115 <<\r
+* ( --- )\r
+* Set the conversion base to sixteen (b00010000).\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'HE' ; 'HEX'\r
+ DC.B 'X'|$80\r
+ DC.L SMUDGE-7-NATWID\r
+HEX DC.L DOCOL\r
+ DC.L LIT16\r
+ DC.W 16 ; decimal sixteen\r
+ DC.L BASE,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 116 <<\r
+* ( --- )\r
+* Set the conversion base to ten (b00001010).\r
+ EVEN\r
+ DC.B $87\r
+ DC.B 'DECIMA' ; 'DECIMAL'\r
+ DC.B 'L'|$80\r
+ DC.L HEX-4-NATWID\r
+DEC DC.L DOCOL\r
+ DC.L LIT16\r
+ DC.W 10 ; decimal ten\r
+ DC.L BASE,STORE\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 42 <<\r
+* ======>> 117 <<\r
+* ( --- ) ( IP *** ) \r
+* Pop the saved IP and use it to \r
+* compile the latest symbol as a reference to a ;CODE definition;\r
+* overwrite the code field of the symbol found by LATEST\r
+* with the address of the low-level characteristic code\r
+* provided in the defining definition.\r
+* Look closely at where things return, consider the operation of R> and >R .\r
+*\r
+* The machine-level code which follows (;CODE) in the instruction stream\r
+* is not executed by the defining symbol,\r
+* but becomes the characteristic of the defined symbol. \r
+* This is the usual way to generate the characteristics of VARIABLEs,\r
+* CONSTANTs, COLON definitions, etc., when FORTH compiles itself. \r
+*\r
+* Finally, note that, if code shifts from low level back to high \r
+* (native CPU machine code calling into a list of FORTH codes),\r
+* the low level code can't just call a high-level definition. \r
+* Leaf definitions can directly call other leaf definitions, \r
+* but not non-leafs.\r
+* It will need an anonymous list, probably embedded in the low-level code,\r
+* and Y and X will have to be set appropriately before entering the list.\r
+\r
+*********\r
+********* This will have to fix up the initial branch according to the offset to the characteristic:\r
+* BSR.S (2 bytes)\r
+* BSR.W (4 bytes)\r
+* MOVE.L #difference,IX; JMP (PC,IX.L) or something (6 bytes, for those that don't have BSR.L)\r
+*********\r
+*\r
+* BSR.S offset and BSR.W offsets are both from the address of the word following the op-code lead word, \r
+* which is kind of awkward. \r
+* Use TARGL as dummy target, to avoid semantics of 0 offset.\r
+* Since the 68000 does not have BSR.L (not until the 68020), long offset branches will have to be synthesized:\r
+DOASML MOVE.L #TARGL-*,A0 ; 6 bytes, overwrite offset in long word following opcode\r
+ JSR TARGL(PC,A0.L) ; 4 bytes, offset should be forced to 0\r
+* I do not like the way it's handling the offset for PC relative, indexed.\r
+TARGL:\r
+* 3206 T 00003952 207C0000000A DOASML MOVE.L #TARGL-*,A0 ; 6 bytes, overwrite offset in long word following opcode\r
+* 3207 T 00003958 4EBB8802 JSR TARGL(PC,A0.L) ; 4 bytes, offset should be forced to 0\r
+* 3209 T 0000395C TARGL:\r
+DOASMW BSR.W TARGL ; overwrite offset following 16-bit op-code.\r
+* 3213 T 0000395C 6100FFFE DOASMW BSR.W TARGL ; overwrite offset following 16-bit op-code.\r
+DOASMS BSR.S TARGL ; overwrite offset in 2nd byte of op-code.\r
+* 3215 T 00003960 61FA DOASMS BSR.S TARGL ; overwrite offset in 2nd byte of op-code.\r
+\r
+ EVEN\r
+ DC.B $87\r
+ DC.B '(;CODE' ; '(;CODE)'\r
+ DC.B ')'|$80\r
+ DC.L DEC-8-NATWID\r
+* PSCODE DC.L DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE\r
+PSCODE DC.L DOCOL,FROMR ; A5/IP is post-inc, needs no adjustment.\r
+ DC.L LATEST,PFA,CFA,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 118 <<\r
+* ( --- ) P\r
+* ?CSP to see if there are loose ends in the defining definition\r
+* before shifting to the assembler,\r
+* compile (;CODE) in the defining definition's instruction stream,\r
+* shift to interpreting,\r
+* make the ASSEMBLER vocabulary current,\r
+* and !CSP to mark the stack\r
+* in preparation for assembling low-level code.\r
+* Note that ;CODE, unlike DOES>, is IMMEDIATE,\r
+* and compiles (;CODE),\r
+* which will do the actual work of changing\r
+* the LATEST definition's characteristic when the defining word runs.\r
+* Assembly is done by the interpreter, rather than the compiler.\r
+* I could have avoided the anomalous three-byte code fields by\r
+*\r
+* Note that the ASSEMBLER is not part of the model (at this time).\r
+* That means that, until the assembler is ready, \r
+* if you want to define low-level words,\r
+* you have to poke (comma) in hand-assembled stuff.\r
+*\r
+ EVEN\r
+ DC.B $C5 immediate\r
+ DC.B ';COD' ; ';CODE'\r
+ DC.B 'E'|$80\r
+ DC.L PSCODE-8-NATWID\r
+SEMIC DC.L DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK\r
+ DC.L NOOP ; note: will be replaced by "ASSEMBLER" later\r
+ DC.L SEMIS\r
+* note: I think I'd rather keep ?STACK here, so I'm adding a NOOP to be patched later. \r
+*\r
+* ######>> screen 43 <<\r
+* ======>> 119 <<\r
+* ( --- ) C\r
+* Make the word currently being defined\r
+* build a header for DOES> definitions. \r
+* Actually just compiles a CONSTANT zero\r
+* which can be overwritten later by DOES>.\r
+* Since the fig models were established, this technique has been deprecated.\r
+*\r
+* Note that <BUILDS is not IMMEDIATE,\r
+* and therefore executes during a definition's run-time,\r
+* rather than its compile-time. \r
+* It is not intended to be used directly,\r
+* but rather so that one definition word can build another. \r
+* Also, note that nothing particularly special happens\r
+* in the defining definition until DOES> executes. \r
+* The name <BUILDS is intended to be a reminder of what is about to occur.\r
+*\r
+* <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.\r
+ EVEN\r
+ DC.B $87\r
+ DC.B '<BUILD' ; '<BUILDS'\r
+ DC.B 'S'|$80\r
+ DC.L SEMIC-6-NATWID\r
+BUILDS DC.L DOCOL,ZERO,CON\r
+ DC.L SEMIS\r
+*\r
+* ======>> 120 <<\r
+* ( --- ) ( IP *** ) C\r
+* Define run-time behavior of definitions compiled/defined\r
+* by a high-level defining definition --\r
+* the FORTH equivalent of a compiler-compiler. \r
+* DOES> assumes that the LATEST symbol table entry\r
+* has at least one word of parameter field,\r
+* which <BUILDS provides. \r
+* Note that DOES> is also not IMMEDIATE. \r
+*\r
+* When the defining word containing DOES> executes the DOES> icode,\r
+* it overwrites the LATEST symbol's CFA with jsr <XDOES,\r
+* overwrites the first word of that symbol's parameter field with its own IP,\r
+* and pops the previous IP from the return stack.\r
+* The icodes which follow DOES> in the stream\r
+* do not execute at the defining word's run-time.\r
+*\r
+* Examining XDOES in the virtual machine shows\r
+* that the defined word will execute those icodes\r
+* which follow DOES> at its own run-time. \r
+*\r
+* The advantage of this kind of behaviour,\r
+* which you will also note in ;CODE,\r
+* is that the defined word can contain\r
+* both operations and data to be operated on. \r
+* This is how FORTH data objects define their own behavior. \r
+*\r
+* Finally, note that the effective parameter field for DOES> definitions\r
+* starts two NATWID words after the CFA, instead of just one\r
+* (eight bytes instead of four in a thirty-two-bit addressing Forth).\r
+*\r
+* VOCABULARYs will use this. See definition of word FORTH.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'DOES' ; 'DOES>'\r
+ DC.B '>'|$80\r
+ DC.L BUILDS-8-NATWID\r
+* DOES DC.L DOCOL,FROMR,TWOP,LATEST,PFA,STORE\r
+DOES DC.L DOCOL,FROMR ; A5/IP is post-inc, needs no adjustment.\r
+ DC.L LATEST,PFA,STORE\r
+ DC.L PSCODE\r
+*\r
+* ( --- PFA+NATWID ) ( *** IP )\r
+* Characteristic of a DOES> defined word. \r
+* The characteristics of DOES> definitions are written in high-level\r
+* Forth codes rather than native CPU machine level code.\r
+* The first parameter word points to the high-level characteristic. \r
+* This routine's job is to push the IP,\r
+* load the high level characteristic pointer in IP,\r
+* and leave the address following the characteristic pointer on the stack\r
+* so the parameter field can be accessed.\r
+DODOES MOVE.L (RP),A0\r
+ MOVE.L IP,(RP) ; Save/nest the current IP on the return stack.\r
+ MOVE.L (W),IP ; First parameter is new IP.\r
+ LEA NATWID(W),A1 ; Address of second parameter.\r
+ MOVE.L A1,-(PSP) ; Note that PEA would push on Forth RP\r
+ JMP (A0) ; return to NEXT.\r
+*\r
+* ######>> screen 44 <<\r
+* ======>> 121 <<\r
+* ( strptr --- strptr+1 count )\r
+* Convert counted string to string and count. \r
+* (Fetch the byte at strptr, post-increment.)\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'COUN' ; 'COUNT'\r
+ DC.B 'T'|$80\r
+ DC.L DOES-6-NATWID\r
+COUNT DC.L DOCOL,DUP,ONEP,SWAP,CAT\r
+ DC.L SEMIS\r
+*\r
+* ======>> 122 <<\r
+* ( strptr count --- )\r
+* EMIT count characters at strptr.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'TYP' ; 'TYPE'\r
+ DC.B 'E'|$80\r
+ DC.L COUNT-6-NATWID\r
+TYPE DC.L DOCOL,DDUP,ZBRAN\r
+ DC.L TYPE3-*-NATWID\r
+ DC.L OVER,PLUS,SWAP,XDO\r
+TYPE2 DC.L I,CAT,EMIT,XLOOP\r
+ DC.L TYPE2-*-NATWID\r
+ DC.L BRAN\r
+ DC.L TYPE4-*-NATWID\r
+TYPE3 DC.L DROP\r
+TYPE4 DC.L SEMIS\r
+*\r
+* ======>> 123 <<\r
+* ( strptr count1 --- strptr count2 )\r
+* Supress trailing blanks (subtract count of trailing blanks from strptr).\r
+ EVEN\r
+ DC.B $89\r
+ DC.B '-TRAILIN' ; '-TRAILING'\r
+ DC.B 'G'|$80\r
+ DC.L TYPE-5-NATWID\r
+DTRAIL DC.L DOCOL,DUP,ZERO,XDO\r
+DTRAL2 DC.L OVER,OVER,PLUS,ONE,SUB,CAT,BL\r
+ DC.L SUB,ZBRAN\r
+ DC.L DTRAL3-*-NATWID\r
+ DC.L LEAVE,BRAN\r
+ DC.L DTRAL4-*-NATWID\r
+DTRAL3 DC.L ONE,SUB\r
+DTRAL4 DC.L XLOOP\r
+ DC.L DTRAL2-*-NATWID\r
+ DC.L SEMIS\r
+*\r
+* ======>> 124 <<\r
+* ( --- ) \r
+* TYPE counted string out of instruction stream (updating IP).\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B '(."' ; '(.")'\r
+ DC.B ')'|$80\r
+ DC.L DTRAIL-10-NATWID\r
+* PDOTQ DC.L DOCOL,R,TWOP,COUNT,DUP,ONEP\r
+* PDOTQ DC.L DOCOL,R,NATP,COUNT,DUP,ONEP\r
+PDOTQ DC.L DOCOL,R ; A5/IP is post-inc.\r
+ DC.L COUNT,DUP,ONEP ; There's a count byte, too.\r
+ DC.L ZERO,ALGNB,PLUS ; Align the count.\r
+ DC.L FROMR,PLUS,TOR ; IP ready to continue after the string.\r
+ DC.L TYPE\r
+ DC.L BREAK ; DBG *****\r
+ DC.L SEMIS\r
+*\r
+* ======>> 125 <<\r
+* ( --- ) P\r
+* { ." something-to-be-printed " } typical input\r
+* Use WORD to parse to trailing quote;\r
+* if compiling, compile XDOTQ and string parsed,\r
+* otherwise, TYPE string.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $C2 immediate\r
+ DC.B '.' ; '."'\r
+ DC.B '"'|$80\r
+ DC.L PDOTQ-5-NATWID\r
+DOTQ DC.L DOCOL\r
+ DC.L LIT16\r
+ DC.W $22 ascii quote\r
+ DC.L STATE,AT,ZBRAN\r
+ DC.L DOTQ1-*-NATWID\r
+ DC.L COMPIL,PDOTQ,WORD\r
+ DC.L HERE,CAT,ONEP,DUP,ALLOT\r
+ DC.L ALGNB,ZBRAN ; Rely on PDOTQ to adjust the IP for the odd length.\r
+ DC.L DOTQ0-*-NATWID\r
+ DC.L ZERO,CCOMM ; Align and fill with NUL\r
+DOTQ0 DC.L BRAN\r
+ DC.L DOTQ2-*-NATWID\r
+DOTQ1 DC.L WORD,HERE,COUNT,TYPE\r
+DOTQ2 DC.L SEMIS\r
+*\r
+* ######>> screen 45 <<\r
+* ======>> 126 <<== MACHINE DEPENDENT\r
+* ( --- ) ( *** )\r
+* ( --- IN BLK ) ( anything *** nothing )\r
+* ERROR if parameter stack out of bounds.\r
+* \r
+* But checking whether the stack is in bounds or not\r
+* really should not use the stack.\r
+* And there really should be a ?RSTACK, as well.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B '?STAC' ; '?STACK'\r
+ DC.B 'K'|$80\r
+ DC.L DOTQ-3-NATWID\r
+QSTACK DC.L DOCOL,LIT16\r
+* DC.W $12\r
+ DC.W SINIT-ORIG\r
+* But why use that instead of XSPZER (S0)?\r
+* Multi-user or multi-tasking would not want that.\r
+* CMP.L XSPZER-UORIG(UP),PSP ; something like this \r
+* DC.L PORIG,AT,TWO,SUB,SPAT,LESS,ONE\r
+ DC.L PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.\r
+ DC.L QERR\r
+* prints 'empty stack'\r
+*\r
+QSTAC2 DC.L SPAT\r
+* Here, we compare with a value at least 128\r
+* higher than dict. ptr. (DICTPT)\r
+* DC.L HERE,LIT16\r
+* DC.W $80 ; This is a rough check anyway, leave it as is. \r
+* But shouldn't it be the terminal width?\r
+ DC.L HERE,COLUMS,AT\r
+ DC.L PLUS,LESS,ZBRAN\r
+ DC.L QSTAC3-*-NATWID\r
+ DC.L TWO ; NOT the NATWID constant!\r
+ DC.L QERR\r
+* prints 'full stack'\r
+*\r
+QSTAC3 DC.L SEMIS\r
+*\r
+* ======>> 127 << this word's function\r
+* is done by ?STACK in this version\r
+* EVEN\r
+* DC.B $85\r
+* DC.B 4,?FREE\r
+* DC.B 'E'|$80\r
+* DC.L QSTACK-7-NATWID\r
+*QFREE DC.L DOCOL,SPAT,HERE,LIT16\r
+* DC.W $80\r
+* DC.L PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 46 <<\r
+* ======>> 128 <<\r
+* ( buffer n --- )\r
+* ***** Check that this is how it works here:\r
+* Get up to n-1 characters from the keyboard,\r
+* storing at buffer and echoing, with backspace editing,\r
+* quitting when a CR is read.\r
+* Terminate it with a NUL.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'EXPEC' ; 'EXPECT'\r
+ DC.B 'T'|$80\r
+ DC.L QSTACK-7-NATWID\r
+EXPECT DC.L DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area\r
+* EXPEC2 DC.L KEY,DUP,LIT16\r
+EXPEC2 DC.L KEY\r
+ DC.L DUP,LIT16\r
+ DC.W BACKSP-ORIG ; again, this should be in the per-task table\r
+ DC.L PORIG,AT,EQUAL,ZBRAN ; check for backspacing \r
+ DC.L EXPEC3-*-NATWID\r
+ DC.L DROP,LIT16\r
+ DC.W 8 ; ( backspace character to emit )\r
+ DC.L OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters \r
+ DC.L TOR,SUB,BRAN\r
+ DC.L EXPEC6-*-NATWID\r
+EXPEC3 DC.L DUP,LIT16\r
+ DC.W $D ; ( carriage return )\r
+ DC.L EQUAL,ZBRAN\r
+ DC.L EXPEC4-*-NATWID\r
+* DC.L BREAK ; dbg\r
+ DC.L LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.\r
+ DC.L EXPEC5-*-NATWID\r
+EXPEC4 DC.L DUP\r
+* DC.L BREAK ; dbg\r
+EXPEC5 DC.L I,CSTORE,ZERO,I,ONEP,CSTORE,ZERO,I,TWOP,CSTORE ; save two NULs to make sure address is even\r
+EXPEC6 DC.L EMIT,XLOOP\r
+ DC.L EXPEC2-*-NATWID\r
+ DC.L DROP\r
+ DC.L SEMIS\r
+*\r
+* ======>> 129 <<\r
+* ( --- )\r
+* EXPECT terminal width characters to TIB.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'QUER' ; 'QUERY'\r
+ DC.B 'Y'|$80\r
+ DC.L EXPECT-7-NATWID\r
+QUERY DC.L DOCOL,TIB,AT,COLUMS,AT\r
+* DC.L TRON ; dbg *****\r
+ DC.L EXPECT,ZERO,IN,STORE\r
+* DC.L TROFF ; dbg *****\r
+ DC.L SEMIS\r
+*\r
+* ======>> 130 <<\r
+* ( --- ) P\r
+* End interpretation of a line or screen, and/or prepare for a new block. \r
+* Note that the name of this definition is an empty string,\r
+* so it matches on the terminating NUL in the terminal or block buffer.\r
+ EVEN\r
+ DC.B $C1 ; immediate < carriage return >\r
+ DC.B $00|$80 ; NUL character (end of buffered text)\r
+ DC.L QUERY-6-NATWID\r
+NULL DC.L DOCOL,BLK,AT,ZBRAN\r
+ DC.L NULL2-*-NATWID\r
+ DC.L ONE,BLK,PSTORE\r
+ DC.L ZERO,IN,STORE,BLK,AT,BSCR,MOD\r
+ DC.L ZEQU\r
+* check for end of screen\r
+ DC.L ZBRAN\r
+ DC.L NULL1-*-NATWID\r
+ DC.L QEXEC,FROMR,DROP\r
+NULL1 DC.L BRAN\r
+ DC.L NULL3-*-NATWID\r
+NULL2 DC.L FROMR,DROP\r
+NULL3 DC.L SEMIS\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 47 <<\r
+* ======>> 133 <<\r
+* ( adr n b --- )\r
+* Fill n bytes at adr with b.\r
+* This relies on CMOVE having a certain lack of parameter checking,\r
+* where overlapping regions are not properly inverted in copy.\r
+* And this really should be done in low-level.\r
+* None of the advantages of doing things in high-level apply to fill.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'FIL' ; 'FILL'\r
+ DC.B 'L'|$80\r
+ DC.L NULL-2-NATWID\r
+FILL DC.L DOCOL\r
+* DC.L BREAK ; DBG\r
+ DC.L SWAP,TOR,OVER,CSTORE,DUP,ONEP\r
+ DC.L FROMR,ONE,SUB,CMOVE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 134 <<\r
+* ( adr n --- )\r
+* Fill n bytes with 0.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'ERAS' ; 'ERASE'\r
+ DC.B 'E'|$80\r
+ DC.L FILL-5-NATWID\r
+ERASE DC.L DOCOL,ZERO,FILL\r
+ DC.L SEMIS\r
+*\r
+* ======>> 135 <<\r
+* ( adr n --- )\r
+* Fill n bytes with ASCII SPACE.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'BLANK' ; 'BLANKS'\r
+ DC.B 'S'|$80\r
+ DC.L ERASE-6-NATWID\r
+BLANKS DC.L DOCOL,BL,FILL\r
+ DC.L SEMIS\r
+*\r
+* ======>> 136 <<\r
+* ( c --- )\r
+* Format a character at the left of the HLD output buffer.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'HOL' ; 'HOLD'\r
+ DC.B 'D'|$80\r
+ DC.L BLANKS-7-NATWID\r
+HOLD DC.L DOCOL,LIT\r
+ DC.L -1 ; $FFFF in 16-bit model, but -1 is -1. DPL flag.\r
+ DC.L HLD,PSTORE,HLD,AT,CSTORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 137 <<\r
+* ( --- adr )\r
+* Give the address of the output PAD buffer. \r
+* PAD points to the end of a 68 byte buffer for numeric conversion.\r
+* 68 bytes is enough to convert a 64-bit integer to binary.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'PA' ; 'PAD'\r
+ DC.B 'D'|$80\r
+ DC.L HOLD-5-NATWID\r
+PAD DC.L DOCOL,HERE,LIT16\r
+ DC.W $44\r
+ DC.L PLUS\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 48 <<\r
+* ======>> 138 <<\r
+* ( c --- )\r
+* Scan a string terminated by the character c or ASCII NUL out of input;\r
+* store symbol at WORDPAD with leading count byte and trailing ASCII NUL. \r
+* Leading c are passed over, per ENCLOSE.\r
+* Scans from BLK, or from TIB if BLK is zero. \r
+* May overwrite the numeric conversion pad,\r
+* if really long (length > 31) symbols are scanned.\r
+* Does not ALLOCate the symbol.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'WOR' ; 'WORD'\r
+ DC.B 'D'|$80\r
+ DC.L PAD-4-NATWID\r
+WORD DC.L DOCOL,BLK,AT,ZBRAN\r
+ DC.L WORD2-*-NATWID\r
+ DC.L BLK,AT,BLOCK,BRAN\r
+ DC.L WORD3-*-NATWID\r
+WORD2 DC.L TIB,AT\r
+WORD3 DC.L IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT16\r
+ DC.W MAXNML+2\r
+ DC.L BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE\r
+ DC.L CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 49 <<\r
+* ======>> 139 <<\r
+* ( d1 string --- d2 adr )\r
+* Convert the text at string into a number, accumulating the result into d1,\r
+* leaving adr pointing to the first character not converted. \r
+* If DPL is non-negative at entry,\r
+* accumulates the number of characters converted into DPL.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $88\r
+ DC.B '(NUMBER' ; '(NUMBER)'\r
+ DC.B ')'|$80\r
+ DC.L WORD-5-NATWID\r
+PNUMB DC.L DOCOL\r
+* DC.L BREAK ; DBG *****\r
+PNUMB2 DC.L ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN\r
+ DC.L PNUMB4-*-NATWID\r
+ DC.L SWAP,BASE,AT,USTAR,DROP,ROT,BASE\r
+ DC.L AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN\r
+ DC.L PNUMB3-*-NATWID\r
+ DC.L ONE,DPL,PSTORE\r
+PNUMB3 DC.L FROMR,BRAN\r
+ DC.L PNUMB2-*-NATWID\r
+PNUMB4 DC.L FROMR\r
+* DC.L BREAK ; DBG *****\r
+ DC.L SEMIS\r
+*\r
+* ======>> 140 <<\r
+* ( ctstr --- d )\r
+* Convert text at ctstr to a double integer,\r
+* taking the 0 ERROR if the conversion is not valid. \r
+* If a decimal point is present,\r
+* accumulate the count of digits to the decimal point's right into DPL\r
+* (negative DPL at exit indicates single precision). \r
+* ctstr is a counted string\r
+* -- the first byte at ctstr is the length of the string,\r
+* but NUMBER ignores the count and expects a NUL terminator instead.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'NUMBE' ; 'NUMBER'\r
+ DC.B 'R'|$80\r
+ DC.L PNUMB-9-NATWID\r
+NUMB DC.L DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT16\r
+ DC.W "-" minus sign\r
+ DC.L EQUAL,DUP,TOR,PLUS,LIT\r
+ DC.L -1 ; $FFFF in 16-bit model, but -1 is -1. DPL flag.\r
+NUMB1 DC.L DPL,STORE,PNUMB,DUP,CAT,BL,SUB\r
+ DC.L ZBRAN\r
+ DC.L NUMB2-*-NATWID\r
+ DC.L DUP,CAT,LIT16\r
+ DC.W "."\r
+ DC.L SUB,ZERO,QERR,ZERO,BRAN\r
+ DC.L NUMB1-*-NATWID\r
+NUMB2 DC.L DROP,FROMR,ZBRAN\r
+ DC.L NUMB3-*-NATWID\r
+ DC.L DMINUS\r
+NUMB3 DC.L SEMIS\r
+*\r
+* ======>> 141 <<\r
+* ( --- locptr length true ) { -FIND name } typical input\r
+* ( --- false )\r
+* Parse a word, then FIND,\r
+* first in the definition vocabulary,\r
+* then in the CONTEXT (interpretation) vocabulary, if necessary.\r
+* Returns what (FIND) returns, flag and optional location and length.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B '-FIN' ; '-FIND'\r
+ DC.B 'D'|$80\r
+ DC.L NUMB-7-NATWID\r
+DFIND DC.L DOCOL,BL,WORD,HERE,CONTXT,AT,AT\r
+ DC.L PFIND,DUP,ZEQU,ZBRAN\r
+ DC.L DFIND2-*-NATWID\r
+ DC.L DROP,HERE,LATEST,PFIND\r
+DFIND2 DC.L SEMIS\r
+*\r
+ PAGE\r
+* ######>> screen 50 <<\r
+* ======>> 142 <<\r
+* ( anything --- nothing ) ( anything *** nothing )\r
+* An indirection for ABORT, for ERROR,\r
+* which may be modified carefully.\r
+ EVEN\r
+ DC.B $87\r
+ DC.B '(ABORT' ; '(ABORT)'\r
+ DC.B ')'|$80\r
+ DC.L DFIND-6-NATWID\r
+PABORT DC.L DOCOL,ABORT\r
+ DC.L SEMIS\r
+*\r
+* ======>> 143 <<\r
+* ERROR ( anything line --- IN BLK ) ( anything *** nothing )\r
+* ( anything --- nothing )\r
+* ( anything *** nothing ) WARNING < 0\r
+* Prints out the last symbol scanned and MESSAGE number line. If\r
+* WARNING is less than zero, ABORTs through (ABORT), otherwise,\r
+* clears the parameter stack, pushes the INput cursor and\r
+* interpretaion BLK, and QUITs.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'ERRO' ; 'ERROR'\r
+ DC.B 'R'|$80\r
+ DC.L PABORT-8-NATWID\r
+* This really should not be high level, according to best practices.\r
+* But fixing that cascades through MESSAGE,\r
+* requiring re-architecting the disk block system.\r
+* First, we need to get this transliteration running.\r
+ERROR DC.L DOCOL,WARN,AT,ZLESS\r
+ DC.L ZBRAN\r
+ DC.L ERROR2-*-NATWID\r
+* note: WARNING is\r
+* -1 to abort,\r
+* 0 to print error #\r
+* and 1 to print error message from disc\r
+ DC.L PABORT\r
+ERROR2 DC.L HERE,COUNT,TYPE,PDOTQ\r
+ DC.B 4,7 ; ( bell )\r
+ DC.B " ? "\r
+ DC.B 0 ; hand-align\r
+ DC.L MESS,SPSTOR,IN,AT,BLK,AT,QUIT\r
+ DC.L SEMIS\r
+*\r
+* ======>> 144 <<\r
+* ( n adr --- )\r
+* Mask byte at adr with n.\r
+* Not in FIG, don't need it for 8 bit characters after all.\r
+* EVEN\r
+* DC.B $85\r
+* DC.B 'CMAS' ; 'CMASK'\r
+* DC.B 'K'|$80\r
+* DC.L ERROR-6-NATWID\r
+* CMASK DC.L *+NATWID\r
+* MOVE.L (PSP)+,A0 ; adr\r
+* MOVE.L (PSP)+,D0 ; prepare for mask\r
+* AND.B D0,(A0)\r
+* RTS\r
+*\r
+* ( adr --- adr )\r
+* Mask high bit of tail of name in PAD buffer.\r
+* Not in FIG, need it for characters with high bit set.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'IDFLA' ; 'IDFLAT'\r
+ DC.B 'T'|$80\r
+ DC.L ERROR-6-NATWID\r
+IDFLAT DC.L *+NATWID\r
+ MOVE.L (PSP),A0\r
+ MOVE.B (A0),D1 ; get the count\r
+ AND.W #CTMASK,D1\r
+ AND.B #$7F,(A0,D1.W) ; point to the tail and clear the EndOfName flag bit.\r
+ RTS\r
+*\r
+* ( symptr --- )\r
+* Print definition's name from its NFA.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'ID' ; 'ID.'\r
+ DC.B '.'|$80\r
+ DC.L IDFLAT-7-NATWID\r
+IDDOT DC.L DOCOL,PAD\r
+* DC.L BREAK ; DBG *****\r
+ DC.L LIT16\r
+ DC.W MAXNML ; Why did I hard code this?\r
+* DC.L WIDTH,ONEP ; Because WIDTH is a (USER) variable.\r
+ DC.L LIT16\r
+ DC.W '_' ( underline )\r
+ DC.L FILL,DUP,PFA,LFA,OVER,SUB,PAD\r
+* DC.L SWAP,CMOVE,PAD,COUNT,LIT16\r
+* DC.W NMLMSK\r
+ DC.L SWAP,CMOVE,PAD\r
+ DC.L IDFLAT\r
+ DC.L COUNT,LIT16\r
+ DC.W NMLMSK\r
+ DC.L AND,TYPE,SPACE\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 51 <<\r
+* ======>> 145 <<\r
+* ( --- ) { CREATE name } input\r
+* Parse a name (length < MAXNML characters) and create a header,\r
+* reporting first duplicate found in either the defining vocabulary\r
+* or the context (interpreting) vocabulary. \r
+* Install the header in the defining vocabulary\r
+* with CFA dangerously pointing to the parameter field.\r
+* Leave the name SMUDGEd.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'CREAT' ; 'CREATE'\r
+ DC.B 'E'|$80\r
+ DC.L IDDOT-4-NATWID\r
+CREATE DC.L DOCOL,DFIND,ZBRAN\r
+ DC.L CREAT2-*-NATWID\r
+ DC.L DROP,PDOTQ\r
+ DC.B 8\r
+ DC.B 7 ; ( bel )\r
+ DC.B "redef: "\r
+ DC.B 0 ; hand align\r
+ DC.L NFA,IDDOT,LIT16\r
+ DC.W 4\r
+ DC.L MESS,SPACE\r
+*CREAT2 DC.L HERE,DUP,CAT,WIDTH,AT,MIN ; clip to WIDTH\r
+CREAT2 DC.L BREAK,HERE,CAT,WIDTH,AT,MIN ; clip to WIDTH, hold off copying HERE ; DBG *****\r
+* Make sure it ends up aligned by moving the name.\r
+* Note that we don't need to copy beyond WIDTH.\r
+ DC.L DUP,HERE,PLUS,ONEP ; tentative LFA\r
+ DC.L ONE,AND,ZBRAN ; Will LFA, as is, be even?\r
+ DC.L CREATN-*-NATWID ; will be even\r
+\r
+ DC.L HERE,OVER,HERE,ONEP,SWAP,ONEP ; source, destination, length including count\r
+ DC.L CMOVD ; Use descending copy so it doesn't just fill.\r
+\r
+ DC.L ZERO,CCOMM ; insert a NUL byte, update HERE.\r
+\r
+* Now build header.\r
+CREATN DC.L HERE,SWAP,ONEP,ALLOT,DUP,LIT16\r
+ DC.W ($80|FSMUDG) ; Bracket the name.\r
+ DC.L TOGGLE\r
+ DC.L HERE,ONE,SUB,LIT16\r
+ DC.W $80\r
+ DC.L TOGGLE\r
+ DC.L LATEST,COMMA,CURENT,AT,STORE\r
+* DC.L HERE,TWOP,COMMA\r
+ DC.L HERE,NATP,COMMA\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 52 <<\r
+* ======>> 146 <<\r
+* ( --- ) P\r
+* { [COMPILE] name } typical use\r
+* -DFIND next WORD and COMPILE it, literally;\r
+* used to compile immediate definitions into words.\r
+ EVEN\r
+ DC.B $C9 immediate\r
+ DC.B '[COMPILE' ; '[COMPILE]'\r
+ DC.B ']'|$80\r
+ DC.L CREATE-7-NATWID\r
+BCOMP DC.L DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA\r
+ DC.L SEMIS\r
+*\r
+* ======>> 147 <<\r
+* ( n --- ) if compiling. P\r
+* ( n --- n ) if interpreting.\r
+* Compile n as a literal, if compiling.\r
+ EVEN\r
+ DC.B $C7 immediate\r
+ DC.B 'LITERA' ; 'LITERAL'\r
+ DC.B 'L'|$80\r
+ DC.L BCOMP-10-NATWID\r
+LITER DC.L DOCOL,STATE,AT,ZBRAN\r
+ DC.L LITER2-*-NATWID\r
+ DC.L COMPIL,LIT,COMMA\r
+LITER2 DC.L SEMIS\r
+*\r
+* ======>> 148 <<\r
+* ( d --- ) if compiling. P\r
+* ( d --- d ) if interpreting.\r
+* Compile d as a double literal, if compiling.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $C8 immediate\r
+ DC.B 'DLITERA' ; 'DLITERAL'\r
+ DC.B 'L'|$80\r
+ DC.L LITER-8-NATWID\r
+DLITER DC.L DOCOL,STATE,AT,ZBRAN\r
+ DC.L DLITE2-*-NATWID\r
+ DC.L SWAP,LITER,LITER ; Just two literals in the right order.\r
+DLITE2 DC.L SEMIS\r
+*\r
+* ######>> screen 53 <<\r
+* ======>> 149 <<\r
+* ( --- )\r
+* Interpret or compile, according to STATE. \r
+* Searches words parsed in dictionary first, via -FIND,\r
+* then checks for valid NUMBER.\r
+* Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative. \r
+* ERROR checks the stack via ?STACK before returning to its caller. \r
+ EVEN\r
+ DC.B $89\r
+ DC.B 'INTERPRE' ; 'INTERPRET'\r
+ DC.B 'T'|$80\r
+* DC.L LITER-8-NATWID\r
+ DC.L DLITER-9-NATWID\r
+INTERP DC.L DOCOL\r
+INTER2 DC.L DFIND,ZBRAN\r
+ DC.L INTER5-*-NATWID\r
+ DC.L STATE,AT,LESS\r
+ DC.L ZBRAN\r
+ DC.L INTER3-*-NATWID\r
+ DC.L CFA,COMMA,BRAN\r
+ DC.L INTER4-*-NATWID\r
+INTER3 DC.L CFA,EXEC\r
+INTER4 DC.L BRAN\r
+ DC.L INTER7-*-NATWID\r
+INTER5 DC.L HERE,NUMB,DPL,AT,ONEP,ZBRAN\r
+ DC.L INTER6-*-NATWID\r
+ DC.L DLITER,BRAN\r
+ DC.L INTER7-*-NATWID\r
+INTER6 DC.L DROP,LITER\r
+INTER7 DC.L QSTACK,BRAN\r
+*INTER7 DC.L BREAK,QSTACK,BRAN ; DBG\r
+ DC.L INTER2-*-NATWID\r
+* DC.L SEMIS never executed\r
+\r
+*\r
+* ######>> screen 54 <<\r
+* ======>> 150 <<\r
+* ( --- )\r
+* Toggle precedence bit of LATEST definition header. \r
+* During compiling, most symbols scanned are compiled. \r
+* IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,\r
+* but may be compiled via ' (TICK).\r
+ EVEN\r
+ DC.B $89\r
+ DC.B 'IMMEDIAT' ; 'IMMEDIATE'\r
+ DC.B 'E'|$80\r
+ DC.L INTERP-10-NATWID\r
+IMMED DC.L DOCOL,LATEST,LIT16\r
+ DC.W FIMMED\r
+ DC.L TOGGLE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 151 <<\r
+* ( --- ) { VOCABULARY name } input\r
+* Create a vocabulary entry with a flag for terminating vocabulary searches.\r
+* Store the current search context in it for linking.\r
+* At run-time, VOCABULARY makes itself the CONTEXT vocabulary.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $8A\r
+ DC.B 'VOCABULAR' ; 'VOCABULARY'\r
+ DC.B 'Y'|$80\r
+ DC.L IMMED-10-NATWID\r
+VOCAB DC.L DOCOL,BUILDS,LIT,VOCFLG,COMMA,CURENT,AT,CFA\r
+ DC.L COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES\r
+* DOVOC DC.L TWOP,CONTXT,STORE\r
+DOVOC DC.L NATP,CONTXT,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 152 <<\r
+*\r
+* Note: FORTH does not go here in the rom-able dictionary,\r
+* since FORTH is a type of variable.\r
+*\r
+* (Should make a proper architecture for this at some point.)\r
+*\r
+*\r
+* ======>> 153 <<\r
+* ( --- )\r
+* Makes the current interpretation CONTEXT vocabulary\r
+* also the CURRENT defining vocabulary.\r
+ EVEN\r
+ DC.B $8B\r
+ DC.B 'DEFINITION' ; 'DEFINITIONS'\r
+ DC.B 'S'|$80\r
+ DC.L VOCAB-11-NATWID\r
+DEFIN DC.L DOCOL,CONTXT,AT,CURENT,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 154 <<\r
+* ( --- )\r
+* Parse out a comment and toss it away. \r
+* Leaves the leading characters in WORDPAD, which may or may not be useful.\r
+ EVEN\r
+ DC.B $C1 immediate (\r
+ DC.B '('|$80\r
+ DC.L DEFIN-12-NATWID\r
+PAREN DC.L DOCOL,LIT16\r
+ DC.W ")"\r
+ DC.L WORD\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 55 <<\r
+* ======>> 155 <<\r
+* ( anything *** nothing )\r
+* Clear return stack. \r
+* Then INTERPRET and, if not compiling, prompt with OK,\r
+* in infinite loop.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'QUI' ; 'QUIT'\r
+ DC.B 'T'|$80\r
+ DC.L PAREN-2-NATWID\r
+QUIT DC.L DOCOL,ZERO,BLK,STORE\r
+ DC.L BREAK ; DBG ****\r
+ DC.L LBRAK\r
+*\r
+* Here is the outer interpretter\r
+* which gets a line of input, does it, prints " OK"\r
+* then repeats :\r
+QUIT2 DC.L RPSTOR,CR,QUERY\r
+ DC.L BREAK ; DBG *****\r
+ DC.L INTERP,STATE,AT,ZEQU\r
+ DC.L ZBRAN\r
+ DC.L QUIT3-*-NATWID\r
+ DC.L PDOTQ\r
+ DC.B 3\r
+ DC.B ' OK' ; ' OK'\r
+QUIT3 DC.L BRAN\r
+ DC.L QUIT2-*-NATWID\r
+* DC.L SEMIS ( never executed )\r
+*\r
+* ======>> 156 <<\r
+* ( anything --- nothing ) ( anything *** nothing )\r
+* Clear parameter stack,\r
+* set STATE to interpret and BASE to DECIMAL,\r
+* return to input from terminal,\r
+* restore DRIVE OFFSET to 0,\r
+* print out "Forth-68",\r
+* set interpret and define vocabularies to FORTH,\r
+* and finally, QUIT. \r
+* Used to force the system to a known state\r
+* and return control to the initial INTERPRETer.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'ABOR' ; 'ABORT'\r
+ DC.B 'T'|$80\r
+ DC.L QUIT-5-NATWID\r
+*ABORT DC.L DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ\r
+ABORT DC.L DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,BREAK,PDOTQ\r
+ DC.B 15\r
+ DC.B "fig-Forth-68000"\r
+* DC.B 0 ; hand align\r
+ DC.L FORTH,DEFIN\r
+* DC.L CR,TROFF,VLIST ; (whole line is) DBG ****\r
+ DC.L QUIT\r
+* DC.L SEMIS never executed\r
+ PAGE\r
+*\r
+* ######>> screen 56 <<\r
+* bootstrap code... moves rom contents to ram :\r
+* ======>> 157 <<\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'COL' ; 'COLD'\r
+ DC.B 'D'|$80\r
+ DC.L ABORT-6-NATWID\r
+COLD DC.L *+NATWID\r
+* Ultimately, we want position indepence,\r
+* so I'm using PCR where it seems reasonable.\r
+* Time for some testing.\r
+CENT MOVE.L RINIT(PC),RP ; Get a useable initial return stack,\r
+ MOVE.L SINIT(PC),PSP ; a useable initial parameter stack,\r
+* MOVE.L #IUP,UP ; and a useable initial task base (not in init table).\r
+ MOVE.L #UORIG,UP ; and a useable initial task base (not in init table).\r
+*\r
+ LEA ERAM(PC),A2 ; end of stuff to move, A2 as loop terminator\r
+ MOVE.L #RBEG,A1 ; bottom of (open-ended) destination\r
+ LEA RAM(PC),A0 ; bottom of stuff to move\r
+COLD2 MOVE.B (A0)+,(A1)+ ; move TASK & FORTH to ram\r
+ CMP.L A2,A0\r
+ BNE.S COLD2\r
+* The above leaves USE and PREV uninitialized.\r
+ MOVE.L BUFINT(PC),A2\r
+ MOVE.L A2,XUSE-UORIG(UP)\r
+ MOVE.L A2,XPREV-UORIG(UP)\r
+* ... or we could go top to bottom.\r
+* Definitely no need to use the return stack pointer like in the 6800 model,\r
+* nor to fiddle with it, since it is already pointing to a place that should be safe.\r
+ MOVE.L COLINT(PC),XCOLUM-UORIG(UP)\r
+ MOVE.L DELINT(PC),XDELAY-UORIG(UP)\r
+ MOVE.L VOCINT(PC),XVOCL-UORIG(UP)\r
+ MOVE.L DPINIT(PC),XDICTP-UORIG(UP)\r
+ MOVE.L FENCIN(PC),XFENCE-UORIG(UP)\r
+*\r
+WENT MOVE.L RINIT(PC),RP ; Get a useable initial return stack,\r
+ MOVE.L SINIT(PC),PSP ; a useable initial parameter stack,\r
+* MOVE.L #IUP,UP ; and a useable initial task base (not in init table).\r
+ MOVE.L #UORIG,UP ; and a useable initial task base (not in init table).\r
+*\r
+ LEA SINIT(PC),A2 ; for loop termination\r
+ LEA XFENCE-UORIG(UP),A1 ; top of destination\r
+ LEA FENCIN(PC),A0 ; top of stuff to move\r
+WARM2 MOVE.L -(A0),-(A1) ; All entries are 32 bit.\r
+ CMP.L A2,A0\r
+ BNE.S WARM2\r
+*\r
+ LEA ABORT+NATWID(PC),IP ; IP never points to DOCOL!\r
+*\r
+ NOP ; Here is a place to jump to special user\r
+ NOP ; initializations such as I/0 interrups\r
+ NOP\r
+*\r
+\r
+\r
+* For systems with TRACE:\r
+ CLR.L (RP) ; The hole above the return stack\r
+ CLR.L (PSP) ; The hole above the parameter stack\r
+ LEA N(PC),A0\r
+ CLR.W TRLIM-N(A0) ; clear trace limit (all bytes)\r
+ CLR.W TRACEM-N(A0) ; and mode (all bytes)\r
+* DBG:\r
+* ADDQ.W #1,TRACEM-N(A0) ; DBG *******************\r
+ CLR.L BRKPT-N(A0) ; clear breakpoint address\r
+ BRA.W RPSTOR+NATWID ; start the virtual machine running !\r
+* RPSTOR's NEXT will pick up the IP set above, and start ABORT.\r
+* RP! sets up the return stack pointer, then IP references abort.\r
+\r
+* Comment out the branch above and use something like this to jump direct to test code:\r
+* LEA TESTMIN(PC),IP\r
+* RTS\r
+\r
+*\r
+* Here is the stuff that gets copied to ram :\r
+* (not * at address $140:)\r
+* at an appropriate address:\r
+*\r
+* RAM DC.L $3000,$3000,0,0\r
+* RAM DC.L BUFBAS,BUFBAS,0,0 ; ... except the direct page has moved.\r
+* These initialization values for USE and PREV were here to help pack the code.\r
+* They don't belong here unless we move the USER table\r
+* back below the writable dictionary, \r
+* *and* move these USER variables to the end of the direct page --\r
+* *or* let these definitions exist in the USER table.\r
+RAM EQU * ; Does RAM need to have the BUFfer BASe address before RFORTH?\r
+\r
+* ======>> (152) <<\r
+* ( --- ) P\r
+* Makes FORTH the current interpretation vocabulary.\r
+* In order to make this ROMmable,\r
+* this entry is set up as the tail-end of its VOCABULARY,\r
+* and copied to RAM in the start-up code.\r
+* We want a more elegant solution to this, too. Greedy, maybe.\r
+ EVEN\r
+ DC.B $C5 immediate\r
+ DC.B 'FORT' ; 'FORTH'\r
+ DC.B 'H'|$80\r
+ DC.L NOOP-5-NATWID ; Note that this does not link to COLD!\r
+RFORTH DC.L DODOES,DOVOC,VOCFLG,TASK-5-NATWID\r
+ DC.L 0\r
+ DC.B "Copyright 1979 Forth Interest Group, David Lion,"\r
+ DC.B $0D\r
+ DC.B "Parts Copyright 2019 Joel Matthew Rees"\r
+ DC.B $0D\r
+*\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'TAS' ; 'TASK'\r
+ DC.B 'K'|$80\r
+ DC.L FORTH-6-NATWID\r
+RTASK DC.L DOCOL,SEMIS\r
+ERAM EQU *\r
+ERAMSZ EQU *-RAM ; So we can get a look at it.\r
+*\r
+ PAGE\r
+* ######>> screen 57 <<\r
+* ======>> 158 <<\r
+* ( n0 --- d0 )\r
+* Sign extend n0 to a double integer.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'S->' ; 'S->D'\r
+ DC.B 'D'|$80\r
+ DC.L COLD-5-NATWID ; Note that this does not link to FORTH (RFORTH)!\r
+STOD DC.L DOCOL,DUP,ZLESS,MINUS\r
+ DC.L SEMIS\r
+\r
+\r
+*\r
+* ======>> 159 <<\r
+* ( multiplier multiplicand --- product )\r
+* Signed word multiply.\r
+ EVEN\r
+ DC.B $81 ; *\r
+ DC.B '*'|$80\r
+ DC.L STOD-5-NATWID\r
+STAR DC.L DOCOL\r
+ DC.L USTAR,DROP,SEMIS ; Drop high word.\r
+* STAR DC.L *+NATWID\r
+* BSR.W USTAR+NATWID\r
+* LEA NATWID(PSP),PSP ; Drop high word. Seems like magic, doesn't it?\r
+* RTS\r
+*\r
+* ======>> 160 <<\r
+* ( dividend divisor --- remainder quotient )\r
+* M/ in word-only form, i. e., signed division of 2nd word by top word,\r
+* yielding signed word quotient and remainder.\r
+* Except *BUG* it isn't signed.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B '/MO' ; '/MOD'\r
+ DC.B 'D'|$80\r
+ DC.L STAR-2-NATWID\r
+SLMOD DC.L DOCOL,TOR,STOD,FROMR,USLASH\r
+ DC.L SEMIS\r
+*\r
+* ======>> 161 <<\r
+* ( dividend divisor --- quotient )\r
+* Signed word divide without remainder.\r
+* Except *BUG* it isn't signed.\r
+ EVEN\r
+ DC.B $81 ; /\r
+ DC.B '/'|$80\r
+ DC.L SLMOD-5-NATWID\r
+SLASH DC.L DOCOL,SLMOD,SWAP,DROP\r
+ DC.L SEMIS\r
+*\r
+* ======>> 162 <<\r
+* ( dividend divisor --- remainder )\r
+* Remainder function, result takes sign of dividend.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'MO' ; 'MOD'\r
+ DC.B 'D'|$80\r
+ DC.L SLASH-2-NATWID\r
+MOD DC.L DOCOL,SLMOD,DROP\r
+ DC.L SEMIS\r
+*\r
+* ======>> 163 <<\r
+* ( multiplier multiplicand divisor --- remainder quotient )\r
+* Signed precise division of product:\r
+* multiply 2nd and 3rd words on stack\r
+* and divide the 31-bit product by the top word,\r
+* leaving both quotient and remainder.\r
+* Remainder takes sign of product. \r
+* Guaranteed not to lose significant bits in 16 bit integer math.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B '*/MO' ; '*/MOD'\r
+ DC.B 'D'|$80\r
+ DC.L MOD-4-NATWID\r
+SSMOD DC.L DOCOL,TOR,USTAR,FROMR,USLASH\r
+ DC.L SEMIS\r
+*\r
+* ======>> 164 <<\r
+* ( multiplier multiplicand divisor --- quotient )\r
+* */MOD without remainder.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '*' ; '*/'\r
+ DC.B '/'|$80\r
+ DC.L SSMOD-6-NATWID\r
+SSLASH DC.L DOCOL,SSMOD,SWAP,DROP\r
+ DC.L SEMIS\r
+*\r
+* ======>> 165 <<\r
+* ( ud1 u1 --- u2 ud2 )\r
+* U/ with an (unsigned) double quotient. \r
+* Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,\r
+* if you are prepared to deal with the extra 16 bits of result.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'M/MO' ; 'M/MOD'\r
+ DC.B 'D'|$80\r
+ DC.L SSLASH-3-NATWID\r
+MSMOD DC.L DOCOL,TOR,ZERO,R,USLASH\r
+ DC.L FROMR,SWAP,TOR,USLASH,FROMR\r
+ DC.L SEMIS\r
+*\r
+* ======>> 166 <<\r
+* ( n>=0 --- n )\r
+* ( n<0 --- -n )\r
+* Convert the top of stack to its absolute value.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'AB' ; 'ABS'\r
+ DC.B 'S'|$80\r
+ DC.L MSMOD-6-NATWID\r
+ABS DC.L DOCOL,DUP,ZLESS,ZBRAN\r
+ DC.L ABS2-*-NATWID\r
+ DC.L MINUS\r
+ABS2 DC.L SEMIS\r
+*\r
+* ======>> 167 <<\r
+* ( d>=0 --- d )\r
+* ( d<0 --- -d )\r
+* Convert the top double to its absolute value.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'DAB' ; 'DABS'\r
+ DC.B 'S'|$80\r
+ DC.L ABS-4-NATWID\r
+DABS DC.L DOCOL,DUP,ZLESS,ZBRAN\r
+ DC.L DABS2-*-NATWID\r
+ DC.L DMINUS\r
+DABS2 DC.L SEMIS\r
+*\r
+ PAGE\r
+* ######>> screen 58 <<\r
+* Disc primitives :\r
+* ======>> 168 <<\r
+* ( --- vadr ) \r
+* Least Recently Used buffer.\r
+* Really should be with FIRST and LIMIT in the per-task table.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'US' ; 'USE'\r
+ DC.B 'E'|$80\r
+ DC.L DABS-5-NATWID\r
+USE DC.L DOCON\r
+ DC.L XUSE ; The address of XUSE is the constant.\r
+* ======>> 169 <<\r
+* ( --- vadr ) \r
+* Most Recently Used buffer.\r
+* Really should be with FIRST and LIMIT in the per-task table.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'PRE' ; 'PREV'\r
+ DC.B 'V'|$80\r
+ DC.L USE-4-NATWID\r
+PREV DC.L DOCON\r
+ DC.L XPREV ; The address of XPREV is the constant.\r
+* ======>> 170 <<\r
+* ( buffer1 --- buffer2 f )\r
+* Bump to next buffer,\r
+* flag false if result is PREVious buffer,\r
+* otherwise flag true. \r
+* Used in the LRU allocation routines.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B '+BU' ; '+BUF'\r
+ DC.B 'F'|$80\r
+ DC.L PREV-5-NATWID\r
+* PBUF DC.L DOCOL,LIT16\r
+* DC.W $84 ; This was a hard-wiring bug.\r
+PBUF DC.L DOCOL,BBUF,BCTL,PLUS ; Size of the buffer record.\r
+* DC.L PLUS,DUP,LIMIT,EQUAL,ZBRAN\r
+ DC.L PLUS,DUP,LIMIT,LESS,ZEQU,OVER,FIRST,LESS,OR,ZBRAN\r
+ DC.L PBUF2-*-NATWID ; Use defensive programming.\r
+ DC.L DROP,FIRST\r
+PBUF2 DC.L DUP,PREV,AT,SUB\r
+ DC.L SEMIS\r
+*\r
+* ======>> 171 <<\r
+*\r
+UPDATB EQU $80000000 ; $8000 in the 6800 model -- puts limits on sector count.\r
+*\r
+* ( --- f )\r
+* Flag to mark a buffer dirty, in need of being written out.\r
+* This flag limits the max number of sectors in a disk to ((256^NATWID)/2)-1.\r
+* It also hard-codes an implicit test which is used elsewhere.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $8A\r
+ DC.B 'UPDATE-BI' ; 'UPDATE-BIT'\r
+ DC.B 'T'|$80\r
+ DC.L PBUF-5-NATWID\r
+UPDBIT DC.L DOCON\r
+ DC.L UPDATB\r
+*\r
+* ( --- )\r
+* Mark PREVious buffer dirty, in need of being written out.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'UPDAT' ; 'UPDATE'\r
+ DC.B 'E'|$80\r
+ DC.L UPDBIT-11-NATWID\r
+* UPDATE DC.L DOCOL,PREV,AT,AT,LIT,UPDATB,OR,PREV,AT,STORE\r
+UPDATE DC.L DOCOL,PREV,AT,AT,UPDBIT,OR,PREV,AT,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 172 <<\r
+*\r
+* Going to leave the 0 sector bug in place, I guess. Maybe.\r
+* ( adr --- )\r
+** Mark the buffer addressed as empty.\r
+** Have to add code to avoid block 0 appearing to be in a buffer from COLD.\r
+** Usually, there is no sector 0 (?), but the RAM buffers are too simple.\r
+** Note that without this block number being made illegal, \r
+** about 8 binaryMegabytes (256 bytes/block) of disk can be addressed total.\r
+** With this block number made illegal, the max is 1 block less,\r
+** still about 8 biMeg.\r
+* EVEN\r
+* DC.B $8B\r
+* DC.B 'KILL-BUFFE' ; 'KILL-BUFFER'\r
+* DC.B 'R'|$80\r
+* DC.L UPDATE-7-NATWID\r
+*KILBUF DC.L *+NATWID ; DOCOL,UPDBIT,ONE,SUB,SWAP,STORE\r
+* MOVE.L (PSP)+,A0 \r
+* MOVE.L UPDBIT+NATWID(PC),D0\r
+* SUBQ.L #1,D0\r
+* MOVE.L D0,(A0)\r
+* RTS\r
+*\r
+* ( --- )\r
+* Mark all buffers empty. \r
+* EVEN\r
+* DC.B 0\r
+* DC.B $8C\r
+* DC.B 'KILL-BUFFER' ; 'KILL-BUFFERS'\r
+* DC.B 'S'|$80\r
+* DC.L KILBUF-12-NATWID\r
+*KLBFS DC.L DOCOL,FIRST,LIT16\r
+* DC.W 4 ; Want to make sure it's only four.\r
+* DC.L ZERO,XDO ; It would be "cleaner" to let +BUF control the loop.\r
+* DC.L DUP,KILBUF,PBUF,DROP,XLOOP\r
+* DC.L DROP,SEMIS\r
+** KLBFS DC.L *+NATWID\r
+** LDD #4\r
+** PSHU D\r
+** LDD FIRST+NATWID,PCR\r
+** INC <TRACEM\r
+** LBSR DBGREG\r
+** PSHU D ; DUP\r
+** KLBFSL PSHU D\r
+** BSR KILBUF+NATWID\r
+** LDD ,U \r
+** LBSR DBGREG\r
+** ADDD BBUF+NATWID,PCR\r
+** ADDD BCTL+NATWID,PCR\r
+** STD ,U\r
+** LBSR DBGREG\r
+** DEC NATWID+1,U\r
+** BNE KLBFSL\r
+** LBSR DBGREG\r
+** LEAU NATWID*2,U\r
+** DEC <TRACEM\r
+** LBRA NEXT\r
+*\r
+* ( --- )\r
+* Erase and mark all buffers empty. \r
+* Standard method of discarding changes.\r
+ EVEN\r
+ DC.B $8D\r
+ DC.B 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'\r
+ DC.B 'S'|$80\r
+* DC.L KLBFS-13-NATWID\r
+ DC.L UPDATE-7-NATWID\r
+MTBUF DC.L DOCOL,FIRST,LIMIT,OVER,SUB,ERASE\r
+* DC.L FIRST,DUP,KILBUF,PBUF,DROP,DUP,KILBUF\r
+* DC.L PBUF,DROP,DUP,KILBUF,PBUF,DROP,KILBUF\r
+* DC.L KLBFS\r
+ DC.L SEMIS\r
+*\r
+* ======>> 173 <<\r
+* ( --- )\r
+* Clear the current offset to the block numbers in the drive interface.\r
+* The drives need to be re-architected.\r
+* Would be cool to have RAM and ROM drives supported\r
+* in addition to regular physical persistent store.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'DR' ; 'DR0'\r
+ DC.B '0'|$80\r
+ DC.L MTBUF-14-NATWID\r
+DRZERO DC.L DOCOL,ZERO,OFSET,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 174 <<== system dependant word\r
+* ( --- )\r
+* Set the current offset in the drive interface to reference the second drive.\r
+* The hard-coded number in there needs to be in a table.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'DR' ; 'DR1'\r
+ DC.B '1'|$80\r
+ DC.L DRZERO-4-NATWID\r
+*DRONE DC.L DOCOL,LIT,$07D0,OFSET,STORE \r
+; **** hard-codes the size of the disc !!!!\r
+DRONE DC.L DOCOL,LIT,RAMDSZ,OFSET,STORE\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 59 <<\r
+* ======>> 175 <<\r
+* ( n --- buffer )\r
+* Get a free buffer,\r
+* assign it to block n,\r
+* return buffer address.\r
+* Will free a buffer by writing it, if necessary. \r
+* Does not actually read the block. \r
+* A bug in the fig LRU algorithm, which I have not fixed,\r
+* gives the PREVious buffer if USE gets set to PREVious.\r
+* (The bug is that USE sometimes gets set to PREVious.) \r
+* This bug sometimes causes sector moves to become sector fills.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'BUFFE' ; 'BUFFER'\r
+ DC.B 'R'|$80\r
+ DC.L DRONE-4-NATWID\r
+BUFFER DC.L DOCOL,USE,AT,DUP,TOR\r
+BUFFR2 DC.L PBUF,ZBRAN\r
+ DC.L BUFFR2-*-NATWID\r
+ DC.L USE,STORE,R,AT,ZLESS\r
+ DC.L ZBRAN\r
+ DC.L BUFFR3-*-NATWID\r
+* DC.L R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW\r
+ DC.L R,NATP,R,AT,UPDBIT,LNOT,AND,ZERO,RW\r
+* BUFFR3 DC.L R,STORE,R,PREV,STORE,FROMR,TWOP\r
+BUFFR3 DC.L R,STORE,R,PREV,STORE,FROMR,NATP\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 60 <<\r
+* ======>> 176 <<\r
+* ( n --- buffer )\r
+* Get BUFFER containing block n, relative to OFFSET. \r
+* If block n is not in a buffer, bring it in. \r
+* Returns buffer address.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'BLOC' ; 'BLOCK'\r
+ DC.B 'K'|$80\r
+ DC.L BUFFER-7-NATWID\r
+BLOCK DC.L DOCOL,OFSET,AT,PLUS,TOR\r
+ DC.L PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN\r
+ DC.L BLOCK5-*-NATWID\r
+BLOCK3 DC.L PBUF,ZEQU,ZBRAN\r
+ DC.L BLOCK4-*-NATWID\r
+* DC.L DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB\r
+ DC.L DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB\r
+BLOCK4 DC.L DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN\r
+ DC.L BLOCK3-*-NATWID\r
+ DC.L DUP,PREV,STORE\r
+* BLOCK5 DC.L FROMR,DROP,TWOP\r
+BLOCK5 DC.L FROMR,DROP,NATP\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 61 <<\r
+* ======>> 177 <<\r
+* ( line screen --- buffer C/L)\r
+* Bring in the sector containing the specified line of the specified screen. \r
+* Returns the buffer address and the width of the screen. \r
+* Screen number is relative to OFFSET. \r
+* The line number may be beyond screen 4,\r
+* (LINE) will get the appropriate screen.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B '(LINE' ; '(LINE)'\r
+ DC.B ')'|$80\r
+ DC.L BLOCK-6-NATWID\r
+PLINE DC.L DOCOL,TOR,LIT16\r
+ DC.W $40\r
+ DC.L BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT16\r
+ DC.W $40\r
+ DC.L SEMIS\r
+*\r
+* ======>> 178 <<\r
+* ( line screen --- )\r
+* Print the line of the screen as found by (LINE), suppress trailing BLANKS.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B '.LIN' ; '.LINE'\r
+ DC.B 'E'|$80\r
+ DC.L PLINE-7-NATWID\r
+DLINE DC.L DOCOL,PLINE,DTRAIL,TYPE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 179 <<\r
+* ( n --- )\r
+* If WARNING is 0, print "MESSAGE #n";\r
+* otherwise, print line n relative to screen 4,\r
+* the line number may be negative. \r
+* Uses .LINE, but counter-adjusts to be relative to the real drive 0.\r
+* BUG: -DUP will cause this to reach farther into the stack than the error number \r
+* when WARNING is set and err# is zero (can't find entry in dictionary).\r
+ EVEN\r
+ DC.B $87\r
+ DC.B 'MESSAG' ; 'MESSAGE'\r
+ DC.B 'E'|$80\r
+ DC.L DLINE-6-NATWID\r
+MESS DC.L DOCOL,WARN,AT,ZBRAN\r
+ DC.L MESS3-*-NATWID\r
+ DC.L DDUP,ZBRAN ; -DUP here is a bug from the original 6800 model, at least.\r
+ DC.L MESS3-*-NATWID\r
+ DC.L LIT16\r
+ DC.W 4\r
+ DC.L OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN\r
+ DC.L MESS4-*-NATWID\r
+MESS3 DC.L PDOTQ\r
+ DC.B 6\r
+ DC.B 'err # ' ; 'err # '\r
+ DC.B 0 ; hand align\r
+ DC.L DOT\r
+MESS4 DC.L SEMIS\r
+*\r
+* ======>> 180 <<\r
+* ( n --- )\r
+* Begin interpretation of screen (block) n. \r
+* See also ARROW, SEMIS, and NULL.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'LOA' ; 'LOAD' : input:scr #\r
+ DC.B 'D'|$80\r
+ DC.L MESS-8-NATWID\r
+LOAD DC.L DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE\r
+ DC.L BSCR,STAR,BLK,STORE\r
+ DC.L INTERP,FROMR,IN,STORE,FROMR,BLK,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 181 <<\r
+* ( --- ) P\r
+* Continue interpreting source code on the next screen.\r
+ EVEN\r
+ DC.B $C3\r
+ DC.B '--' ; '-->'\r
+ DC.B '>'|$80\r
+ DC.L LOAD-5-NATWID\r
+ARROW DC.L DOCOL,QLOAD,ZERO,IN,STORE,BSCR\r
+ DC.L BLK,AT,OVER,MOD,SUB,BLK,PSTORE\r
+ DC.L SEMIS\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 63 <<\r
+* The next clot of subroutines are machine dependent.\r
+* PEMIT, PKEY, PQTER, and PCR (_P_arenthetic versions) are called by\r
+* EMIT, KEY, QTERM, and CR, words 13 through 16 in the dictionary.\r
+* This is all native CPU code.\r
+*\r
+* ATARI BIOS call parameters on _A7_ == SP. (Not PSP!)\r
+* Defining for Atari ST BIOS:\r
+* Atari BIOS messes with D0-D2/A0-A2.\r
+* We do not know D0/D1/A0/A1 are safe to overwrite in our runtime.\r
+*\r
+* ======>> 185 << code for CR\r
+* ( --- ) No stack effect.\r
+* Output a CR/LF combo to the CONSOLE device \r
+* using the Atari ST BIOS.\r
+* Move this here to keep it in reach of short branch.\r
+PCR MOVEM.L D1,-(SP) Don't destroy D1.\r
+ MOVE.W #$0D,D1\r
+ BSR.S PEMIT\r
+ MOVE.W #$0A,D1\r
+ BSR.S PEMIT ; Don't rob PEMIT's return.\r
+ MOVEM.L (SP)+,D1 ; Restore D1\r
+ RTS\r
+*\r
+* ( --- ) No parameter stack effect.\r
+* Assume volatile registers saved,\r
+* Use Atari terminal emulation to turn the text cursor on.\r
+PCURON MOVEM.L D1,-(SP) Don't destroy D1.\r
+ MOVE.W #$1B,D1\r
+ BSR.S PEMIT\r
+ MOVE.W #'e',D1\r
+ BSR.S PEMIT ; Don't rob PEMIT's return.\r
+ MOVEM.L (SP)+,D1 ; Restore D1\r
+ RTS \r
+*\r
+* ( --- ) No parameter stack effect.\r
+* Assume volatile registers saved,\r
+* Use Atari terminal emulation to turn the text cursor off.\r
+PCROFF MOVEM.L D1,-(SP) Don't destroy D1.\r
+ MOVE.W #$1B,D1\r
+ BSR.S PEMIT\r
+ MOVE.W #'f',D1\r
+ BSR.S PEMIT ; Don't rob PEMIT's return.\r
+ MOVEM.L (SP)+,D1 ; Restore D1\r
+ RTS \r
+*\r
+* ======>> 182 << code for EMIT\r
+* ( --- ) No parameter stack effect.\r
+* Put one byte from D1 out on the CONSOLE device\r
+* using Atari ST BIOS.\r
+PEMIT MOVEM.L D0/D1/D2/A0/A1/A2,-(PSP) ; Save volatile registers, D0 lowest.\r
+ LEA -6(SP),SP ; allocate BIOS parameter space\r
+PEMITW MOVE.W #2,2(SP) ; console device\r
+ MOVE.W #8,(SP) ; bcostat\r
+ TRAP #13 ; BIOS call\r
+ TST.L D0 ; not really necessary?\r
+ BEQ.S PEMITW ; wait for CONSOLE out ready\r
+ MOVE.W NATWID+NATWID/2(PSP),4(SP) ; low word of PSP top is character to output\r
+ MOVE.W #2,2(SP) ; console device\r
+ MOVE.W #3,(SP) ; bconout\r
+ TRAP #13 ; BIOS call\r
+ LEA 6(SP),SP ; deallocate BIOS workspace\r
+ MOVEM.L (PSP)+,D0/D1/D2/A0/A1/A2 ; Restore volatile registers and parameter stack.\r
+ RTS\r
+*\r
+* ======>> 183 << code for KEY\r
+* ( --- ) No parameter stack effect.\r
+* Wait for one keypress from the CONSOLE device\r
+* and return the character code for the key pressed in D1\r
+* using Atari ST BIOS.\r
+PKEY MOVEM.L D0/D2/A0/A1/A2,-(PSP) ; Save volatile registers.\r
+ BSR.S PCURON ; Show the cursor\r
+PKEYG MOVE.W #2,-(SP) ; console device\r
+ MOVE.W #2,-(SP) ; bconin\r
+ TRAP #13 ; BIOS call\r
+ LEA 4(SP),SP ; clean up stack\r
+PKEYT BSR.S PCROFF\r
+ CMP.B #3,D0 ; CTL-C? (Atari BIOS emulates a nice terminal.)\r
+ BNE.S PKEYX\r
+ OR.L #$FFFFFF00,D0 ; set the N flag\r
+PKEYX MOVE.L D0,D1 ; KEY and QTERM expect it in D1.\r
+ MOVEM.L (PSP)+,D0/D2/A0/A1/A2 ; Restore registers without touching flags.\r
+ RTS\r
+*\r
+* ######>> screen 64 <<\r
+* ======>> 184 << code for ?TERMINAL\r
+* ( --- ) No stack effect.\r
+* Check for break key on the CONSOLE device without waiting\r
+* using Atari ST BIOS.\r
+PQTER MOVEM.L D0/D2/A0/A1/A2,-(PSP) ; Save D2.\r
+ MOVE.W #2,-(SP) ; console device\r
+ MOVE.W #1,-(SP) ; bconstat\r
+ TRAP #13 ; BIOS call\r
+ LEA 4(SP),SP ; clean up stack, don't wait\r
+ TST.L D0 ; Got a key?\r
+ BMI.S PKEYG ; Get the key, but D2 already saved.\r
+ BRA.S PKEYX ; Rob PKEY's tail and restore.\r
+*\r
+* ######>> screen 66 <<\r
+* ======>> 187 <<\r
+* ( ??? )\r
+* Query the disk, I suppose.\r
+* Not sure what the model had in mind for this stub.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B '?DIS' ; '?DISC'\r
+ DC.B 'C'|$80\r
+ DC.L ARROW-4-NATWID\r
+QDISC DC.L *+NATWID\r
+ JMP NEXT\r
+*\r
+* ######>> screen 67 <<\r
+* ======>> 189 <<\r
+* ( ??? )\r
+* Write one block of data to disk.\r
+* Parameters unspecified in model. Stub in model.\r
+ EVEN\r
+ DC.B $8B\r
+ DC.B 'BLOCK-WRIT' ; 'BLOCK-WRITE'\r
+ DC.B 'E'|$80\r
+ DC.L QDISC-6-NATWID\r
+BWRITE DC.L *+NATWID\r
+ JMP NEXT\r
+*\r
+* ######>> screen 68 <<\r
+* ======>> 190 <<\r
+* ( ??? )\r
+* Read one block of data from disk.\r
+* Parameters unspecified in model. Stub in model.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $8A\r
+ DC.B 'BLOCK-REA' ; 'BLOCK-READ'\r
+ DC.B 'D'|$80\r
+ DC.L BWRITE-12-NATWID\r
+BREAD DC.L *+NATWID\r
+ JMP NEXT\r
+*\r
+*The next 3 words are written to create a substitute for disc\r
+* mass memory,located between MASSLO & MASSHI in ram --\r
+* ($3210 and $3fff in the 6800 model).\r
+* ======>> 190.1 <<\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'L' ; 'LO'\r
+ DC.B 'O'|$80\r
+ DC.L BREAD-11-NATWID\r
+LO DC.L DOCON\r
+ DC.L MEMEND a system dependent equate at front\r
+*\r
+* ======>> 190.2 <<\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'H' ; 'HI'\r
+ DC.B 'I'|$80\r
+ DC.L LO-3-NATWID\r
+HI DC.L DOCON\r
+ DC.L MEMTOP ( $3FFF or $7FFF in this version )\r
+*\r
+* ######>> screen 69 <<\r
+* ======>> 191 <<\r
+* ( buffer sector f --- )\r
+* Read or Write the specified (absolute -- ignores OFFSET) sector\r
+* from or to the specified buffer. \r
+* A zero flag specifies write,\r
+* non-zero specifies read. \r
+* Sector is an unsigned integer,\r
+* buffer is the buffer's address. \r
+* Will need to use the CoCo ROM disk routines. \r
+* For now, provides a virtual disk in RAM.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'R/' ; 'R/W'\r
+ DC.B 'W'|$80\r
+ DC.L HI-3-NATWID\r
+RW DC.L DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN\r
+ DC.L RW2-*-NATWID\r
+ DC.L PDOTQ\r
+ DC.B 8\r
+ DC.B ' Range ?' ; ' Range ?'\r
+ DC.B 0 ; hand align\r
+ DC.L QUIT\r
+RW2 DC.L FROMR,ZBRAN\r
+ DC.L RW3-*-NATWID\r
+ DC.L SWAP\r
+RW3 DC.L BBUF,CMOVE\r
+ DC.L SEMIS\r
+*\r
+* From BIF-6809:\r
+* RW PSHS Y,U,DP\r
+* LDY $C006 control table\r
+* LDX #DROFFS+7 ; This is BIF's table of drive sizes.\r
+* LDD 2,U\r
+* RWD SUBD ,X++ sectors\r
+* BHS RWD\r
+* BVC RWR table end?\r
+* LDD #6\r
+* PSHU D\r
+* JMP ERROR\r
+* RWR ADDD ,--X back one\r
+* PSHS X\r
+* PSHU D\r
+* LDD #18 sectors/track\r
+* PSHU D\r
+* DOCOL\r
+* FDB SLAMOD\r
+* FDB XMACH\r
+* PULU D\r
+* STB 2,Y track\r
+* PULU D\r
+* INCB\r
+* STB 3,Y sector\r
+* PULS D table entry\r
+* SUBD #DROFFS+7\r
+* ASRB drive #\r
+* STB 1,Y\r
+* LDD 4,U buffer\r
+* STD 4,Y\r
+* LDB #2 coco READ\r
+* LDX ,U 0?\r
+* BNE *+3\r
+* INCB coco WRITE\r
+* STB ,Y op code\r
+* CLRA\r
+* TFR A,DP\r
+* JSR [$C004] ROM handles timeout\r
+* PULS Y,U,DP if IRQ enabled\r
+* LEAU 6,U\r
+* LDX $C006\r
+* LDB 6,X coco status\r
+* BEQ RWE\r
+* LDX <UP\r
+* LDD #0 no disc\r
+* STD UWARN,X\r
+* LDD #8\r
+* PSHU D\r
+* JMP ERROR\r
+* RWE NEXT\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 72 <<\r
+* ======>> 192 <<\r
+* ( --- ) compiling P\r
+* ( --- adr ) interpreting\r
+* { ' name } input\r
+* Parse a symbol name from input and search the dictionary for it, per -FIND;\r
+* compile the address as a literal if compiling,\r
+* otherwise just push it. \r
+ EVEN\r
+ DC.B $C1 ; immediate\r
+ DC.B "'"|$80 ; ' ( tick )\r
+ DC.L RW-4-NATWID\r
+TICK DC.L DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER\r
+ DC.L SEMIS\r
+*\r
+* ======>> 193 <<\r
+* ( --- ) { FORGET name } input\r
+* Parse out name of definition to FORGET to, -DFIND it,\r
+* then lop it and everything that follows out of the dictionary. \r
+* In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'FORGE' ; 'FORGET'\r
+ DC.B 'T'|$80\r
+ DC.L TICK-2-NATWID\r
+FORGET DC.L DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT16\r
+ DC.W $18\r
+ DC.L QERR,TICK,DUP,FENCE,AT,LESS,LIT16\r
+ DC.W $15\r
+ DC.L QERR,DUP,ZERO,PORIG,GREAT,LIT16\r
+ DC.W $15\r
+ DC.L QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 73 <<\r
+* ======>> 194 <<\r
+* ( adr --- ) C\r
+* Calculate a back reference from HERE and compile it. \r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'BAC' ; 'BACK'\r
+ DC.B 'K'|$80\r
+ DC.L FORGET-7-NATWID\r
+* BACK DC.L DOCOL,HERE,SUB,COMMA\r
+BACK DC.L DOCOL,HERE,NATP,SUB,COMMA\r
+ DC.L SEMIS\r
+*\r
+* ======>> 195 <<\r
+* ( --- ) runtime\r
+* typical use: BEGIN code-loop test UNTIL \r
+* typical use: BEGIN code-loop AGAIN \r
+* typical use: BEGIN code-loop test WHILE code-true REPEAT \r
+* ( --- adr n ) compile time P,C\r
+* Push HERE for BACK reference for general (non-counting) loops,\r
+* with BEGIN construct flag.\r
+* A better flag: $4245 (ASCII for 'BE').\r
+ EVEN\r
+ DC.B $C5\r
+ DC.B 'BEGI' ; 'BEGIN'\r
+ DC.B 'N'|$80\r
+ DC.L BACK-5-NATWID\r
+BEGIN DC.L DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.\r
+ DC.L SEMIS\r
+*\r
+* ======>> 196 <<\r
+* ( --- ) runtime\r
+* typical use: test IF code-true ELSE code-false ENDIF \r
+* ENDIF is just a sort of intersection piece, \r
+* marking where execution resumes after both branches.\r
+* ( adr n --- ) compile time\r
+* Check the mark and resolve the IF.\r
+* A better flag: $4846 (ASCII for 'IF').\r
+ EVEN\r
+ DC.B $C5\r
+ DC.B 'ENDI' ; 'ENDIF'\r
+ DC.B 'F'|$80\r
+ DC.L BEGIN-6-NATWID\r
+ENDIF DC.L DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.\r
+* DC.L OVER,SUB,SWAP,STORE\r
+ DC.L OVER,NATP,SUB,SWAP,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 197 <<\r
+* ( --- ) runtime\r
+* typical use: test IF code-true ELSE code-false ENDIF \r
+* ( adr n --- ) \r
+* Alias for ENDIF .\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $C4\r
+ DC.B 'THE' ; 'THEN'\r
+ DC.B 'N'|$80\r
+ DC.L ENDIF-6-NATWID\r
+THEN DC.L DOCOL,ENDIF\r
+ DC.L SEMIS\r
+*\r
+* ======>> 198 <<\r
+* ( limit index --- ) runtime\r
+* typical use: DO code-loop LOOP \r
+* typical use: DO code-loop increment +LOOP\r
+* Counted loop, index is initial value of index.\r
+* Will loop until index equals (positive going)\r
+* or passes (negative going) limit.\r
+* ( --- adr n ) compile time P,C\r
+* Compile (DO), push HERE for BACK reference,\r
+* and push DO control construct flag.\r
+* A better flag: $444F (ASCII for 'DO').\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $C2\r
+ DC.B 'D' ; 'DO'\r
+ DC.B 'O'|$80\r
+ DC.L THEN-5-NATWID\r
+DO DC.L DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.\r
+ DC.L SEMIS\r
+*\r
+* ======>> 199 <<\r
+* ( --- ) runtime\r
+* typical use: DO code-loop LOOP \r
+* Increments the index by one and branches back to beginning of loop.\r
+* Will loop until index equals limit.\r
+* ( adr n --- ) compile time P,C\r
+* Check the mark and compile (LOOP), fill in BACK reference.\r
+* A better flag: $444F (ASCII for 'DO').\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $C4\r
+ DC.B 'LOO' ; 'LOOP'\r
+ DC.B 'P'|$80\r
+ DC.L DO-3-NATWID\r
+LOOP DC.L DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.\r
+ DC.L SEMIS\r
+*\r
+* ======>> 200 <<\r
+* ( n --- ) runtime\r
+* typical use: DO code-loop increment +LOOP\r
+* Increments the index by n and branches back to beginning of loop.\r
+* Will loop until index equals (positive going)\r
+* or passes (negative going) limit.\r
+* ( adr n --- ) compile time P,C\r
+* Check the mark and compile (+LOOP), fill in BACK reference.\r
+* A better flag: $444F (ASCII for 'DO').\r
+ EVEN\r
+ DC.B $C5\r
+ DC.B '+LOO' ; '+LOOP'\r
+ DC.B 'P'|$80\r
+ DC.L LOOP-5-NATWID\r
+PLOOP DC.L DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.\r
+ DC.L SEMIS\r
+*\r
+* ======>> 201 <<\r
+* ( n --- ) runtime\r
+* typical use: BEGIN code-loop test UNTIL \r
+* Will loop until UNTIL tests true.\r
+* ( adr n --- ) compile time P,C\r
+* Check the mark and compile (0BRANCH), fill in BACK reference.\r
+* A better flag: $4245 (ASCII for 'BE').\r
+ EVEN\r
+ DC.B $C5\r
+ DC.B 'UNTI' ; 'UNTIL' : ( same as END )\r
+ DC.B 'L'|$80\r
+ DC.L PLOOP-6-NATWID\r
+UNTIL DC.L DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 74 <<\r
+* ======>> 202 <<\r
+* ( n --- ) runtime\r
+* typical use: BEGIN code-loop test END \r
+* ( adr n --- ) \r
+* Alias for UNTIL .\r
+ EVEN\r
+ DC.B $C3\r
+ DC.B 'EN' ; 'END'\r
+ DC.B 'D'|$80\r
+ DC.L UNTIL-6-NATWID\r
+END DC.L DOCOL,UNTIL\r
+ DC.L SEMIS\r
+*\r
+* ======>> 203 <<\r
+* ( --- ) runtime\r
+* typical use: BEGIN code-loop AGAIN \r
+* Will loop forever \r
+* (or until something uses R> DROP to force the current definition to die,\r
+* or perhaps ABORT or ERROR or some such other drastic means stops things).\r
+* ( adr n --- ) compile time P,C\r
+* Check the mark and compile (0BRANCH), fill in BACK reference.\r
+* A better flag: $4245 (ASCII for 'BE').\r
+ EVEN\r
+ DC.B $C5\r
+ DC.B 'AGAI' ; 'AGAIN'\r
+ DC.B 'N'|$80\r
+ DC.L END-4-NATWID\r
+AGAIN DC.L DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.\r
+ DC.L SEMIS\r
+*\r
+* ======>> 204 <<\r
+* ( --- ) runtime\r
+* typical use: BEGIN code-loop test WHILE code-true REPEAT \r
+* Will loop until WHILE tests false, skipping code-true on end.\r
+* REPEAT marks where execution resumes after the WHILE find a false flag.\r
+* ( aadr1 n1 adr2 n2 --- ) compile time P,C\r
+* Check the marks for WHILE and BEGIN,\r
+* compile BRANCH and BACK fill adr1 reference,\r
+* FILL-IN 0BRANCH reference at adr2.\r
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $C6\r
+ DC.B 'REPEA' ; 'REPEAT'\r
+ DC.B 'T'|$80\r
+ DC.L AGAIN-6-NATWID\r
+REPEAT DC.L DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.\r
+ DC.L TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.\r
+ DC.L SEMIS\r
+*\r
+* ======>> 205 <<\r
+* ( n --- ) runtime\r
+* typical use: test IF code-true ELSE code-false ENDIF \r
+* Will pass execution to the true part on a true flag \r
+* and to the false part on a false flag.\r
+* ( --- adr n ) compile time P,C\r
+* Compile a 0BRANCH and dummy offset\r
+* and push IF reference to fill in and\r
+* IF control construct flag.\r
+* A better flag: $4946 (ASCII for 'IF').\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $C2\r
+ DC.B 'I' ; 'IF'\r
+ DC.B 'F'|$80\r
+ DC.L REPEAT-7-NATWID\r
+IF DC.L DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.\r
+ DC.L SEMIS\r
+*\r
+* ======>> 206 <<\r
+* ( --- ) runtime\r
+* typical use: test IF code-true ELSE code-false ENDIF \r
+* ELSE is just a sort of intersection piece, \r
+* marking where execution resumes on a false branch.\r
+* ( adr1 n --- adr2 n ) compile time P,C\r
+* Check the marks,\r
+* compile BRANCH with dummy offset,\r
+* resolve IF reference,\r
+* and leave reference to BRANCH for ELSE.\r
+* A better flag: $4946 (ASCII for 'IF').\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $C4\r
+ DC.B 'ELS' ; 'ELSE'\r
+ DC.B 'E'|$80\r
+ DC.L IF-3-NATWID\r
+ELSE DC.L DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE\r
+ DC.L ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.\r
+ DC.L SEMIS\r
+*\r
+* ======>> 207 <<\r
+* ( n --- ) runtime\r
+* typical use: BEGIN code-loop test WHILE code-true REPEAT \r
+* Will loop until WHILE tests false, skipping code-true on end.\r
+* ( --- adr n ) compile time P,C\r
+* Compile 0BRANCH with dummy offset (using IF),\r
+* push WHILE reference.\r
+* BEGIN flag will sit underneath this.\r
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').\r
+ EVEN\r
+ DC.B $C5\r
+ DC.B 'WHIL' ; 'WHILE'\r
+ DC.B 'E'|$80\r
+ DC.L ELSE-5-NATWID\r
+WHILE DC.L DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.\r
+ DC.L SEMIS\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 75 <<\r
+* ======>> 208 <<\r
+* ( count --- )\r
+* EMIT count spaces, for non-zero, non-negative counts.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $86\r
+ DC.B 'SPACE' ; 'SPACES'\r
+ DC.B 'S'|$80\r
+ DC.L WHILE-6-NATWID\r
+SPACES DC.L DOCOL,ZERO,MAX,DDUP,ZBRAN\r
+ DC.L SPACE3-*-NATWID\r
+ DC.L ZERO,XDO\r
+SPACE2 DC.L SPACE,XLOOP\r
+ DC.L SPACE2-*-NATWID\r
+SPACE3 DC.L SEMIS\r
+*\r
+* ======>> 209 <<\r
+* ( --- )\r
+* Initialize HLD for converting a double integer. \r
+* Stores the PAD address in HLD.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '<' ; '<#'\r
+ DC.B '#'|$80\r
+ DC.L SPACES-7-NATWID\r
+BDIGS DC.L DOCOL,PAD,HLD,STORE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 210 <<\r
+* ( d --- string length )\r
+* Terminate numeric conversion,\r
+* drop the number being converted,\r
+* leave the address of the conversion string and the length, ready for TYPE.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '#' ; '#>'\r
+ DC.B '>'|$80\r
+ DC.L BDIGS-3-NATWID\r
+EDIGS DC.L DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB\r
+ DC.L SEMIS\r
+*\r
+* ======>> 211 <<\r
+* ( n d --- d )\r
+* Put sign of n (as a flag) at the head of the conversion string.\r
+* Drop the sign flag.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'SIG' ; 'SIGN'\r
+ DC.B 'N'|$80\r
+ DC.L EDIGS-3-NATWID\r
+SIGN DC.L DOCOL,ROT,ZLESS,ZBRAN\r
+ DC.L SIGN2-*-NATWID\r
+ DC.L LIT16\r
+ DC.W "-" \r
+ DC.L HOLD\r
+SIGN2 DC.L SEMIS\r
+*\r
+* ======>> 212 <<\r
+* ( d --- d/base )\r
+* Generate next most significant digit in the conversion BASE,\r
+* putting the digit at the head of the conversion string.\r
+ EVEN\r
+ DC.B $81 ; #\r
+ DC.B '#'|$80\r
+ DC.L SIGN-5-NATWID\r
+DIG DC.L DOCOL,BASE,AT,MSMOD,ROT,LIT16\r
+ DC.W 9\r
+ DC.L OVER,LESS,ZBRAN\r
+ DC.L DIG2-*-NATWID\r
+ DC.L LIT16\r
+ DC.W 7\r
+ DC.L PLUS\r
+DIG2 DC.L LIT16\r
+ DC.W "0" ; ascii zero\r
+ DC.L PLUS,HOLD\r
+ DC.L SEMIS\r
+*\r
+* ======>> 213 <<\r
+* ( d --- dzero )\r
+* Convert d to a numeric string using # until the result is zero.\r
+* Leave the double result on the stack for #> to drop.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '#' ; '#S'\r
+ DC.B 'S'|$80\r
+ DC.L DIG-2-NATWID\r
+DIGS DC.L DOCOL\r
+DIGS2 DC.L DIG,OVER,OVER,OR,ZEQU,ZBRAN\r
+ DC.L DIGS2-*-NATWID\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 76 <<\r
+* ======>> 214 <<\r
+* ( n width --- )\r
+* Print n on the output device in the current conversion base,\r
+* with sign,\r
+* right aligned in a field at least width wide.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B '.' ; '.R'\r
+ DC.B 'R'|$80\r
+ DC.L DIGS-3-NATWID\r
+DOTR DC.L DOCOL,TOR,STOD,FROMR,DDOTR\r
+ DC.L SEMIS\r
+*\r
+* ======>> 215 <<\r
+* ( d width --- )\r
+* Print d on the output device in the current conversion base,\r
+* with sign,\r
+* right aligned in a field at least width wide.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'D.' ; 'D.R'\r
+ DC.B 'R'|$80\r
+ DC.L DOTR-3-NATWID\r
+DDOTR DC.L DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN\r
+ DC.L EDIGS,FROMR,OVER,SUB,SPACES,TYPE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 216 <<\r
+* D. ( d --- )\r
+* Print d on the output device in the current conversion base,\r
+* with sign,\r
+* in free format with trailing space.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $82\r
+ DC.B 'D' ; 'D.'\r
+ DC.B '.'|$80\r
+ DC.L DDOTR-4-NATWID\r
+DDOT DC.L DOCOL,ZERO,DDOTR,SPACE\r
+ DC.L SEMIS\r
+*\r
+* ======>> 217 <<\r
+* ( n --- )\r
+* Print n on the output device in the current conversion base,\r
+* with sign,\r
+* in free format with trailing space.\r
+ EVEN\r
+ DC.B $81 ; .\r
+ DC.B '.'|$80\r
+ DC.L DDOT-3-NATWID\r
+*DOT DC.L DOCOL,STOD,DDOT\r
+DOT DC.L DOCOL,BREAK,STOD,DDOT ; DBG *****\r
+ DC.L SEMIS\r
+*\r
+* ======>> 218 <<\r
+* ( adr --- )\r
+* Print signed word at adr, per DOT.\r
+ EVEN\r
+ DC.B $81 ; ?\r
+ DC.B '?'|$80\r
+ DC.L DOT-2-NATWID\r
+QUEST DC.L DOCOL,AT,DOT\r
+ DC.L SEMIS\r
+*\r
+ PAGE\r
+*\r
+* ######>> screen 77 <<\r
+* ======>> 219 <<\r
+* ( n --- )\r
+* Print out screen n as a field of ASCII,\r
+* with line numbers in decimal.\r
+* Needs a console more than 70 characters wide.\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'LIS' ; 'LIST'\r
+ DC.B 'T'|$80\r
+ DC.L QUEST-2-NATWID\r
+LIST DC.L DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ\r
+ DC.B 6\r
+ DC.B "SCR # "\r
+ DC.B 0 ; hand align\r
+ DC.L DOT,LIT16\r
+ DC.W $10\r
+ DC.L ZERO,XDO\r
+LIST2 DC.L CR,I,THREE\r
+ DC.L DOTR,SPACE,I,SCR,AT,DLINE,XLOOP\r
+ DC.L LIST2-*-NATWID\r
+ DC.L CR\r
+ DC.L SEMIS\r
+*\r
+* ======>> 220 <<\r
+* ( start end --- )\r
+* Print comment lines (line 0, and line 1 if C/L < 41) of screens\r
+* from start to end.\r
+* Needs a console more than 70 characters wide.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'INDE' ; 'INDEX'\r
+ DC.B 'X'|$80\r
+ DC.L LIST-5-NATWID\r
+INDEX DC.L DOCOL,CR,ONEP,SWAP,XDO\r
+INDEX2 DC.L CR,I,THREE\r
+ DC.L DOTR,SPACE,ZERO,I,DLINE\r
+ DC.L QTERM,ZBRAN\r
+ DC.L INDEX3-*-NATWID\r
+ DC.L LEAVE\r
+INDEX3 DC.L XLOOP\r
+ DC.L INDEX2-*-NATWID\r
+ DC.L SEMIS\r
+*\r
+* ======>> 221 <<\r
+* ( n --- )\r
+* List a printer page full of screens.\r
+* Line and screen number are in current base.\r
+* Needs a console more than 70 characters wide.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'TRIA' ; 'TRIAD'\r
+ DC.B 'D'|$80\r
+ DC.L INDEX-6-NATWID\r
+TRIAD DC.L DOCOL,THREE,SLASH,THREE,STAR\r
+ DC.L THREE,OVER,PLUS,SWAP,XDO\r
+TRIAD2 DC.L CR,I\r
+ DC.L LIST,QTERM,ZBRAN\r
+ DC.L TRIAD3-*-NATWID\r
+ DC.L LEAVE\r
+TRIAD3 DC.L XLOOP\r
+ DC.L TRIAD2-*-NATWID\r
+ DC.L CR,LIT16\r
+ DC.W $0F\r
+ DC.L MESS,CR\r
+ DC.L SEMIS\r
+*\r
+* ######>> screen 78 <<\r
+* ======>> 222 <<\r
+* ( --- )\r
+* List the definitions in the current vocabulary.\r
+* Expects to output to full-width screen of printer, not a 32- or 40- column screen\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'VLIS' ; 'VLIST'\r
+ DC.B 'T'|$80\r
+ DC.L TRIAD-6-NATWID\r
+VLIST DC.L DOCOL\r
+* DC.L TRON ; DBG ******\r
+* DC.L LIT16 ; should not be hard coded.\r
+* DC.W $80\r
+ DC.L COLUMS,AT\r
+ DC.L OUT,STORE,CONTXT,AT,AT\r
+VLIST1 DC.L OUT,AT,COLUMS,AT\r
+* DC.L LIT16 ; Should not be hard coded.\r
+* DC.W 32\r
+ DC.L WIDTH,AT\r
+ DC.L SUB,GREAT,ZBRAN\r
+ DC.L VLIST2-*-NATWID\r
+ DC.L CR,ZERO,OUT,STORE\r
+VLIST2 DC.L DUP,IDDOT\r
+* DC.L BREAK ; dbg *****\r
+ DC.L SPACE,SPACE,PFA,LFA,AT\r
+ DC.L DUP,ZEQU,QTERM,OR,ZBRAN\r
+ DC.L VLIST1-*-NATWID\r
+ DC.L DROP\r
+* DC.L TROFF,BREAK ; DBG ********\r
+ DC.L SEMIS\r
+*\r
+* Need some utility stuff that isn't in the fig FORTH:\r
+* ( c --- )\r
+* Emit dot if c is less than blank, else emit c\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'BEMI' ; 'BEMIT'\r
+ DC.B 'T'|$80\r
+ DC.L VLIST-6-NATWID\r
+BEMIT DC.L DOCOL\r
+ DC.L DUP,BL,LESS,ZBRAN\r
+ DC.L BEMITO-*-NATWID\r
+ DC.L DROP,LIT16\r
+ DC.W $2e ; '.'\r
+BEMITO DC.L EMIT\r
+ DC.L SEMIS\r
+*\r
+* ( n width --- )\r
+* Output n in hexadecimal with field width.\r
+ EVEN\r
+ DC.B $83\r
+ DC.B 'X.' ; 'X.R'\r
+ DC.B 'R'|$80\r
+ DC.L BEMIT-6-NATWID\r
+XDOTR DC.L DOCOL\r
+ DC.L BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE\r
+ DC.L SEMIS\r
+*\r
+BYTPLN EQU 16 ; bytes to dump per line\r
+* ( adr --- )\r
+* Dump a line of 16 bytes in memory, in hex and as characters.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'BLIN' ; 'BLINE'\r
+ DC.B 'E'|$80\r
+ DC.L XDOTR-4-NATWID\r
+BLINE DC.L DOCOL\r
+ DC.L DUP,LIT16\r
+ DC.W BYTPLN\r
+ DC.L PLUS,OVER,XDO\r
+BLINEX DC.L I,CAT,THREE,XDOTR,XLOOP\r
+ DC.L BLINEX-*-NATWID\r
+ DC.L SPACE,SPACE\r
+ DC.L DUP,LIT16\r
+ DC.W BYTPLN\r
+ DC.L PLUS,SWAP,XDO\r
+BLINEC DC.L I,CAT,BEMIT,XLOOP\r
+ DC.L BLINEC-*-NATWID\r
+ DC.L SEMIS\r
+*\r
+* ( adr ct --- )\r
+* Dump memory via BLINE from adr to ct (ceiling BYTPLN) bytes.\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'BDUM' ; 'BDUMP'\r
+ DC.B 'P'|$80\r
+ DC.L BLINE-6-NATWID\r
+BDUMP DC.L DOCOL\r
+ DC.L CR,OVER,PLUS,SWAP,XDO\r
+BDUMPL DC.L I,LIT16\r
+ DC.W 4\r
+ DC.L XDOTR,LIT16\r
+ DC.W $3A\r
+ DC.L EMIT,SPACE\r
+ DC.L I,BLINE,CR,LIT16\r
+ DC.W BYTPLN\r
+ DC.L XPLOOP\r
+ DC.L BDUMPL-*-NATWID\r
+ DC.L SEMIS\r
+*\r
+* ======>> XX <<\r
+* ( --- )\r
+* Place holder for triggering low-level debuggers (not in fig Forth).\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'BREA' ; 'BREAK'\r
+ DC.B 'K'|$80\r
+ DC.L BDUMP-6-NATWID\r
+BREAK DC.L *+NATWID\r
+BREAKF NOP ; set a low-level break in here\r
+ NOP\r
+ NOP\r
+ RTS\r
+*\r
+*\r
+ EVEN\r
+ DC.B $85\r
+ DC.B 'TROF' ; 'TROFF'\r
+ DC.B 'F'|$80\r
+ DC.L BREAK-6-NATWID\r
+TROFF DC.L *+NATWID\r
+ CLR.W TRACEM-UORIG(UP)\r
+ RTS\r
+*\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'TRO' ; 'TRON'\r
+ DC.B 'N'|$80\r
+ DC.L TROFF-6-NATWID\r
+TRON DC.L *+NATWID\r
+ MOVE.W #1,TRACEM-UORIG(UP)\r
+ RTS\r
+*\r
+*\r
+* NOOP NEXT a useful no-op\r
+*\r
+* ======>> XX <<\r
+* ( --- )\r
+* Mostly for place holding (fig Forth).\r
+ EVEN\r
+ DC.B 0\r
+ DC.B $84\r
+ DC.B 'NOO' ; 'NOOP'\r
+ DC.B 'P'|$80\r
+ DC.L TRON-5-NATWID\r
+NOOP DC.L *+NATWID\r
+ NOP\r
+ NOP\r
+ NOP\r
+ RTS\r
+* NOOP NEXT a useful no-op\r
+ZZZZ DC.L 0,0,0,0,0,0,0,0 end of rom program\r
+\r
+* About 10.3K in the dictionary image proper.\r
+* This is not surprising, given that the 6809 image is about 6.9K. \r
+* (The 6800 image is about 6.3K, if I remember right.)\r
+* Since the image is mostly pointers, and pointers in the 68000 are 32 bits, not 16\r
+* (since we don't want to limit ourselves to a 32K or so dictionary),\r
+* the 68000 image should be something less than double the size of the 6809 or 6800 image.\r
+\r
+ PAGE\r
+*\r
+\r
+\r
+*\r
+* Build test lists here:\r
+*TESTNEXT:\r
+* DC.L LIT,$FEEDBEEF\r
+* DC.L LIT16\r
+* DC.W $FF0F\r
+* DC.L LIT,AND\r
+* DC.L EXEC\r
+* DC.L BRAN\r
+* DC.L TESTNEXT-*-NATWID\r
+*\r
+*TESTMIN:\r
+* DC.L LIT,5\r
+* DC.L SIGNUM\r
+* DC.L LIT,-10\r
+* DC.L SIGNUM\r
+* DC.L MIN\r
+* DC.L LIT,100\r
+* DC.L MIN\r
+* DC.L DROP\r
+*TESTSUB:\r
+* DC.L LIT,$DEEFEED\r
+* DC.L LIT,$FEDDEBB\r
+* DC.L SUB ; DEEFEED - FEDDEBB\r
+* DC.L BRAN\r
+* DC.L TESTNEXT-*-NATWID\r
+*\r
+\r
+* Here you can see some of the advantages and disadvantages of the inner interpreter loop,\r
+* and of indirect threading.\r
+* PTRACE saves and restores D0/D1/D2/A2 so it can use them.\r
+* PEMIT will also save and restore D1/D2/A2 to protect them from the BIOS calls.\r
+D1MKHX:\r
+ AND.L #$0F,D1\r
+ ADD.B #'0',D1\r
+ CMP.B #'9',D1\r
+ BLE.S D1MKHR\r
+ ADD.B #'A'-'9'-1,D1\r
+D1MKHR RTS\r
+*\r
+PD1H1:\r
+ MOVEM.L D1,-(SP)\r
+ BSR.S D1MKHX\r
+ BSR.W PEMIT\r
+ MOVEM.L (SP)+,D1\r
+ RTS\r
+*\r
+PD1H8:\r
+ MOVEM.L D2,-(SP)\r
+ MOVE.W #7,D2\r
+PD1H8L:\r
+ ROL.L #4,D1 ; Grab the top four bits.\r
+ BSR.S PD1H1\r
+ DBF D2,PD1H8L\r
+ MOVEM.L (SP)+,D2\r
+ RTS\r
+*\r
+PTRACE:\r
+ MOVEM.L D0/D1/D2/A2,-(SP)\r
+ MOVE.B #'|',D1\r
+ BSR.W PEMIT\r
+ MOVE.L (PSP),D1\r
+ BSR.S PD1H8\r
+ MOVE.B #'|',D1\r
+ BSR.W PEMIT\r
+ MOVE.L NATWID(PSP),D1\r
+ BSR.S PD1H8\r
+ MOVE.B #':',D1\r
+ BSR.W PEMIT\r
+ MOVE.L W,D1\r
+ BSR.S PD1H8\r
+ MOVE.B #'>',D1\r
+ BSR.W PEMIT\r
+ BSR.S PNAME\r
+ BSR.W PCR\r
+ MOVEM.L (SP)+,D0/D1/D2/A2\r
+ RTS\r
+*\r
+PSTR:\r
+ SUBQ #1,D2 ; for DBF count\r
+PSTRL MOVE.B (A2)+,D1\r
+ AND.L #$7F,D1\r
+ BSR.W PEMIT\r
+ DBF D2,PSTRL\r
+ RTS\r
+*\r
+IXNAME:\r
+ LEA -2*NATWID(W),A2 ; back up to one past the mode byte.\r
+ TST.B -(A2) ; is it a mode byte?\r
+ BPL.S IXNAMX ; If this is not an end/mode byte, stop.\r
+IXNAML TST.B -(A2) ; back up to the length byte\r
+ BPL.s IXNAML\r
+IXNAMX RTS\r
+*\r
+PNAMN0 DC.B $0E ; Not a dictionary entry, unadorned length,\r
+ DC.B '** NOT NAME **' ; and no tail char flag.\r
+ EVEN \r
+PNAME:\r
+ BSR.S IXNAME\r
+ MOVE.B (A2)+,D2 ; Length byte, point to 1st character\r
+ BPL.S PNAMEF\r
+ AND.W #$1F,D2 ; extract length, word for DBF\r
+ BEQ.S PNAMEF ; all names have length, even NUL\r
+PNAMEP BSR.S PSTR\r
+ RTS\r
+PNAMEF LEA PNAMN0(PC),A2\r
+ MOVE.B (A2)+,D2 ; Error message has length (unadorned), too.\r
+ BRA.S PNAMEP\r
+*\r
+ZZZZ2 DC.L 0,0,0,0,0,0,0,0 ; "real" end of "rom" program\r
+* ALIGN 256 ; want to do this, but the ATARI CNOP directive doesn't look standard to me.\r
+*\r
+* substitute for disc mass memory\r
+NBLK EQU 4 ; # of disc buffer blocks for virtual memory\r
+* Should NBLK be SCRSZ/SECTSZ? maybe not.\r
+* each block is SECTSZ+SECTRL bytes in size,\r
+* holding SECTSZ characters\r
+SECTSZ EQU 256\r
+SECTRL EQU 2*NATWID ; Currently held sector number, etc.\r
+BUFSZ EQU (SECTSZ+SECTRL)*NBLK\r
+*\r
+BUFBAS DS.L BUFSZ\r
+* This is a really awkward place to define the disk buffer records.\r
+*\r
+* *BUG* SECTRL was magic-number hard-wired into several definitions.\r
+* It will take a bit of work to ferret them out.\r
+* It is too small, and it should not be hard-wired.\r
+* SECTSZ was also magic-number hard-wired into several definitions,\r
+* will I find them all?\r
+ DC.L 0,0,0,0,0,0,0,0 ; put a little space between\r
+* ALIGN 256 ; Again, I want to, but ...\r
+MEMEND EQU *\r
+*\r
+SCRSZ EQU 1024\r
+*\r
+* FIRST\r
+*\r
+VDISK EQU MEMEND\r
+*\r
+* Screens for drive 0, including error messages.\r
+*\r
+* SCREEN 0\r
+ DC.B "000~000: ( Index to disk SCREENS SCREEN 0 ) " 0\r
+ DC.B "001~002: ( More Index lines ) " 1\r
+ DC.B "003~003: ( FIG Title page, FIG Copyright Notice ) " 2\r
+ DC.B "004~005: ( FIG ERROR MESSAGES ) " 3\r
+ DC.B "006~007: ( Custom Error Messages ) " 4\r
+ DC.B "008~???: ( Modifications, copyright notices ) " 5\r
+ DC.B "XXX~XXX: " 6\r
+ DC.B "XXX~XXX: " 7\r
+ DC.B "XXX~XXX: " 8\r
+ DC.B "XXX~XXX: " 9\r
+ DC.B "XXX~XXX: " 10\r
+ DC.B "XXX~XXX: " 11\r
+ DC.B "XXX~XXX: " 12\r
+ DC.B "XXX~XXX: " 13\r
+ DC.B "XXX~XXX: " 14\r
+ DC.B "XXX~XXX: " 15\r
+* SCREEN 1\r
+ DC.B "XXX~XXX: ( More index SCREEN 1 ) " 0\r
+ DC.B "XXX~XXX: " 1\r
+ DC.B "XXX~XXX: " 2\r
+ DC.B "XXX~XXX: " 3\r
+ DC.B "XXX~XXX: " 4\r
+ DC.B "XXX~XXX: " 5\r
+ DC.B "XXX~XXX: " 6\r
+ DC.B "XXX~XXX: " 7\r
+ DC.B "XXX~XXX: " 8\r
+ DC.B "XXX~XXX: " 9\r
+ DC.B "XXX~XXX: " 10\r
+ DC.B "XXX~XXX: " 11\r
+ DC.B "XXX~XXX: " 12\r
+ DC.B "XXX~XXX: " 13\r
+ DC.B "XXX~XXX: " 14\r
+ DC.B "XXX~XXX: " 15\r
+* SCREEN 2\r
+ DC.B "XXX~XXX: ( More index SCREEN 2 ) " 0\r
+ DC.B "XXX~XXX: " 1\r
+ DC.B "XXX~XXX: " 2\r
+ DC.B "XXX~XXX: " 3\r
+ DC.B "XXX~XXX: " 4\r
+ DC.B "XXX~XXX: " 5\r
+ DC.B "XXX~XXX: " 6\r
+ DC.B "XXX~XXX: " 7\r
+ DC.B "XXX~XXX: " 8\r
+ DC.B "XXX~XXX: " 9\r
+ DC.B "XXX~XXX: " 10\r
+ DC.B "XXX~XXX: " 11\r
+ DC.B "XXX~XXX: " 12\r
+ DC.B "XXX~XXX: " 13\r
+ DC.B "XXX~XXX: " 14\r
+ DC.B "XXX~XXX: " 15\r
+* SCREEN 3\r
+ DC.B "*************** Code from the fig-FORTH MODEL *************** " 0\r
+ DC.B " " 1\r
+ DC.B " Through the courtesy of " 2\r
+ DC.B " " 3\r
+ DC.B " FORTH INTEREST GROUP " 4\r
+ DC.B " P. O. BOX 1105 " 5\r
+ DC.B " SAN CARLOS, CA. 94070 " 6\r
+ DC.B " " 7\r
+ DC.B " " 8\r
+ DC.B " RELEASE 1 " 9\r
+ DC.B " WITH COMPILER SECURITY " 10\r
+ DC.B " AND " 11\r
+ DC.B " VARIABLE LENGTH NAMES " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " Further distribution must include the above notice. " 15\r
+* SCREEN 4\r
+ DC.B "( ERROR MESSAGES ) " 0\r
+ DC.B "DATA STACK UNDERFLOW " 1\r
+ DC.B "DICTIONARY FULL " 2\r
+ DC.B "HAS INCORRECT ADDRESS MODE " 3\r
+ DC.B "ISN'T UNIQUE " 4\r
+ DC.B " " 5\r
+ DC.B "DISC RANGE? " 6\r
+ DC.B "DATA STACK OVERFLOW " 7\r
+ DC.B "DISC ERROR! " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B "FORTH INTEREST GROUP " 15\r
+* SCREEN 5\r
+ DC.B "( ERROR MESSAGES ) " 0\r
+ DC.B "COMPILATION ONLY, USE IN DEFINITION " 1\r
+ DC.B "EXECUTION ONLY " 2\r
+ DC.B "CONDITIONALS NOT PAIRED " 3\r
+ DC.B "DEFINITION NOT FINISHED " 4\r
+ DC.B "IN PROTECTED DICTIONARY " 5\r
+ DC.B "USE ONLY WHEN LOADING " 6\r
+ DC.B "OFF CURRENT EDITING SCREEN " 7 \r
+ DC.B "DECLARE VOCABULARY " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B "FORTH INTEREST GROUP " 15\r
+* SCREEN 6\r
+ DC.B "( MORE ERROR MESSAGES SCREEN 6 ) " 0\r
+ DC.B " " 1\r
+ DC.B " " 2\r
+ DC.B " " 3\r
+ DC.B " " 4\r
+ DC.B " " 5\r
+ DC.B " " 6\r
+ DC.B " " 7\r
+ DC.B " " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " " 15\r
+* \r
+* SCREEN 7\r
+ DC.B " ( MORE ERROR MESSAGES SCREEN 7 ) " 0\r
+ DC.B " " 1\r
+ DC.B " " 2\r
+ DC.B " " 3\r
+ DC.B " " 4\r
+ DC.B " " 5\r
+ DC.B " " 6\r
+ DC.B " " 7\r
+ DC.B " " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " " 15\r
+*\r
+* SCREEN 8\r
+ DC.B " ( TEXT, LINE WFR-79MAY01 ) " 0\r
+ DC.B " FORTH DEFINITIONS HEX " 1\r
+ DC.B " " 2\r
+ DC.B " 64 CONSTANT C/L " 3\r
+ DC.B " " 4\r
+ DC.B " : TEXT ( ACCEPT FOLLOWING TEXT TO PAD *) " 5\r
+ DC.B " HERE C/L 1+ BLANKS WORD HERE PAD C/L 1+ CMOVE ; " 6\r
+ DC.B " " 7\r
+ DC.B " : LINE ( RELATIVE TO SCR, LEAVE ADDRESS OF LINE *) " 8\r
+ DC.B " DUP FFF0 AND 17 ?ERROR ( KEEP ON THIS SCREEN ) " 9\r
+ DC.B " SCR @ (LINE) DROP ; " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " " 15\r
+*\r
+* SCREEN 9\r
+ DC.B " ( More crude editing facilities. -- one byte characters ) " 0\r
+ DC.B " " 1\r
+ DC.B " 0 VARIABLE LNEDBUF 62 ALLOT ( buffer for line editing ) " 2\r
+ DC.B " " 3\r
+ DC.B " ( ns nl -- ) ( overwrite one line of the screen ) " 4\r
+ DC.B " : PUTLINE LNEDBUF 64 BLANKS ( just enough to write to disc ) " 5\r
+ DC.B " CR LNEDBUF 64 EXPECT CR ( just enough to write ) " 6\r
+ DC.B " SL2BB LNEDBUF SWAP 64 CMOVE UPDATE ; " 7\r
+ DC.B " ( Full screen editing requires keyboard control codes. ) " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " " 15\r
+*\r
+* SCREEN 10\r
+ DC.B " " 0\r
+ DC.B " " 1\r
+ DC.B " " 2\r
+ DC.B " " 3\r
+ DC.B " " 4\r
+ DC.B " " 5\r
+ DC.B " " 6\r
+ DC.B " " 7\r
+ DC.B " " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " " 15\r
+*\r
+* SCREEN 11\r
+ DC.B " " 0\r
+ DC.B " " 1\r
+ DC.B " " 2\r
+ DC.B " " 3\r
+ DC.B " " 4\r
+ DC.B " " 5\r
+ DC.B " " 6\r
+ DC.B " " 7\r
+ DC.B " " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " " 15\r
+*\r
+* SCREEN 12\r
+ DC.B " " 0\r
+ DC.B " " 1\r
+ DC.B " " 2\r
+ DC.B " " 3\r
+ DC.B " " 4\r
+ DC.B " " 5\r
+ DC.B " " 6\r
+ DC.B " " 7\r
+ DC.B " " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " " 15\r
+*\r
+* SCREEN 13\r
+ DC.B " " 0\r
+ DC.B " " 1\r
+ DC.B " " 2\r
+ DC.B " " 3\r
+ DC.B " " 4\r
+ DC.B " " 5\r
+ DC.B " " 6\r
+ DC.B " " 7\r
+ DC.B " " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " " 15\r
+*\r
+* SCREEN 14\r
+ DC.B " " 0\r
+ DC.B " " 1\r
+ DC.B " " 2\r
+ DC.B " " 3\r
+ DC.B " " 4\r
+ DC.B " " 5\r
+ DC.B " " 6\r
+ DC.B " " 7\r
+ DC.B " " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " " 15\r
+*\r
+* SCREEN 15\r
+ DC.B " " 0\r
+ DC.B " " 1\r
+ DC.B " " 2\r
+ DC.B " " 3\r
+ DC.B " " 4\r
+ DC.B " " 5\r
+ DC.B " " 6\r
+ DC.B " " 7\r
+ DC.B " " 8\r
+ DC.B " " 9\r
+ DC.B " " 10\r
+ DC.B " " 11\r
+ DC.B " " 12\r
+ DC.B " " 13\r
+ DC.B " " 14\r
+ DC.B " " 15\r
+*\r
+VDR1 EQU *\r
+RAMDSZ EQU VDR1-VDISK\r
+*\r
+ DS RAMDSZ\r
+*\r
+MEMTOP EQU *\r
+*\r
+* LO\r
+*\r
+MASSLO EQU VDISK\r
+MASSHI EQU MEMTOP\r
+*\r
+* HI\r
+*\r
+* "end" of "usable ram" (If disc mass memory emulation is removed, actual end.)\r
+*\r
+ end ORIG \r
+\r
+\r
+\r
+\r
+\r
OSDN Git Service
