5 * fig-FORTH FOR 68000
\r
6 * ASSEMBLY SOURCE LISTING
\r
10 * WITH COMPILER SECURITY
\r
11 * AND VARIABLE LENGTH NAMES
\r
12 * Flattening the RTS mode
\r
14 * When I got to BUILDS/DOES in FIG68KSB.S,
\r
15 * I realized that the far branch kludge
\r
16 * is more of a paradigm-breaker than I had been expecting.
\r
17 * So I came back to FIG68KRT.S to flatten
\r
18 * the indirect-threading, subroutine-call inner interpreter.
\r
19 * Subroutine-call inner interpreter should allow
\r
20 * seamless interface with CPU native runtime libraries,
\r
22 * Adapted by Joel Matthew Rees
\r
23 * from fig-FORTH for 6800 (via buggy fig-FORTH for 6809) by Dave Lion, et. al.
\r
25 * This free/libre/open source publication is provided
\r
26 * through the courtesy of:
\r
31 * and other interested parties.
\r
34 * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
\r
35 * URL: http://www.forth.org
\r
36 * Further distribution must include this notice.
\r
38 TTL Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
\r
40 * filename fig-forth-hand68000.asm
\r
41 * === FORTH-68000 {date} {time}
\r
44 * Permission is hereby granted, free of charge, to any person obtaining a copy
\r
45 * of this software and associated documentation files (the "Software"), to deal
\r
46 * in the Software without restriction, including without limitation the rights
\r
47 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
\r
48 * copies of the Software, and to permit persons to whom the Software is
\r
49 * furnished to do so, subject to the following conditions:
\r
51 * The above copyright notice and this permission notice shall be included in
\r
52 * all copies or substantial portions of the Software.
\r
54 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
\r
55 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
\r
56 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
\r
57 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
\r
58 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
\r
59 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
\r
62 * "Associated documentation" for this declaration of license
\r
63 * shall be interpreted to include only the comments in this file,
\r
64 * or, if the code is split into multiple files,
\r
65 * all files containing the complete source.
\r
67 * This is the MIT model license, as published by the Open Source Consortium,
\r
68 * with associated documentation defined.
\r
69 * It was chosen to reflect the spirit of the original
\r
70 * terms of use, which used archaic legal terminology.
\r
72 * Authors of the 6800 model:
\r
73 * === Primary: Dave Lion,
\r
74 * === with help from
\r
76 * === LaFarr Stuart,
\r
77 * === The Forth Interest Group
\r
79 * === San Carlos, CA 94070
\r
81 * === Unbounded Computing
\r
82 * === 1134-K Aster Ave.
\r
83 * === Sunnyvale, CA 94086
\r
88 * NOTICE! the fig Forth model has problems,
\r
89 * including known bugs and unknown,
\r
90 * and including vulnerabilities.
\r
92 * While it might be used to bootstrap more correct and secure systems,
\r
93 * it should be primarily used for study, practice, and research.
\r
96 * Some processor-specific stuff:
\r
97 NATWID EQU 4 ; bytes per natural integer/pointer
\r
98 * The assembler ought to have defined these, but I don't see them in the manual:
\r
99 * User program condition codes:
\r
105 * System status flags (68000/68010/CPU32):
\r
108 * Ignoring the interrupt flags for now
\r
110 * The original version was developed on an AMI EVK 300 PROTO
\r
111 * system using an ACIA for the I/O.
\r
112 * This version is developed targeting the Atari ST.
\r
115 * is done in three subroutines:
\r
116 * PEMIT ( word # 182 )
\r
120 * The FORTH words for disc related I/O follow the model
\r
121 * of the FORTH Interest Group, but have not yet been
\r
122 * tested using a real disc.
\r
124 * Addresses in the 6800 implementation reflect the fact that,
\r
125 * on the development system, it was convenient to
\r
126 * write-protect memory at hex 1000, and leave the first
\r
127 * 4K bytes write-enabled. As a consequence, code from
\r
128 * location $1000 to label ZZZZ could be put in ROM.
\r
129 * Minor deviations from the model were made in the
\r
130 * initialization and words ?STACK and FORGET
\r
131 * in order to do this.
\r
133 * Those definitions will be altered somewhat in this
\r
134 * implementation for the 68000 -- Atari ST.
\r
137 * MEMORY MAP for this approximately 128K system:
\r
138 * ( arranged for systems with high-memory ROM/write-protect )
\r
140 * Won't be using the ACIA directly, no need to define addresses.
\r
141 * ACIAC EQU $XXXXXXXX the ACIA control address and
\r
142 * ACIAD EQU ACIAC+1 data address for PROTO
\r
144 * Moving the definitions of the memory area since the usual 68000 assemblers are
\r
145 * so kind as to make sure that definitions dependent on negative offsets and such
\r
146 * are not supported as ORG arguments, etc.
\r
148 * These will be defined elsewhere:
\r
149 * Except the buffers must be defined before being used.
\r
152 * The following buffered I/O definitions must be resolved before being used in the first pass,
\r
153 * for assemblers that insist.
\r
155 * Traditional SCREEN size is 1024.
\r
156 * But it must be a power of 2 multiple of BLOCK size.
\r
157 * The model I/O routines from fig Forth may work better at 8 BLOCKs per SCREEN,
\r
158 * but only 4 buffers (half a SCREEN) in memory
\r
159 * -- because of certain tightly-coupled design features (bugs).
\r
161 * * If your block I/O works directly on sector buffers,
\r
162 * BLOCK size should be SECTOR size.
\r
163 * * If your sector buffer memory is not in Forth-controlled memory,
\r
164 * BLOCK size can be decoupled from SECTOR size. But your low-level routines
\r
165 * have to handle the copying between correctly.
\r
167 * This version of the model does not handle BLOCK 0 buffering well.
\r
169 * And, of course, this should be in a table with entries for each block I/O device.
\r
171 NBLK EQU 4 ; # of disc buffer blocks for "virtual memory"
\r
175 RSECSZ EQU 256 ; size of the RAM-resident emulated block I/O sector
\r
176 RBLKSZ EQU SCRSZ/NBLK ;
\r
177 * each block buffer is RBLKSZ+SECTRL bytes in size,
\r
178 * holding RBLKSZ characters
\r
179 SECTRL EQU 2*NATWID ; Currently held sector number, etc.
\r
180 BUFSZ EQU (RBLKSZ+SECTRL)*NBLK
\r
184 * MEMEND EQU 132*NBLK+ENDofCODE end of ram
\r
185 * each block is 132 bytes in size,
\r
186 * holding 128 characters
\r
188 * MEMTOP EQU $WAYupHIGH absolute end of all ram
\r
189 * MEMORY MAP for this 16K system:
\r
190 * ( positioned so that systems with 4k byte write-
\r
191 * protected segments can write protect FORTH )
\r
193 * addr. contents pointer init by
\r
194 * **** ******************************* ******* ******
\r
196 * substitute for disc mass memory
\r
199 * 4 buffer sectors of VIRTUAL MEMORY
\r
200 * ENDofCODE+1 FIRST
\r
201 * >>>>>> memory from here up must be RAM <<<<<<
\r
204 * >>>>>>--------Two words to start RAMmable dictionary--------<<<<<<
\r
206 * ~12k of romable "FORTH" <== IP ABORT
\r
208 * the VIRTUAL FORTH MACHINE
\r
210 * ENTRY+4 <<< WARM START ENTRY >>>
\r
211 * ENTRY <<< COLD START ENTRY >>>
\r
213 * >>>>>> memory from here down must be RAM <<<<<<
\r
214 * IRP RETURN STACK base <== RP RINIT
\r
217 * INPUT LINE BUFFER
\r
218 * holds up to 132 characters
\r
219 * and is scanned upward by IN
\r
222 * IPSP DATA STACK <== SP SP0,SINIT
\r
223 * | grows downward from here
\r
227 * | DICTIONARY grows upward
\r
229 * These two entries will be copied from the end of the "ROMmable" dictionary
\r
230 * into the bottom of the "RAMmable" dictionary area to link the two parts together.
\r
232 * end of ram-dictionary. <== DP DPINIT
\r
235 * "FORTH" ( a word ) <=, <== CONTEXT
\r
237 * start of RAM dictionary area.
\r
239 * RTDICT+(something) "FORTH" ( definition ) <=, <== CONTEXT
\r
241 * RTDICT start of ram-dictionary.
\r
243 * USERSP user #1 table of variables <= UP DPINIT
\r
244 * --- No need for registers & pointers for the virtual machine
\r
245 * No need for scratch area used by various words
\r
246 * --- lowest address used by FORTH
\r
247 * Linker/loader structures produced by assembler and linker
\r
249 * >>>>>> memory from here down left alone <<<<<<
\r
250 * >>>>>> so we can safely call ROM routines <<<<<<
\r
252 * UNK don't care stuff, if anything
\r
255 * EXCVCT 68000 exception vectors
\r
260 * ORG $30000 ; Not on the Atari ST under EMUTOS.
\r
262 * Edit this according to the desired size for the dictionary.
\r
263 RTDCSZ EQU 8*1024 ; Must be even on 68000. For now, keep total size under 32K.
\r
265 * This should be adjusted to the target:
\r
267 CODEBG EQU * ; On the Atari ST, the assembler should determine this.
\r
269 * per-task (per-user) tables
\r
270 USERAL EQU 64*NATWID ; allocatable
\r
271 USERCT EQU 4 ; maybe, someday?
\r
273 * USERSP EQU * ; (task-local variable space, addressable by UP) ; NOPE!
\r
274 USERSP EQU USERAL*USERCT ; (task-local variable space, addressable by UP)
\r
275 * IUP EQU USERSP ; USERSZ*USERCT ; Nope!
\r
276 * The per-user (or task-local) table definitions are moved to the end
\r
277 * to avoid using BSS segments, because I don't know how well they are
\r
278 * supported in various 68K assemblers.
\r
280 * This system is built for one "user", or task,
\r
281 * but additional users (tasks) may be added
\r
282 * by allocating additional user tables.
\r
284 * Some of this stuff gets initialized during
\r
285 * COLD start and WARM start:
\r
286 * [ names correspond to FORTH words of similar (no X) name ]
\r
288 * A few useful VM variables --
\r
289 * Will be removed when they are no longer needed.
\r
290 * All are replaced by 68000 registers.
\r
292 * The Atari apparently wants the beginning of the image to be a jump to the entry point.
\r
293 * Put a jump around stuff here, anyway.
\r
295 * MOVE.L #ORIG-SURPRISE,D7
\r
297 * JMP (PC,D7) ; monku monku mutter mutter mumble mumble butsu butsu
\r
298 JMP ORIG ; In case the distance is greater than 32K.
\r
299 * And this is why people don't understand true position independent coding.
\r
301 N DS.L 8 ; might be used as scratch if we really needed it.
\r
303 * These locations could be used by a TRACE routine :
\r
304 TRLIM DS.W 1 ; the count for tracing without user intervention
\r
305 TRACEM DS.W 1 ; non-zero = trace mode
\r
306 BRKPT DS.L 1 ; the breakpoint address at which
\r
307 * the program will go into trace mode
\r
308 VECT DS.L 1 ; vector to machine code
\r
309 * (only needed if the TRACE routine is resident)
\r
311 * Registers used by the FORTH virtual machine:
\r
312 * Starting at $OOFO in the 6800, unneeded here:
\r
314 * All of these are defined below, with explanation.
\r
315 * W RMB NATWID ; the instruction register remembers IP.
\r
316 * IP RMB NATWID ; the instruction pointer points to pointer to 6800 code
\r
317 * RP RMB NATWID ; the return stack pointer
\r
318 * PSP RMB NATWID ; the parameter stack pointer (Forth SP)
\r
319 * UP RMB NATWID ; the pointer to base of current user's 'USER' table
\r
320 * ( altered by a task switch )
\r
323 DS.B USERAL-(GAP-START)
\r
325 UORIG DS.L 3 ; 3 reserved variables
\r
326 XSPZER DS.L 1 ; initial top of data stack for this user
\r
327 XRZERO DS.L 1 ; initial top of return stack
\r
328 XTIB DS.L 1 ; start of terminal input buffer
\r
329 XWIDTH DS.L 1 ; name field width ****** could be byte
\r
330 XWARN DS.L 1 ; warning message mode (0 = no disc) ****** could be byte
\r
331 XFENCE DS.L 1 ; fence for FORGET
\r
332 XDICTP DS.L 1 ; dictionary pointer
\r
333 XVOCL DS.L 1 ; vocabulary linking
\r
334 XBLK DS.L 1 ; disc block being accessed
\r
335 XIN DS.L 1 ; scan pointer into the block ****** could be 16-bit
\r
336 XOUT DS.L 1 ; cursor position ****** could be 16-bit
\r
337 XSCR DS.L 1 ; disc screen being accessed ( O=terminal )
\r
338 XOFSET DS.L 1 ; disc sector offset for multi-disc
\r
339 XCONT DS.L 1 ; last word in primary search vocabulary
\r
340 XCURR DS.L 1 ; last word in extensible vocabulary
\r
341 XSTATE DS.L 1 ; flag for 'interpret' or 'compile' modes ****** could be byte?
\r
342 XBASE DS.L 1 ; number base for I/O numeric conversion ****** could be byte
\r
343 XDPL DS.L 1 ; decimal point place ****** could be 16-bit
\r
344 XFLD DS.L 1 ; conversion field ****** could be 16-bit
\r
345 XCSP DS.L 1 ; current stack position, for compile checks
\r
346 XRNUM DS.L 1 ; ****** could be 16-bit?
\r
347 XHLD DS.L 1 ; ****** could be 16-bit?
\r
348 XDELAY DS.L 1 ; carriage return delay count ****** could be byte
\r
349 XCOLUM DS.L 1 ; carriage width ****** could be 16-bit
\r
350 IOSTAT DS.L 1 ; last acia status from write/read ****** could be byte or 16-bit
\r
352 * end of user table, start of (theoretical) common system variables
\r
354 * These need to be moved to where they will be
\r
355 * initialized globals in variable space, not in the USER table.
\r
356 * Or, more accurately, need to be turned into monitored or semaphored resources.
\r
361 XUCURR DS.L 1 ; user table current allocation
\r
364 DS.B USERAL-(XDEF-UORIG) ; allocatable
\r
366 *USERSZ EQU *-UORIG
\r
367 DS.B USERAL*(USERCT-1)
\r
370 VOCFLG EQU $832020A0 ; flag (dummy) entry to switch vocabularies by.
\r
371 * These things, up through the label 'REND', are overwritten
\r
372 * at time of cold load and should have the same contents
\r
378 DC.B 'FORT' ; 'FORTH'
\r
381 FORTH: DC.L DODOES,DOVOC,VOCFLG,TASK-5-NATWID
\r
384 DC.B "Copyright 1979 Forth Interest Group, David Lion,"
\r
386 DC.B "Parts Copyright 2019 Joel Matthew Rees"
\r
392 DC.B 'TAS' ; 'TASK'
\r
394 DC.L FORTH-6-NATWID
\r
395 TASK: DC.L DOCOL,SEMIS
\r
397 REND EQU * ( first empty location in dictionary )
\r
398 RSIZE EQU *-RBEG ; So we can look at it.
\r
402 * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
\r
404 * IP points to the next FORTH VM instruction ( pre-increment mode )
\r
405 IP EQUR A5 ; post-inc mode, as opposed to 6800 model.
\r
406 * RP points to last return address pushed on return stack
\r
407 RP EQUR A7 ; Yes, we are going to break with fig false traditions.
\r
408 * PSP points to last item pushed on data (parameter) stack
\r
409 PSP EQUR A6 ; SP is already defined as A7 on 68K.
\r
410 * may conflict with using A6 as frame pointer? Not really.
\r
411 * Note that 6800 S points one below last byte pushed. We don't have to do that.
\r
413 * A5 must be IP when NEXT is entered (when using the inner loop).
\r
415 * D0 handles all of what is A:B on 6801/6809.
\r
417 * UP (could be DP on 6809) is the base of per-task ("user") variables.
\r
419 * (Be careful of the stray semantics of "user".)
\r
421 * W (hardware X) is the pointer to the "code field" address of native CPU
\r
423 * Points to pointer to machine code to be executed for the definition
\r
424 * of the dictionary word to be executed/currently executing.
\r
425 * The following natural integer (word) begins any "parameter section"
\r
426 * (body) -- similar to a "this" pointer, but not the same.
\r
427 * It may be native CPU machine code, or it may be a global variable,
\r
428 * or it may be a list of Forth definition words (addresses).
\r
430 * Since we have it, give it a handle. The execute vector:
\r
431 * (Only valid until used elsewhere.)
\r
434 * A0 and A1 used as scratch indexes.
\r
435 * D0 through D7 used as scratch registers.
\r
436 * Some related routines (for example, LOOP) use D0 as a shared parameter.
\r
438 * Except that I want to keep this close to the fig model:
\r
439 ** We've got the registers, might as well use 'em.
\r
440 ** Defined for the I-level loop variables:
\r
441 * LUPLIM EQUR D5 ; limit was pushed first,
\r
442 * LUPCT EQUR D4 ; then index/count
\r
443 ** J-level is on the return stack.
\r
446 * This implementation uses the indirect subroutine architecture
\r
447 * -- a postponed-push call that the 6800 model VM also uses
\r
448 * to save code and time in leaf routines.
\r
450 * It won't allow mixing assembly language directly into Forth word lists.
\r
454 * 0 is false, anything else is true.
\r
455 * Most places in this model that set a boolean flag set true as 1.
\r
456 * This is in contrast to many models that set a boolean flag as -1.
\r
460 * The run-time dictionary allocation area begins here,
\r
461 * initialized with the FORTH and TASK definitions that will be
\r
464 RTDICT DS.B RTDCSZ ; dictionary allocation space
\r
466 PSPSPC EQU 256*NATWID ; for the parameter stack
\r
468 SPBUMP EQU 4*NATWID
\r
469 IPSP DS.L SPBUMP ; initial PSP below, bumper zone above
\r
471 * Don't want terminal input and parameter underflow collisions
\r
472 TIBSZ EQU 80 ; bytes of input buffer, must be even on 68000.
\r
473 ITIB DS.B TIBSZ ; Also, must match terminal width. (Bad design.)
\r
475 * *** This is quite clearly a vulnerability! ***
\r
476 SFTBND EQU * ; (pseudo boundary between TIB and return stack)
\r
478 RPSPAC EQU 128*NATWID ; for the return stack
\r
480 RPBUMP EQU 4*NATWID
\r
481 IRP DS.B RPBUMP ; initial RP below, bumper zone above
\r
484 * Expecting 8K to 12K for the kernel, because pointers are 4 bytes.
\r
487 * "ROMmable" init tables and pre-compiled dictionary
\r
489 * The FORTH interpreter will be organized
\r
490 * so that it can be in a ROM, or write-protected if desired,
\r
491 * but right now we're just getting it running.
\r
493 * ######>> screen 3 <<
\r
495 ***************************
\r
496 ** C O L D E N T R Y **
\r
497 ***************************
\r
500 BRA.W CENT ; ROMmable dictionary size is less than 32K
\r
501 ***************************
\r
502 ** W A R M E N T R Y **
\r
503 ***************************
\r
505 BRA.W WENT warm-start code, keeps current dictionary intact
\r
508 MAXNML EQU 32 ; max name length of words (symbols) in the dictionary
\r
509 NMLMSK EQU MAXNML-1 ; MAXNML must be a power of 2.
\r
510 ******* startup parmeters **************************
\r
512 DC.L $68000,00000000 ; cpu & revision
\r
513 DC.L 0 ; topmost word in FORTH vocabulary
\r
514 * BACKSP DC.L $7F ; backspace character for editing
\r
515 BACKSP DC.L $08 ; backspace character for editing
\r
516 UPINIT DC.L UORIG ; initial user area
\r
517 SINIT DC.L IPSP ; initial top of data stack
\r
518 RINIT DC.L IRP ; initial top of return stack
\r
519 DC.L ITIB ; terminal input buffer
\r
520 IWIDTH DC.L MAXNML ; initial name field width
\r
521 DC.L 0 ; initial warning mode (0 = no disc)
\r
522 FENCIN DC.L REND ; initial fence
\r
523 DPINIT DC.L REND ; cold start value for DICTPT
\r
524 BUFINT DC.L BUFBAS ; Start of the disk buffers area
\r
525 VOCINT DC.L FORTH+4*NATWID
\r
526 COLINT DC.L TIBSZ ; initial terminal carriage width
\r
527 DELINT DC.L 4 ; initial carriage return delay
\r
528 ****************************************************
\r
533 * ######>> screen 13 <<
\r
534 * These are of questionable use anyway,
\r
535 * and are too much trouble to use with native subroutine call anyway.
\r
536 *POPD0X MOVE.L (PSP)+,D0 ; These may actually not end up being used.
\r
537 *STD0X MOVE.L D0,(A0)
\r
539 *GETX MOVE.L (A0),D0
\r
540 PUSHD0 MOVE.L D0,-(PSP) ; fall through to NEXT
\r
542 * "NEXT" takes ?? cycles if TRACE is removed,
\r
544 * and ?? cycles if trace is present and NOT tracing.
\r
546 * = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
\r
548 * NEXT itself might just completely go away.
\r
549 * About the only reason to keep it is to allow executing a list
\r
550 * which allows a cheap TRACE routine.
\r
552 * NEXT is a loop which implements the Forth VM.
\r
553 * It basically cycles through calling the code out of code lists,
\r
555 * Using a native CPU return for this uses a few extra cycles per call,
\r
556 * compared to simply jumping to each definition and jumping back
\r
557 * to the known beginning of the loop,
\r
558 * but the loop itself is really only there for convenience,
\r
559 * in the first place.
\r
561 * This implementation uses indirect threading,
\r
562 * leaving a wall between Forth VM code and non-Forth VM code.
\r
564 NEXT: ; IP is a register.
\r
565 NEXT2 MOVE.L (IP)+,W ; get W which points to CFA of word to be done
\r
566 NEXT3 MOVE.L (W)+,VEC ; get characteristic address, point to Parameter Field.
\r
567 * These NOPs can be patched at run-time to JMP TRACE =
\r
568 * if a TRACE routine is available: =
\r
574 TST.W TRACEM-UORIG(UP) =
\r
579 * In other words, with the call and the NOP,
\r
580 * there is room to patch the loop with a call to your TRACE
\r
581 * routine, which you have to provide.
\r
583 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
\r
589 * Pushes the following natural width integer from the instruction stream
\r
590 * as a literal, or immediate value.
\r
595 * DC.L LITERAL-TO-BE-PUSHED
\r
598 * In native processor code, there should be a better way, use that instead.
\r
599 * More specifically, DO NOT CALL THIS from assembly language code.
\r
600 * (Note that there is no compile-only flag in the fig model.)
\r
602 * See (FIND), or PFIND , for layout of the header format.
\r
606 DC.B 'LI' ; 'LIT' : NOTE: this is different from LITERAL
\r
607 DC.B 'T'|$80 ; character code for T, with high bit set.
\r
608 DC.L 0 ; link of zero to terminate dictionary scan
\r
609 LIT DC.L *+NATWID ; Note also that LIT is meaningless in native code.
\r
610 MOVE.L (IP)+,-(PSP)
\r
613 * ######>> screen 14 <<
\r
616 * Save a little dictionary space by pushing a half-width value as a full-width value.
\r
617 * LIT8 won't really work with the 68000 because of alignment problems,
\r
618 * but LIT16 will save a little space.
\r
619 * Pushes the following 16-bit word from the instruction stream
\r
620 * as a literal, or immediate value.
\r
622 * If this is kept, it should have a header for TRACE to read.
\r
623 * If the data bus is wider than a byte, consider whether you want to do this.
\r
624 * Byte shaving like this is often counter-productive anyway.
\r
625 * Changing the name to LIT16, hoping that will be more understandable.
\r
626 * Also, see comments for LIT: DO NOT CALL THIS from assembly language code.
\r
627 * (Note that there is no compile-only flag in the fig model.)
\r
630 DC.B 'LIT1' ; 'LIT16' ; half a LIT
\r
633 LIT16 DC.L *+NATWID ; (this was an invisible word, with no header)
\r
634 CLR.L -(PSP) ; The fig model does not sign extend.
\r
635 MOVE.W (IP)+,NATWID/2(PSP)
\r
637 * CLR.L D0 ; The fig model does not sign extend.
\r
639 **NOT this: BRA.W PUSHD0
\r
645 * Jump to address on stack. Used by the "outer" interpreter to
\r
646 * interactively invoke routines.
\r
647 * Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
\r
650 DC.B 'EXECUT' ; 'EXECUTE'
\r
652 DC.L LIT16-6-NATWID
\r
654 MOVE.L (PSP)+,W ; Get the adr parameter.
\r
655 * LEA NATWID(RP),RP ; Dump the return
\r
656 * BRA.S NEXT3 ; Sub it.
\r
657 MOVE.L (W)+,VEC ; Or, pretend we are the inner interpreter
\r
658 JMP (VEC) ; tail return
\r
661 * ######>> screen 15 <<
\r
664 * Add the following word from the instruction stream to the
\r
665 * instruction pointer (Y++). Causes a program branch in Forth code stream.
\r
667 * In native processor code, there should be a better way, use that instead.
\r
668 * More specifically, DO NOT CALL THIS from assembly language code.
\r
669 * This is only for Forth code stream.
\r
670 * Also, see comments for LIT.
\r
674 DC.B 'BRANC' ; 'BRANCH'
\r
677 BRAN DC.L ZBYES ; Go steal code in ZBRANCH
\r
679 * Moving code around to optimize the branch taking case in 0BRANCH.
\r
680 ZBNO LEA NATWID(IP),IP ; No branch.
\r
684 * BRANCH if flag is zero.
\r
686 * In native processor code, there should be a better way, use that instead.
\r
687 * More specifically, DO NOT CALL THIS from assembly language code.
\r
688 * This is only for Forth code stream.
\r
689 * Also, see comments for LIT.
\r
692 DC.B '0BRANC' ; '0BRANCH'
\r
695 ZBRAN DC.L *+NATWID
\r
698 ZBYES MOVE.L (IP)+,D0
\r
699 LEA (IP,D0.L),IP ; IP is postinc
\r
703 * ######>> screen 16 <<
\r
706 * ( --- ) ( limit index *** limit index+1) C
\r
707 * ( limit index *** )
\r
708 * Counting loop primitive. The counter and limit are the top two
\r
709 * words on the return stack. If the updated index/counter does
\r
710 * not exceed the limit, a branch occurs. If it does, the branch
\r
711 * does not occur, and the index and limit are dropped from the
\r
714 * Loop words share the counter increment via D0.
\r
716 * In native processor code, there should be a better way, use that instead.
\r
717 * More specifically, DO NOT CALL THIS from assembly language code.
\r
718 * This is only for Forth code stream.
\r
719 * Also, see comments for LIT.
\r
720 * D0 and various code paths are shared with XPLOOP.
\r
721 * Having to dodge the return address on the stack might be reason
\r
722 * for loop variables in registers, but not yet.
\r
723 LUPLIM EQU NATWID*2 ; limit was pushed first,
\r
724 LUPCT EQU NATWID ; then index/count
\r
729 DC.B '(LOOP' ; '(LOOP)'
\r
731 DC.L ZBRAN-8-NATWID
\r
732 XLOOP DC.L *+NATWID
\r
733 MOVEQ #1,D0 ; Loop counter and limit in registers.
\r
734 XLOOPA ADD.L LUPCT(RP),D0
\r
735 MOVE.L D0,LUPCT(RP)
\r
736 CMP.L LUPLIM(RP),D0
\r
737 BMI.S ZBYES ; pseudo-signed-unsigned
\r
738 XLOOPN LEA NATWID(IP),IP
\r
739 MOVE.L (RP),A0 ; Get the return to NEXT.
\r
740 LEA LUPLIM+NATWID(RP),RP ; drop loop control variables
\r
743 * Notes for loop counter and limit in registers:
\r
744 * MOVEQ #1,D0 ; Loop counter and limit in registers.
\r
745 * XLOOPA ADD.L D0,LUPCT
\r
746 * CMP.L LUPLIM,LUPCT
\r
747 * BMI.S ZBYES ; pseudo-signed-unsigned
\r
748 * XLOOPN LEA NATWID(IP),IP
\r
749 * MOVEM.L (RP)+,LUPLIM/LUPCT ; restore possible outer loop controls
\r
753 * ( n --- ) ( limit index *** limit index+n ) C
\r
754 * ( limit index *** )
\r
755 * Loop with a variable increment. Terminates when the index
\r
756 * crosses the boundary from one below the limit to the limit. A
\r
757 * positive n will cause termination if the result index equals the
\r
758 * limit. A negative n must cause the index to become less than
\r
759 * the limit to cause loop termination.
\r
761 * Note that the end conditions are not symmetric around zero.
\r
763 * In native processor code, there should be a better way, use that instead.
\r
764 * More specifically, DO NOT CALL THIS from assembly language code.
\r
765 * This is only for Forth code stream.
\r
766 * Also, see comments for LIT.
\r
767 * D0 and various code paths are shared with XLOOP.
\r
770 DC.B '(+LOOP' ; '(+LOOP)'
\r
772 DC.L XLOOP-7-NATWID
\r
773 XPLOOP DC.L *+NATWID ; Loop counter and limit in registers.
\r
774 MOVE.L (PSP)+,D0 ; inc val
\r
775 BPL.S XLOOPA ; Steal plain loop code for forward count.
\r
777 MOVE.L D0,LUPCT(RP)
\r
778 CMP.L LUPLIM(RP),D0
\r
779 BPL.S ZBYES ; pseudo-signed-unsigned
\r
780 BRA.S XLOOPN ; This path might be less time-sensitive.
\r
782 * Notes for loop counter and limit in registers:
\r
783 * MOVE.L (PSP)+,D0 ; inc val
\r
784 * BPL.S XLOOPA ; Steal plain loop code for forward count.
\r
786 * CMP.L LUPLIM,LUPCT
\r
787 * BPL.S ZBYES ; pseudo-signed-unsigned
\r
788 * BRA.S XLOOPN ; This path might be less time-sensitive.
\r
790 * ######>> screen 17 <<
\r
792 * ( limit index --- ) ( *** outerlimit outerindex )
\r
793 * Save whatever is in limit and index registers, Load the loop parameters.
\r
794 * This would NOT be a synonym for D>R (2>R) if we were keeping the control variables in registers.
\r
798 DC.B '(DO' ; '(DO)'
\r
800 DC.L XPLOOP-8-NATWID
\r
801 XDO DC.L *+NATWID ; This is the RUNTIME DO, not the COMPILING DO
\r
802 MOVEM.L (PSP)+,D0/D1 ; MOVEM preserves the order.
\r
803 MOVE.L (RP)+,A0 ; get the return to NEXT out of the way.
\r
804 MOVEM.L D0/D1,-(RP) ; Control variables are now on the return stack.
\r
805 JMP (A0) ; Back to NEXT
\r
807 * Notes for loop counter and limit in registers:
\r
808 * MOVE.L (RP)+,A0 ; Get the reurn to NEXT out of the way
\r
809 * MOVEM.L LUPLIM/LUPCT,-(RP) ; save possible outer loop limit and count
\r
810 * MOVEM.L (PSP)+,LUPLIM/LUPCT ; limit must be higher register number to be deeper in stack.
\r
811 * JMP (A0) ; Back to NEXT
\r
814 * ( --- index ) ( limit index *** limit index )
\r
815 * Copy the loop index from the index register.
\r
816 * This would NOT be a synonym for R if we were keeping the control variables in registers.
\r
822 MOVE.L LUPCT(RP),-(PSP) ; hide dodge in LUPCT
\r
825 * Notes for loop counter and limit in registers:
\r
826 * MOVE.L LUPCT,-(PSP) ; nothing to dodge
\r
829 * ######>> screen 18 <<
\r
831 * ( c base --- false )
\r
832 * ( c base --- n true )
\r
833 * Translate C in base, yielding a translation valid flag.
\r
834 * If the translation is not valid in the specified base,
\r
835 * only the false flag is returned.
\r
838 DC.B 'DIGI' ; 'DIGIT'
\r
841 DIGIT DC.L *+NATWID ; NOTE: legal input range is 0-9, A-Z
\r
842 MOVE.L NATWID(PSP),D0 ; Check the whole 32 bits.
\r
843 CMP.L #'Z',D0 ; Allow byte width from here.
\r
845 SUB.L #'0',D0 ; ascii zero
\r
846 BLO.S DIGITN ; IF LESS THAN '0', ILLEGAL
\r
848 BLS.S DIGITB ; IF '9' OR LESS
\r
849 SUB.B #'A'-('9'+1),D0 ; translate 'A' thru 'Z'
\r
850 CMP.B #$A,D0 ; between '9' and 'A'?
\r
851 BLO.S DIGITN ; if less than 'A'
\r
852 DIGITB CMP.B NATWID-1(PSP),D0 ; Check the base.
\r
853 BHS.S DIGITN ; error if not less than the base
\r
854 MOVE.L D0,NATWID(PSP) ; Store converted digit. (High bytes known zero.)
\r
855 MOVE.L #1,(PSP) ; store valid flag
\r
857 DIGITN LEA NATWID(PSP),PSP ; pop base
\r
858 MOVE.L #0,(PSP) ; set not valid flag
\r
861 * ######>> screen 19 <<
\r
863 * The word definition format in the dictionary:
\r
865 * (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
\r
867 * EVEN address alignment on 68K.
\r
868 * Optional byte of zero for odd name fields on 68K.
\r
869 * NFA (name field address):
\r
870 * char-count + $80 Length of symbol name, flagged with high bit set.
\r
871 * char 1 Characters of symbol name.
\r
874 * char n + $80 symbol termination flag (char set < 128 code points)
\r
875 * LFA (link field address):
\r
877 * ... inner byte \___pointer to previous word in list
\r
878 * ... inner byte / (List is combined allocation/dictionary list.)
\r
880 * CFA (code field address):
\r
882 * ... inner byte \___pointer to native CPU machine code
\r
883 * ... inner byte / -- Consider this the characteristic code. --
\r
885 * PFA (parameter field address):
\r
886 * parameter fields -- Machine code for low-level native machine CPU code,
\r
887 * " instruction list for high-level Forth code,
\r
888 * " constant data for constants, pointers to per task variables,
\r
889 * " space for variables, for global variables, etc.
\r
891 * In the case of native CPU machine code, the address at CFA (the code field) will be PFA.
\r
893 * Definition attributes:
\r
894 FIMMED EQU $40 ; Immediate word flag.
\r
895 FSMUDG EQU $20 ; Smudged => definition not ready.
\r
896 CTMASK EQU ($FF&(~($80|FIMMED))) ; For unmasking the length byte.
\r
897 * Note that the SMUDGE bit is not masked out.
\r
899 * But we really want more flags (Thinking for a new model, need one more byte):
\r
900 * FCOMPI EQU $10 ; Compile-time-only.
\r
901 * FASSEM EQU $08 ; Assembly-language code only.
\r
902 * F4THLV EQU $04 ; Must not be called from assembly language code.
\r
903 * These would require some significant adjustments to the model.
\r
904 * We also want to put the low-level VM stuff in its own vocabulary, eventually.
\r
907 * (FIND) ( name vocptr --- locptr length true )
\r
908 * ( name vocptr --- false )
\r
909 * Search vocabulary for a symbol called name.
\r
910 * name is a pointer to a high-bit bracketed string with length head.
\r
911 * vocptr is a pointer to the NFA of the tail-end (LATEST) definition
\r
912 * in the vocabulary to be searched.
\r
913 * Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
\r
914 * Use the stack and registers instead of temp area N.
\r
915 PA0 EQU NATWID ; pointer to the length byte of name being searched against
\r
916 YPA0 EQUR A2 ; ditto
\r
917 PD EQU 0 ; pointer to NFA of dict word being checked
\r
918 XPD EQUR A1 ; ditto
\r
922 DC.B '(FIND' ; '(FIND)'
\r
924 DC.L DIGIT-6-NATWID
\r
925 PFIND DC.L *+NATWID
\r
926 MOVE.L PD(PSP),XPD ; Start in on the vocabulary (NFA).
\r
927 PFNDLP MOVE.L PA0(PSP),YPA0 ; Point to the name to check against.
\r
928 MOVE.B (XPD)+,D1 ; get dict name length byte
\r
929 MOVE.B D1,D0 ; Save it in case it matches.
\r
931 CMP.B (YPA0)+,D1 ; Compare lengths
\r
933 PFNDBR MOVE.B (XPD)+,D1 ; Is high bit of character in dictionary entry set?
\r
935 AND.B #$7F,D1 ; Clear high bit in char from dictionary.
\r
936 CMP.B (YPA0)+,D1 ; Compare "last" characters.
\r
937 BEQ.S PFOUND ; Matches even if dictionary actual length is shorter.
\r
938 PFNDLN MOVE.L (XPD)+,D0 ; Get previous link in vocabulary. (Note flag entry to switch vocabularies by.)
\r
939 MOVE.L D0,XPD ; On 68K, flags not in effect for MOVEA, TST not available, and this is what we wanted.
\r
940 BNE.S PFNDLP ; Continue if link not=0
\r
943 LEA NATWID(PSP),PSP ; Return only false flag.
\r
947 PFNDCH CMP.B (YPA0)+,D1 ; Compare characters.
\r
950 PFNDSC MOVE.B (XPD)+,D1 ; scan forward to end of this name in dictionary
\r
956 PFOUND LEA 2*NATWID(XPD),XPD ; point to parameter field
\r
957 MOVE.L XPD,NATWID(PSP)
\r
958 CLR.L D1 ; make sure count is valid
\r
961 MOVEQ #1,D1 ; set a true flag
\r
965 * ######>> screen 20 <<
\r
967 * ( buffer ch --- buffer symboloffset delimiteroffset scancount )
\r
968 * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
\r
969 * ( buffer ch --- buffer nuloffset onepast scancount )
\r
970 * Scan buffer for a symbol delimited by ch or ASCII NUL,
\r
971 * return the length of the buffer region scanned,
\r
972 * the offset to the trailing delimiter,
\r
973 * and the offset of the first character of the symbol.
\r
974 * Leave the buffer on the stack.
\r
975 * Scancount is also offset to first character not yet looked at.
\r
976 * If no symbol in buffer, scancount and symboloffset point to NUL
\r
977 * and delimiteroffset points one beyond for some reason.
\r
978 * On trailing NUL, delimiteroffset == scancount.
\r
979 * (Buffer is the address of the buffer array to scan.)
\r
980 * (This is a bit too tricky, really.)
\r
982 * FC means offset (bytes) to First Character of next word
\r
983 * EW " " to End of Word
\r
984 * NC " " to Next Character to start next enclose at
\r
987 DC.B 'ENCLOS' ; 'ENCLOSE'
\r
989 DC.L PFIND-7-NATWID
\r
990 ENCLOS DC.L *+NATWID
\r
991 MOVE.B NATWID-1(PSP),D0 ; Delimiter character to match against in D0.
\r
992 MOVE.L NATWID(PSP),A0 ; Buffer to scan in.
\r
993 CLR.L D1 ; Initialize offset. (No particular limit on Buffer width.)
\r
994 * Scan to a non-delimiter or a NUL
\r
995 ENCDEL TST.B (A0,D1.W) ; NUL ?
\r
997 CMP.B (A0,D1.W),D0 ; Delimiter?
\r
999 ADDQ.L #1,D1 ; count character
\r
1001 * Found first character. Save the offset.
\r
1002 ENC1ST MOVE.L D1,(PSP) ; Found first non-delimiter character -- store the count.
\r
1003 * Scan to a delimiter or a NUL
\r
1004 ENCSYM TST.B (A0,D1.W) ; NUL ?
\r
1006 CMP.B (A0,D1.W),D0 ; delimiter?
\r
1010 * Found end of symbol. Push offset to delimiter found.
\r
1011 ENCEND MOVE.L D1,-(PSP) ; Offset to seen delimiter.
\r
1012 * Advance and push address of next character to check.
\r
1013 ADDQ.L #1,D1 ; one past
\r
1016 * Found NUL before non-delimiter, therefore there is no word
\r
1017 ENCNUL MOVE.L D1,(PSP) ; offset to NUL.
\r
1018 ADDQ.L #1,D1 ; Point after NUL to allow (FIND) to match it.
\r
1019 MOVE.L D1,-(PSP) ;
\r
1020 SUBQ.L #1,D1 ; Next is not passed NUL.
\r
1021 MOVE.L D1,-(PSP) ; Stealing code will save only one byte.
\r
1023 * Found NUL following the word instead of delimiter.
\r
1025 MOVE.L D1,-(PSP) ; Save offset to first after symbol (NUL)
\r
1026 MOVE.L D1,-(PSP) ; and count scanned.
\r
1031 * ######>> screen 21 <<
\r
1032 * The next 4 words call system dependant I/O routines
\r
1033 * which are listed after word "-->" ( label: "arrow" )
\r
1034 * in the dictionary.
\r
1038 * Write c to the output device (screen or printer).
\r
1039 ******* Need to write this for the ST ROM BIOS.
\r
1040 ******* Probably want to go ahead and define PEMIT, PKEY, PQTER, and PCR.
\r
1041 ******* Also might want to tune UORIG variable sizes.
\r
1042 ******* Need to find a way to set default operand size to Long.
\r
1043 * ROM Uses the ECB device number at address $6F,
\r
1044 * -2 is printer, 0 is screen.
\r
1048 DC.B 'EMI' ; 'EMIT'
\r
1050 DC.L ENCLOS-8-NATWID
\r
1051 EMIT DC.L *+NATWID
\r
1053 BSR.W PEMIT ; PEMIT expects the character in D1.
\r
1054 ADDQ.L #1,XOUT-UORIG(UP) ; Bump the output count.
\r
1060 * Wait for a key from the keyboard.
\r
1061 * If the key is BREAK, set the high byte (result $FF03).
\r
1066 DC.L EMIT-5-NATWID
\r
1068 BSR.W PKEY ; PKEY leaves the scancode|key/break in D1.
\r
1069 AND.L #$000000FF,D1
\r
1075 * Scan keyboard, but do not wait.
\r
1076 * Return 0 if no key,
\r
1077 * BREAK ($ff03) if BREAK is pressed,
\r
1078 * or key currently pressed.
\r
1081 DC.B '?TERMINA' ; '?TERMINAL'
\r
1084 QTERM DC.L *+NATWID
\r
1085 BSR.W PQTER ; PQTER leaves the flag/key in D1.
\r
1091 * EMIT a Carriage Return (ASCII CR).
\r
1097 DC.L QTERM-10-NATWID
\r
1099 BSR.W PCR ; Nothing really to do here.
\r
1102 * ######>> screen 22 <<
\r
1104 * ( source target count --- )
\r
1105 * Copy/move count bytes from source to target.
\r
1106 * Moves ascending addresses,
\r
1107 * so that overlapping only works if the source is above the destination.
\r
1108 * CMOVE provides a nice testbed for the intersection between clever and real.
\r
1109 * It also raises questions about why one might want to move all of memory.
\r
1110 * The 68000 DBF instruction only does up to 2^16 moves, which is probably a reasonable limit;
\r
1111 * but, rather than answer that question and/or the logic of split count, use a straight count.
\r
1114 DC.B 'CMOV' ; 'CMOVE' : source, destination, count
\r
1117 CMOVE DC.L *+NATWID
\r
1118 MOVEM.L (PSP)+,D1/A0/A1 ; No effect in flags.
\r
1119 TST.L D1 ; Don't let zero count equal 2^32.
\r
1120 *NOT BEQ.W NEXT ; Stack clean.
\r
1121 BEQ.S CMOVEX ; Stack clean.
\r
1122 CMOVEL MOVE.B (A1)+,(A0)+
\r
1127 ** One possible way to use DBcc (untested):
\r
1128 * MOVEM.L (PSP)+,D1/A0/A1 ; No effect in flags.
\r
1129 * TST.L D1 ; Don't let zero count equal 2^32.
\r
1130 * BEQ.L CMOVEX ; Stack clean.
\r
1131 * SUBQ.W #1,D1 ; Adjust for DBcc
\r
1132 *CMOVEL MOVE.B (A1)+,(A0)+
\r
1134 * SUB.L #$10000,D1
\r
1138 * ( source target count --- )
\r
1139 * Copy/move count bytes from source to target.
\r
1140 * Moves descending addresses,
\r
1141 * so that overlapping does work if the source is below the destination.
\r
1142 * And, conversely, does not work if the source is above the destination.
\r
1143 * Not in fig, provided here for aligning header names in CREATE.
\r
1147 DC.B 'CMOVE' ; 'CMOVED' : source, destination, count
\r
1149 DC.L CMOVE-6-NATWID
\r
1150 CMOVD DC.L *+NATWID
\r
1151 MOVEM.L (PSP)+,D1/A0/A1 ; No effect in flags.
\r
1152 TST.L D1 ; Don't let zero count equal 2^32.
\r
1153 *NOT BEQ.W NEXT ; Stack clean.
\r
1154 BEQ.S CMOVDX ; Stack clean.
\r
1155 LEA (A1,D1.L),A1 ; Point to (one past) the ends.
\r
1157 CMOVDL MOVE.B -(A1),-(A0)
\r
1161 * Could use MOVE.B (A1,D0.L),(A0,D0.L), too, but that would take extra cycles.
\r
1163 * ######>> screen 23 <<
\r
1165 * ( u1 u2 --- ud )
\r
1166 * Multiplies the top two unsigned integers,
\r
1167 * yielding a double integer product.
\r
1168 * Word at a time, but significantly faster than bit-at-a-time.
\r
1174 DC.L CMOVD-7-NATWID
\r
1175 USTAR DC.L *+NATWID
\r
1176 MOVEM.W (PSP),D0/D1/D2/D3 ; MOVEM is a cheap way to split the low and high words.
\r
1177 MULU.W D3,D1 ; U2 low by U1 low, and it's in place
\r
1178 MULU.W D2,D0 ; U2 high by U1 high, and it's in place
\r
1179 MULU.W NATWID/2(PSP),D2 ; U1 high by U2 low
\r
1180 MULU.W (PSP),D3 ; U1 low by U2 high
\r
1181 ADD.L D3,D2 ; sum of inner products
\r
1182 CLR.L D3 ; X-carry is not affected
\r
1183 ADDX.L D3,D3 ; grab the X-carry (no ADDX #0!)
\r
1184 SWAP D3 ; move the carry into place
\r
1185 SWAP D2 ; fast 16 bit rotate
\r
1186 MOVE.W D2,D3 ; high half of inner product, carry in place
\r
1187 AND.L #$FFFF0000,D2 ; low half of inner product
\r
1189 ADDX.L D3,D0 ; along with both carries!
\r
1190 MOVEM.L D0/D1,(PSP) ; stack is as we want it.
\r
1194 * ######>> screen 24 <<
\r
1196 * ( ud u --- uremainder uquotient )
\r
1197 * Divides the top unsigned integer
\r
1198 * into the second and third words on the stack
\r
1199 * as a single unsigned double integer,
\r
1200 * leaving the remainder and quotient (quotient on top)
\r
1201 * as unsigned integers.
\r
1203 * The reason for this oddity is that U/ was intended to be the inverse of U* :
\r
1204 * in other words,
\r
1205 * U/ can only divide without overflow if the dividend is the result of
\r
1206 * the divisor multiplied by the quotient using U* ,
\r
1207 * with an added constant less than the divisor (the remainder portion).
\r
1209 * This is particularly useful in columnar division,
\r
1210 * when the divisor fits within the defined column:
\r
1212 * The smaller the divisor, the more likely dropping the high word
\r
1213 * of the quotient loses significant bits. See M/MOD .
\r
1215 * An example of a dividend/divisor pair that would not work:
\r
1216 * HEX 200000000 2 U/
\r
1217 * -- The largest multiple of 2 that U* could produce in a 32-bit environment would be
\r
1219 * Thus, HEX 1FFFFFFFF would be the maximum 64-bit number
\r
1220 * that U/ would divide by 2 without overflow.
\r
1222 * Note (from M/MOD) that U/ can be chained, as long as the divisor is single-width.
\r
1224 * For a library routine, I would probably want to run-time optimize the divide,
\r
1225 * following four paths:
\r
1226 * If divisor is zero, (1) give saturation result of max quotient, max remainder --
\r
1227 * else if divisor fits in 16 bits,
\r
1228 * if dividend fits in 16 bits, (2) use native DIVU --
\r
1229 * else (3) use chained native DIVU (can be one less than full divide);
\r
1230 * else, (4) for each 16-bit column,
\r
1231 * use native DIVU to guess high word of quotient
\r
1232 * multiply and subtract intermediate product
\r
1233 * if too guess too large, decrement guess and add divisor to get remainder
\r
1234 * shift to the next right column
\r
1235 * But light testing would not be sufficient.
\r
1236 * Each path would need to be tested against its next more optimal path.
\r
1237 * And the resulting routine could be full M/MOD, if paths 3 and 4 are fully worked out.
\r
1239 * For now, for the fig model --
\r
1245 DC.L USTAR-3-NATWID
\r
1248 MOVEM.L (PSP),D0/D1/D2 ; divisor in D0
\r
1249 TST.L D0 ; divisor 0?
\r
1250 BEQ.S USL0 ; dodge divide-by-zero exception
\r
1251 CMP.L #$10000,D0 ; 16-bit divisor?
\r
1252 BHS.S USLD32 ; no, can't use the easy way
\r
1253 TST.L D1 ; dividend greater than 32-bit?
\r
1254 BNE.S USLH64 ; handle the high word
\r
1255 DIVU.W D0,D2 ; result remainder in high 16 bits ; about ~140
\r
1256 MOVE.L D2,D1 ; Move the results into place.
\r
1258 AND.L #$FFFF,D1 ; only the remainder
\r
1259 AND.L #$FFFF,D2 ; only the quotient
\r
1263 BRA.S BSLENT ; bail for now
\r
1264 USL0 MOVE.L D2,D1 ; dividend low word as remainder
\r
1265 MOVEQ.L #-1,D2 ; saturated quotient
\r
1275 DC.L USLASH-3-NATWID
\r
1276 * Using the bit divide to reduce testing burden, working in registers.
\r
1279 MOVEM.L (PSP),D0/D1/D2 ; D1:D2 by D0 (40~ ignore attempts to count cycles)
\r
1281 MOVE.W #32,D3 ; bit ct for DBcc (8~)
\r
1283 CMP.L D0,D1 ; divisor (6~)
\r
1284 BHS.S BSLSUB (8/10~)
\r
1285 AND #~F_EXT,CCR ; X-carry clear (20~)
\r
1286 BRA.S BSLBIT (10~)
\r
1289 OR #F_EXT,CCR ; quotient, (X-carry set) (20~)
\r
1291 ROXL.L #1,D2 ; save it (8~)
\r
1292 DBF D3,BSLMOR ; more bits? Don't mess with CCR ((12/14)/10~)
\r
1294 LEA NATWID(PSP),PSP (8~)
\r
1295 MOVE.L D1,NATWID(PSP) (16~)
\r
1296 MOVE.L D2,(PSP) (12~)
\r
1299 ROXL.L #1,D1 ; remainder (8~)
\r
1300 BCC.S BSLDIV (8/10~)
\r
1301 BRA.S BSLSUB (10~) (~90*32=~2880+entry+exit, about 800 μS at 4 MHz)
\r
1303 * The following is not yet functional, only here to help me remember:
\r
1304 * cUSLASH DC.L *+NATWID
\r
1305 * MOVE.W (PSP)+,D0
\r
1307 * MOVE.W (PSP)+,D0 ; stack pre-adjusted
\r
1308 * BNE USL16 ; avoid DIV by 0 exception
\r
1309 * MOVE.L #-1,(PSP) ; quotient too large
\r
1310 * MOVE.L #-1,NATWID(PSP) ; remainder too large
\r
1313 * MOVE.W (PSP),D1 ; start with highest half
\r
1314 * DIVU.W D0,D1 ; can't overflow
\r
1315 * MOVE.W D1,(PSP) ; remainder in high half
\r
1316 * MOVE.W NATWID/2(PSP),D1 ; 2nd half
\r
1318 * MOVE.W D1,NATWID/2(PSP)
\r
1319 * MOVE.W NATWID(PSP),D1 ; 3rd half
\r
1321 * MOVE.W D1,NATWID(PSP)
\r
1322 * MOVE.W 3*NATWID/2(PSP),D1 ; lowest half
\r
1323 * DIVU.W D0,D1 ; (140~) (~140*4=560+smallstuff)
\r
1324 * MOVE.W D1,3*NATWID/2(PSP)
\r
1330 * Following the 6809 code, working on the stack.
\r
1334 * MOVE.W #33,D3 ; bit ct
\r
1335 * MOVE.L NATWID(PSP),D2 ; dividend
\r
1337 * CMP.L (PSP),D2 ; divisor
\r
1339 * AND #~F_EXT,CCR ; X-carry clear
\r
1343 * OR #F_EXT,CCR ; quotient, (X-carry set)
\r
1345 * ROXL.W 2*NATWID+NATWID/2(PSP) ; save it
\r
1346 * ROXL.W 2*NATWID(PSP) ; in memory has only 16-bit by 1 bit form
\r
1347 * SUBQ.W #1,D3 ; more bits?
\r
1349 * ROXL.L D2 ; remainder
\r
1353 * LEA NATWID(PSP),PSP
\r
1354 * MOVE.L NATWID(PSP),D1
\r
1355 * MOVEM.L D1/D2,(PSP)
\r
1360 * ######>> screen 25 <<
\r
1363 * Bitwise and the top two integers.
\r
1368 * DC.L I-2-NATWID ; ***** debug link *****
\r
1369 DC.L BSLASH-3-NATWID ; correct link
\r
1377 * Bitwise or the top two integers.
\r
1391 * Bitwise exclusive or the top two integers.
\r
1403 * for CPUs that don't like odd addresses.
\r
1404 * Test whether top of stack is odd, push flag: 0 => even, 1 => odd.
\r
1409 DC.B '?OD' ; '?ODD'
\r
1412 QODD DC.L *+NATWID
\r
1413 MOVE.L (PSP),-(PSP)
\r
1418 **NOT BRA.W PUSHD0 ; Save the test result as the flag.
\r
1419 * MOVE.L D0,-(PSP)
\r
1423 * Calculate the bump adjustment necessary for odd or even alignment.
\r
1424 * Odd for odd alignment, even for even.
\r
1425 * bump is 0 (no adjustment) or 1 (adjustment needed)
\r
1426 * ( n alignment --- n bump )
\r
1430 DC.B 'ALIGN-BUM' ; 'ALIGN-BUMP'
\r
1432 DC.L QODD-5-NATWID
\r
1433 ALGNB DC.L *+NATWID
\r
1435 AND.L #1,D0 ; Even or odd alignment?
\r
1436 MOVE.L NATWID(PSP),D1
\r
1437 AND.W #1,D1 ; Even address or odd?
\r
1438 EOR.W D0,D1 ; odd on even or even on odd is 1, else 0
\r
1443 ** for CPUs that don't like odd addresses.
\r
1444 ** Floor top of stack even.
\r
1449 * DC.B 'FLOOR' ; 'FLOOR2'
\r
1451 * DC.L ALGNB-11-NATWID
\r
1452 * FLOOR2 DC.L *+NATWID
\r
1453 * AND.W #$FFFE,NATWID/2(PSP)
\r
1457 ** for CPUs that don't like odd addresses.
\r
1458 ** Make top of stack even by adjusting it up.
\r
1463 * DC.B 'CIELING' ; 'CIELING2'
\r
1465 * DC.L FLOOR2-7-NATWID
\r
1466 * CIEL2 DC.L *+NATWID
\r
1467 * BCLR #0,NATWID-1(PSP)
\r
1472 * ######>> screen 26 <<
\r
1474 * ( anything --- anything adr )
\r
1475 * Fetch the parameter stack pointer (before it is pushed).
\r
1476 * This points at whatever was on the top of stack before.
\r
1481 DC.L ALGNB-11-NATWID
\r
1482 SPAT DC.L *+NATWID
\r
1487 * ( whatever --- nothing )
\r
1488 * Initialize the parameter stack pointer from the USER variable S0.
\r
1489 * Effectively clears the stack.
\r
1494 DC.L SPAT-4-NATWID
\r
1495 SPSTOR DC.L *+NATWID
\r
1496 MOVE.L XSPZER-UORIG(UP),PSP
\r
1502 * ( whatever *** nothing )
\r
1503 * Initialize the return stack pointer from the initialization table
\r
1504 * instead of the user variable R0, for some reason.
\r
1505 * Quite possibly, this should be from R0.
\r
1506 * Effectively aborts all in-process definitions, except the active one.
\r
1507 * An emergency measure, to be sure.
\r
1508 * The routine that calls this must never execute a return.
\r
1509 * So this should never be executed from the terminal, I guess.
\r
1510 * This is another that should be compile-time only, and in a separate vocabulary.
\r
1515 DC.L SPSTOR-4-NATWID
\r
1516 RPSTOR DC.L *+NATWID
\r
1517 MOVE.L RINIT(PC),RP
\r
1518 BRA.W NEXT ; This is correct here.
\r
1522 * Pop IP from return stack (return from high-level definition).
\r
1523 * Can be used in a screen to force interpretion to terminate.
\r
1524 * Must not be executed when temporaries are saved on top of the return stack.
\r
1530 DC.L RPSTOR-4-NATWID
\r
1531 SEMIS DC.L *+NATWID
\r
1532 MOVEM.L (RP)+,A0/IP ; A0 will be TOS
\r
1533 JMP (A0) ; return to NEXT
\r
1538 * ######>> screen 27 <<
\r
1540 * ( limit index *** index index )
\r
1541 * Force the terminating condition for the innermost loop by
\r
1542 * copying its index to its limit.
\r
1543 * Termination is postponed until the next
\r
1544 * LOOP or +LOOP instruction is executed.
\r
1545 * The index remains available for use until
\r
1546 * the LOOP or +LOOP instruction is encountered.
\r
1547 * Note that the assumption is that the current count is the correct count
\r
1548 * to end at, rather than pushing the count to the final count.
\r
1551 DC.B 'LEAV' ; 'LEAVE'
\r
1553 DC.L SEMIS-3-NATWID
\r
1554 LEAVE DC.L *+NATWID
\r
1555 MOVE.L LUPCT(RP),LUPLIM(RP) ; Return address hidden in offset EQUs.
\r
1558 * Notes for loop counter and limit in registers:
\r
1559 * MOVE.L LUPCT,LUPLIM ; No return address to dodge.
\r
1565 * Move top of parameter stack to top of return stack.
\r
1571 DC.L LEAVE-6-NATWID
\r
1574 MOVE.L (PSP)+,(RP)
\r
1580 * Move top of return stack to top of parameter stack.
\r
1587 FROMR DC.L *+NATWID
\r
1588 * MOVEM.L (RP)+,A0/A1 ; A0 will be TOS
\r
1589 * MOVE.L A1,-(PSP)
\r
1592 MOVE.L (RP)+,-(PSP)
\r
1598 * Copy the top of return stack to top of parameter stack.
\r
1599 * This would NOT be a synonym for I if we were keeping the control variables in registers.
\r
1603 DC.L FROMR-3-NATWID
\r
1604 R DC.L I+NATWID ; synonym
\r
1608 * ######>> screen 28 <<
\r
1612 * Not part of fig model.
\r
1618 LNOT DC.L *+NATWID
\r
1623 * Logically invert top of stack;
\r
1624 * or flag true if top is zero, otherwise false.
\r
1630 DC.L LNOT-4-NATWID
\r
1631 ZEQU DC.L *+NATWID
\r
1634 SEQ D0 ; faster than branch
\r
1635 ZEQMSK AND.W #1,D0
\r
1639 * Option using branch and increment:
\r
1640 * ZEQU DC.L *+NATWID
\r
1644 * MOVEQ #1,D0 ; ADDQ.W would work. ADDQ.L takes 8 cycles instead of 4.
\r
1645 * ZEQUS MOVE.L D0,(PSP)
\r
1648 * If TRUE were -1:
\r
1649 * ZEQU DC.L *+NATWID
\r
1659 * Flag true if top is negative (MSbit set), otherwise false.
\r
1665 DC.L ZEQU-3-NATWID
\r
1666 ZLESS DC.L *+NATWID
\r
1670 * BRA.S ZEQMSK ; don't trade a few cycles for several bytes
\r
1671 * AND.W #1,D0 ; flatten it, instead.
\r
1672 AND.L #1,D0 ; flatten it, instead.
\r
1676 * ######>> screen 29 <<
\r
1678 * ( n1 n2 --- n1+n2 )
\r
1679 * Add top two words.
\r
1683 DC.L ZLESS-3-NATWID
\r
1684 PLUS DC.L *+NATWID
\r
1685 MOVE.L (PSP)+,D0 ; Addition is commutative.
\r
1686 ADD.L D0,(PSP) ; This order will not work for subtraction.
\r
1687 RTS ; Remember, my son --
\r
1688 * ; the left hand operator is one deeper in the stack,
\r
1689 * ; and it is the target.
\r
1692 * ( d1 d2 --- d1+d2 )
\r
1693 * Add top two double integers.
\r
1699 DC.L PLUS-2-NATWID
\r
1700 DPLUS DC.L *+NATWID
\r
1701 MOVEM.L (PSP)+,D0/D1/D2/D3 ; ADDX memory requires too much setup
\r
1702 ADD.L D1,D3 ; This order will work for subtraction, too.
\r
1704 MOVEM.L D2/D3,-(PSP)
\r
1709 * Negate (two's complement) top of stack.
\r
1712 DC.B 'MINU' ; 'MINUS'
\r
1714 DC.L DPLUS-3-NATWID
\r
1715 MINUS DC.L *+NATWID
\r
1721 * Negate (two's complement) top two words on stack as a double integer.
\r
1725 DC.B 'DMINU' ; 'DMINUS'
\r
1727 DC.L MINUS-6-NATWID
\r
1728 DMINUS DC.L *+NATWID
\r
1733 * ######>> screen 30 <<
\r
1735 * ( n1 n2 --- n1 n2 n1 )
\r
1736 * Push a copy of the second word on stack.
\r
1740 DC.B 'OVE' ; 'OVER'
\r
1742 DC.L DMINUS-7-NATWID
\r
1743 OVER DC.L *+NATWID
\r
1744 MOVE.L NATWID(PSP),-(PSP)
\r
1749 * Discard the top word on stack.
\r
1753 DC.B 'DRO' ; 'DROP'
\r
1755 DC.L OVER-5-NATWID
\r
1756 DROP DC.L *+NATWID
\r
1757 LEA NATWID(PSP),PSP
\r
1761 * ( n1 n2 --- n2 n1 )
\r
1762 * Swap the top two words on stack.
\r
1766 DC.B 'SWA' ; 'SWAP'
\r
1768 DC.L DROP-5-NATWID
\r
1769 SWAP DC.L *+NATWID
\r
1770 MOVEM.L (PSP),D0/D1
\r
1772 MOVEM.L D0/D1,(PSP)
\r
1775 * MOVE.L NATWID(PSP),(PSP)
\r
1776 * MOVE.L D0,NATWID(POS)
\r
1780 * ( n1 --- n1 n1 )
\r
1781 * Push a copy of the top word on stack.
\r
1786 DC.L SWAP-5-NATWID
\r
1788 MOVE.L (PSP),-(PSP)
\r
1791 * ######>> screen 31 <<
\r
1794 * Add the second word on stack to the word at the adr on top of stack.
\r
1801 PSTORE DC.L *+NATWID
\r
1802 MOVEM.L (PSP)+,D0/A0
\r
1809 * Exclusive or byte at adr with low byte of top word.
\r
1813 DC.B 'TOGGL' ; 'TOGGLE'
\r
1815 DC.L PSTORE-3-NATWID
\r
1816 TOGGLE DC.L *+NATWID
\r
1817 MOVEM.L (PSP)+,D0/A0
\r
1820 * Using the model code would be less likely to introduce bugs,
\r
1821 * but that would sort-of defeat my purposes here.
\r
1822 * Anyway, I can imitate known good bif-6809 code
\r
1823 * and it's fewer bytes and much faster code this way.
\r
1825 * DC.L DOCOL,OVER,CAT,XOR,SWAP,CSTORE
\r
1828 * ######>> screen 32 <<
\r
1831 * Replace address on stack with the word at the address.
\r
1835 DC.L TOGGLE-7-NATWID
\r
1843 * Replace address on top of stack with the byte at the address.
\r
1844 * High byte of result is clear.
\r
1845 * Unfortunate naming. 8 bits doth not a character code point make.
\r
1853 MOVE.L (PSP),A0 ; Memory indirect is 68020 and after, but not CPU32.
\r
1854 CLR.L D0 ; Reduce bus activity and un-aligned access.
\r
1861 * MOVE.B (A0),NATWID-1(PSP)
\r
1863 * But optimization is not my primary purpose here,
\r
1864 * so I'm not going to count bytes and cycles and compare.
\r
1867 * Yeah, we're gonna need this.
\r
1868 * Replace address on top of stack with the 16-bit half-word at the address.
\r
1869 * High half-word of result is clear.
\r
1877 MOVE.L (PSP),A0 ; Memory indirect is 68020 and after, but not CPU32.
\r
1878 CLR.L D0 ; Reduce bus activity.
\r
1882 * See alternate approach for CAT
\r
1886 * Store second word on stack at address on top of stack.
\r
1891 STORE DC.L *+NATWID
\r
1892 MOVEM.L (PSP)+,D0/A0
\r
1897 * MOVE.L (PSP)+,A0
\r
1898 * MOVE.L (PSP)+,(A0)
\r
1903 * Store low byte of second word on stack at address on top of stack.
\r
1904 * High byte is ignored.
\r
1905 * Unfortunate naming. 8 bits doth not a character code point make.
\r
1911 DC.L STORE-2-NATWID
\r
1912 CSTORE DC.L *+NATWID
\r
1913 MOVEM.L (PSP)+,D0/A0
\r
1919 * Yeah, we're gonna need this.
\r
1920 * Store low 16-bit half-word of second word on stack at address on top of stack.
\r
1921 * High half-word is ignored.
\r
1927 DC.L CSTORE-3-NATWID
\r
1928 HSTORE DC.L *+NATWID
\r
1929 MOVEM.L (PSP)+,D0/A0
\r
1936 * ######>> screen 33 <<
\r
1939 * { : name sundry-activities ; } typical input
\r
1940 * ( Termination of recursive definition, or eating our own dogfood --
\r
1941 * lots of forward references here.)
\r
1942 * If executing (not compiling),
\r
1943 * record the data stack mark in CSP,
\r
1944 * Set the CONTEXT vocabulary to CURRENT,
\r
1945 * CREATE a header,
\r
1946 * set state to compile,
\r
1947 * and compile the call to the trailing native CPU machine code DOCOL.
\r
1949 * This would not be hard to flatten to native code,
\r
1950 * especially in the 6809 or 68000.
\r
1951 * But that's not the purpose of a model.
\r
1952 * Except that's the purpose of this model, now.
\r
1953 * So we will start flattening here, to see how it goes.
\r
1954 * First need to flatten certain of the called words.
\r
1956 DC.B $C1 ; : immediate
\r
1958 DC.L HSTORE-3-NATWID
\r
1959 COLON DC.L DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
\r
1963 * What was I thinking?
\r
1964 *COLON DC.L *+NATWID
\r
1965 * BSR.W QEXEC+NATWID
\r
1966 ** BSR.W SCSP+NATWID
\r
1967 * MOVE.L PSP,XCSP-UORIG(UP) ; SCSP
\r
1968 * MOVE.L XCURR-UORIG(UP),XCONT-UORIG(UP)
\r
1969 * BSR.W CREATE+NATWID
\r
1970 * BSR.W RBRAK+NATWID
\r
1971 * MOVE.L #STCOMP,XSTATE-UORIG(UP) ; RBRAK
\r
1972 ** NOW WHAT? Should work.
\r
1975 * Here is the IP pusher for allowing
\r
1976 * nested words in the virtual machine:
\r
1977 * ( ;S is the equivalent un-nester )
\r
1980 * Characteristic of a colon (:) definition.
\r
1981 * Begins execution of a high-level definition,
\r
1982 * i. e., nests the definition and begins processing icodes.
\r
1983 * Mechanically, it pushes the IP
\r
1984 * and loads the Parameter Field Address of the definition which
\r
1985 * called it into the IP.
\r
1986 DOCOL MOVE.L (RP),A0
\r
1989 JMP (A0) ; Return to NEXT.
\r
1993 * { : name sundry-activities ; } typical input
\r
1994 * ERROR check data stack against mark in CSP,
\r
1996 * unSMUDGE LATEST definition,
\r
1997 * and set state to interpretation.
\r
1999 DC.B $C1 ; ; imnediate code
\r
2001 DC.L COLON-2-NATWID
\r
2002 SEMI DC.L DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
\r
2005 * ######>> screen 34 <<
\r
2008 * { value CONSTANT name } typical input
\r
2009 * CREATE a header,
\r
2011 * compile the constant value,
\r
2012 * and compile the call to the trailing native CPU machine code DOCON.
\r
2016 DC.B 'CONSTAN' ; 'CONSTANT'
\r
2018 DC.L SEMI-2-NATWID
\r
2019 CON DC.L DOCOL,CREATE,SMUDGE,COMMA,PSCODE
\r
2021 * Characteristic of a CONSTANT.
\r
2022 * A CONSTANT simply loads its value from its parameter field
\r
2023 * and pushes it on the stack.
\r
2024 DOCON MOVE.L (W),-(PSP) ; Push the first natural width word of the parameter field.
\r
2027 * Tempting to do a space-saving DOHCON:
\r
2028 * DOHCON CLR.L D0 ; convert to 32-bit
\r
2030 * MOVE.L D0,-(PSP)
\r
2032 * But, as you can see, it'll be a bit slower,
\r
2033 * and it just may not be worth it for the number of times it would be used.
\r
2034 * And there's a bettwer way lurking around the corner.
\r
2038 * { init VARIABLE name } typical input
\r
2039 * Use CONSTANT to CREATE a header and compile the initial value, init,
\r
2040 * then overwrite the characteristic to point to DOVAR.
\r
2044 DC.B 'VARIABL' ; 'VARIABLE'
\r
2047 VAR DC.L DOCOL,CON,PSCODE
\r
2049 * Characteristic of a VARIABLE.
\r
2050 * A VARIABLE pushes its PFA address on the stack.
\r
2051 * The parameter field of a VARIABLE is the actual allocation of the variable,
\r
2052 * so that pushing its address allows its contents to be @ed (fetched).
\r
2053 * Ordinary arrays and strings that do not subscript themselves
\r
2054 * may be allocated by defining a variable
\r
2055 * and immediately ALLOTting the remaining needed space.
\r
2056 * VARIABLES are global to all users,
\r
2057 * and thus should be hidden in resource monitors, but aren't.
\r
2058 DOVAR MOVE.L W,-(PSP) ; Push address of first natural width word of the parameters.
\r
2063 * { uboffset USER name } typical input
\r
2064 * CREATE a header and compile the unsigned byte offset in the per-USER table,
\r
2065 * then overwrite the header with a call to DOUSER.
\r
2066 * The USER is entirely responsible for maintaining allocation!
\r
2067 * (We really need a word that controls allocation of these.)
\r
2071 DC.B 'USE' ; 'USER'
\r
2074 USER DC.L DOCOL,CON,PSCODE
\r
2076 * Characteristic of a per-USER variable.
\r
2077 * USER variables are similiar to VARIABLEs,
\r
2078 * but are allocated (by hand!) in the per-user table.
\r
2079 * A USER variable's parameter field contains its offset in the per-user table.
\r
2080 * DOUSER MOVE.L UP,A0 ; Copy base of per-user/task space.
\r
2081 * ADD.L (W),A0 ; Offset into the table.
\r
2082 * MOVE.L A0,-(PSP)
\r
2084 DOUSER MOVE.L (W),D0 ; Offset into the table.
\r
2089 * Hey, the per-user table can actually be larger than 256 bytes, esp. on the 68000!
\r
2093 * ######>> screen 35 <<
\r
2095 * Some (theoretically) useful constants:
\r
2101 DC.L USER-5-NATWID
\r
2110 DC.L ZERO-2-NATWID
\r
2132 * Useful constant, not in model, needed for abstraction:
\r
2133 * The standard name is CELL, however.
\r
2135 * The byte width of objects on stack.
\r
2139 DC.B 'NATWI' ; 'NATWID'
\r
2141 DC.L THREE-2-NATWID
\r
2143 NATWCV DC.L NATWID
\r
2145 * Not in model, wanted for abstraction:
\r
2146 * Note that this is not defined as an instance of an INCREMENTER here!
\r
2147 * Coded to increment by the exact constant returned by NATWID
\r
2148 * ( n --- n+NATWID )
\r
2152 DC.B 'NAT' ; 'NAT+'
\r
2154 DC.L NATWC-7-NATWID
\r
2155 NATP DC.L *+NATWID
\r
2157 ADD.L NATWCV(PC),D0
\r
2161 * Useful constant, not in model, needed for abstraction:
\r
2162 * ( --- NATWID/2 )
\r
2163 * Half the byte width of objects on stack.
\r
2167 DC.B 'HALFNATWI' ; 'HALFNATWID'
\r
2169 DC.L NATP-5-NATWID
\r
2171 HNATWCV DC.L NATWID/2
\r
2177 * ASCII SPACE character
\r
2183 DC.L HNATWC-11-NATWID
\r
2184 BL DC.L DOCON ; ascii blank
\r
2188 * This really shouldn't be a CONSTANT.
\r
2190 * The base of the disk buffer space.
\r
2193 DC.B 'FIRS' ; 'FIRST'
\r
2198 * FDB MEMEND-528 ; (132 * NBLK)
\r
2201 * This really shouldn't be a CONSTANT.
\r
2203 * The limit of the disk buffer space.
\r
2206 DC.B 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
\r
2208 DC.L FIRST-6-NATWID
\r
2211 * In 6800 model, was
\r
2215 * ( --- sectorsize )
\r
2216 * The size, in bytes, of a buffer control region.
\r
2219 DC.B 'B/CT' ; 'B/CTL' : (bytes/control region)
\r
2221 DC.L LIMIT-6-NATWID
\r
2225 * ( --- sectorsize )
\r
2226 * The size, in bytes, of a buffer.
\r
2229 DC.B 'B/BU' ; 'B/BUF' : (bytes/buffer)
\r
2231 DC.L BCTL-6-NATWID
\r
2234 * Hardcoded in 6800 model:
\r
2238 * ( --- blocksperscreen )
\r
2239 * The size, in blocks, of a screen.
\r
2242 DC.B 'B/SC' ; 'B/SCR' : (blocks/screen)
\r
2244 DC.L BBUF-6-NATWID
\r
2247 BSCR DC.L *+NATWID
\r
2248 MOVE.L #NBLK,-(PSP)
\r
2250 * Hardcoded in 6800 model as:
\r
2252 * blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
\r
2256 * Calculate the address of entry (#n/2) in the boot-up parameter table.
\r
2257 * (Adds the base of the boot-up table to n.)
\r
2260 DC.B '+ORIGI' ; '+ORIGIN'
\r
2262 DC.L BSCR-6-NATWID
\r
2263 PORIG DC.L DOCOL,LIT,ORIG,PLUS
\r
2266 * ######>> screen 36 <<
\r
2269 * This is the per-task variable recording the initial parameter stack pointer.
\r
2275 DC.L PORIG-8-NATWID
\r
2276 *SZERO DC.L DOUSER
\r
2277 * DC.L XSPZER-UORIG
\r
2278 SZERO DC.L *+NATWID
\r
2279 LEA XSPZER-UORIG(UP),A0
\r
2280 MOVE.L A0,-(PSP) ; Note that BRA.W takes 32 bits to encode, so saves no space.
\r
2285 * This is the per-task variable recording the initial return stack pointer.
\r
2291 DC.L SZERO-3-NATWID
\r
2292 *RZERO DC.L DOUSER
\r
2293 * DC.L XRZERO-UORIG
\r
2294 RZERO DC.L *+NATWID
\r
2295 LEA XRZERO-UORIG(UP),A0
\r
2296 MOVE.L A0,-(PSP) ; Note that BRA.W takes 32 bits to encode, so saves no space.
\r
2301 * Terminal Input Buffer address.
\r
2302 * Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
\r
2307 DC.L RZERO-3-NATWID
\r
2312 * ( --- maxnamewidth )
\r
2313 * This is the maximum width to which symbol names will be recorded.
\r
2316 DC.B 'WIDT' ; 'WIDTH'
\r
2324 * Availability of error messages on disk.
\r
2325 * Contains 1 if messages available,
\r
2327 * -1 if a disk error has occurred.
\r
2330 DC.B 'WARNIN' ; 'WARNING'
\r
2332 DC.L WIDTH-6-NATWID
\r
2333 *WARN DC.L DOUSER ; Must be callable from low-level.
\r
2334 * DC.L XWARN-UORIG
\r
2335 WARN DC.L *+NATWID
\r
2336 LEA XWARN-UORIG(UP),A0
\r
2337 MOVE.L A0,-(PSP) ; Note that BRA.W takes 32 bits to encode, so saves no space.
\r
2342 * Boundary for FORGET.
\r
2345 DC.B 'FENC' ; 'FENCE'
\r
2347 DC.L WARN-8-NATWID
\r
2353 * Dictionary pointer, fetched by HERE.
\r
2357 DC.B 'D' ; 'DP' : points to first free byte at end of dictionary
\r
2359 DC.L FENCE-6-NATWID
\r
2360 DICTPT DC.L DOUSER
\r
2363 * ======>> 68.5 <<
\r
2364 * ( --- vadr ) ******* Need to check what this is!
\r
2365 * Used in maintaining vocabularies.
\r
2366 * I think it points to the current "parent" vocabulary, but I'm not sure.
\r
2367 * Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
\r
2371 DC.B 'VOC-LIN' ; 'VOC-LINK'
\r
2373 DC.L DICTPT-3-NATWID
\r
2374 VOCLIN DC.L DOUSER
\r
2379 * Disk block being interpreted.
\r
2380 * Zero refers to terminal.
\r
2381 * ******** Should be made a 64 bit user variable! ********
\r
2382 * But the base system needs to have full 64 bit support, div and mul, etc.
\r
2383 * before we can do that.
\r
2388 DC.L VOCLIN-9-NATWID
\r
2394 * Input buffer offset/cursor.
\r
2398 DC.B 'I' ; 'IN' : scan pointer for input line buffer
\r
2406 * Output buffer offset/cursor.
\r
2417 * Screen currently being edited, once we have an editor running.
\r
2425 * ######>> screen 37 <<
\r
2429 * Sector offset for LOADing screens,
\r
2430 * set by DRIVE to make a new drive the default.
\r
2431 * This should also be 64 bit, if we had full 64-bit math.
\r
2435 DC.B 'OFFSE' ; 'OFFSET'
\r
2438 *OFSET DC.L DOUSER
\r
2439 * DC.L XOFSET-UORIG
\r
2440 OFSET DC.L *+NATWID
\r
2441 LEA XOFSET-UORIG(UP),A0
\r
2447 * Current context of interpretation (vocabulary root).
\r
2450 DC.B 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
\r
2452 DC.L OFSET-7-NATWID
\r
2453 CONTXT DC.L DOUSER
\r
2458 * Current context of definition (vocabulary root).
\r
2461 DC.B 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
\r
2463 DC.L CONTXT-8-NATWID
\r
2464 CURENT DC.L DOUSER
\r
2469 * Compiler/interpreter state.
\r
2472 DC.B 'STAT' ; 'STATE' : 1 if compiling, 0 if not
\r
2474 DC.L CURENT-8-NATWID
\r
2480 * Numeric conversion base.
\r
2484 DC.B 'BAS' ; 'BASE' : number base for all input & output
\r
2486 DC.L STATE-6-NATWID
\r
2492 * Decimal point location for output.
\r
2497 DC.L BASE-5-NATWID
\r
2503 * Field width for I/O formatting.
\r
2514 * Compiler stack mark for stack check.
\r
2525 * Editing cursor location.
\r
2537 * Pointer to last HELD character in PAD.
\r
2542 DC.L RNUM-3-NATWID
\r
2546 * ======>> 82.5 <<== SPECIAL
\r
2548 * Line width of active terminal.
\r
2551 DC.B 'COLUMN' ; 'COLUMNS' : line width of terminal
\r
2554 COLUMS DC.L DOUSER
\r
2559 * ######>> screen 38 <<
\r
2561 ** An INCREMENTER probably should not be defined without a defined CONSTANT increment?
\r
2562 ** Ergo, defined in pairs --
\r
2564 ** Make an INCREMENTER compiling word (not in model):
\r
2566 ** { n INCREMENTER name } typical input
\r
2567 ** CREATE a header and compile the increment constant,
\r
2568 ** then overwrite the header with a call to DOINC.
\r
2570 * DC.B 'INCREMENTE' ; 'INCREMENTER'
\r
2572 * DC.L COLUMS-8-NATWID
\r
2573 * INCR DC.L DOCOL,CON,PSCODE
\r
2574 ** ( n --- ninc )
\r
2575 ** Characteristic of an INCREMENTER.
\r
2576 ** This is probably too naive:
\r
2577 * DOINC MOVE.L (W),D0 ; Get the increment,
\r
2578 * ADD.L D0,(PSP) ; and add it.
\r
2580 * Compiling word should check that it is compiling a CONSTANT.
\r
2581 * On the other hand, there are reasons not to:
\r
2590 DC.L COLUMS-8-NATWID
\r
2591 * Using the model keeps things semantically connected for other processors:
\r
2592 ONEP DC.L DOCOL,ONE,PLUS
\r
2594 ** Greedy alternative:
\r
2595 * ONEPG DC.L *+NATWID
\r
2597 * ADD.L ONEV(PC),D0
\r
2600 * Naive alternative:
\r
2601 * ONEPI DC.L DOINC
\r
2603 * Naive alternative:
\r
2604 * ONEP1 DC.L *+NATWID
\r
2605 * ADDQ.L #1,(PSP) ; It's hard to imagine 1+ being other than 1.
\r
2615 DC.L ONEP-3-NATWID
\r
2616 * Using the model keeps things semantically connected for other processors:
\r
2617 TWOP DC.L DOCOL,TWO,PLUS
\r
2619 ** Greedy alternative:
\r
2620 * TWOP DC.L *+NATWID
\r
2622 * ADD.L TWOV(PC),D0
\r
2625 * Naive alternative:
\r
2628 * Naive alternative:
\r
2629 * TWOP DC.L *+NATWID
\r
2630 * ADDQ.L #2,(PSP) ; It's hard to imagine 1+ being other than 2.
\r
2635 * Get the DICTPT allocation, like a USER constant.
\r
2636 * Should check the stack and heap for collision.
\r
2640 DC.B 'HER' ; 'HERE'
\r
2642 DC.L TWOP-3-NATWID
\r
2643 HERE DC.L DOCOL,DICTPT,AT
\r
2648 * Increase/decrease heap (add n to DP),
\r
2649 * Should ERROR check stack/heap.
\r
2652 DC.B 'ALLO' ; 'ALLOT'
\r
2654 DC.L HERE-5-NATWID
\r
2655 ALLOT DC.L DOCOL,DICTPT,PSTORE
\r
2660 * Store word n at DP++,
\r
2661 * Should ERROR check stack/heap.
\r
2663 DC.B $81 ; , (COMMA)
\r
2665 DC.L ALLOT-6-NATWID
\r
2666 COMMA DC.L DOCOL,HERE,STORE,NATWC,ALLOT ; race condition
\r
2668 * COMMA DC.L DOCOL,HERE,STORE,TWO,ALLOT ; The model hard-coded TWO
\r
2672 * Store byte b at DP+,
\r
2673 * Should ERROR check stack/heap.
\r
2674 * Unfortunate naming.
\r
2680 DC.L COMMA-2-NATWID
\r
2681 CCOMM DC.L DOCOL,HERE,CSTORE,ONE,ALLOT ; race condition
\r
2685 * Bump the DICTPT if necessary to odd or even alignment, according to n,
\r
2686 * by compiling in an extra NUL byte.
\r
2687 * Odd n for odd alignment, even n for even.
\r
2690 DC.B 'ALIGN-COMM' ; 'ALIGN-COMMA'
\r
2692 DC.L CCOMM-3-NATWID
\r
2693 ALCOM DC.L DOCOL,HERE,ZERO,ALGNB,ZBRAN
\r
2694 DC.L ALCOMX-*-NATWID
\r
2699 * Not in model, but needed for 32-bit.
\r
2701 * Store half cell h at DP+.
\r
2702 * Should ERROR check stack/heap.
\r
2708 DC.L ALCOM-12-NATWID
\r
2709 HCOMM DC.L DOCOL,HERE,HSTORE,HNATWC,ALLOT ; race condition
\r
2713 * ( n1 n2 --- n1-n2 )
\r
2714 * Subtract top two words.
\r
2718 DC.L HCOMM-3-NATWID
\r
2720 MOVE.L (PSP)+,D0 ; Subtraction is not commutative.
\r
2721 SUB.L D0,(PSP) ; left side operand is the deeper one on the stack.
\r
2723 * SUB DC.L DOCOL,MINUS,PLUS
\r
2724 * DC.L SEMIS ; Costs extra bytes and lots of cycles compared to native code.
\r
2726 * ( d1 d2 --- d1-d2 )
\r
2727 * Subtract top two integers.
\r
2728 * Yes, we do want this in the model.
\r
2735 DSUB DC.L *+NATWID
\r
2736 MOVEM.L (PSP)+,D0/D1/D2/D3 ; ADDX memory operand requires too much setup for just two long words.
\r
2737 SUB.L D1,D3 ; Right order for subtraction.
\r
2739 MOVEM.L D2/D3,-(PSP)
\r
2743 * ( n1 n2 --- n1==n2 )
\r
2744 * Return flag true if n1 and n2 are equal, otherwise false.
\r
2748 DC.L DSUB-3-NATWID
\r
2749 EQUAL DC.L DOCOL,SUB,ZEQU
\r
2753 * ( n1 n2 --- n1<n2 )
\r
2754 * Return flag true if n1 is less than n2, otherwise false.
\r
2759 DC.L EQUAL-2-NATWID
\r
2760 LESS DC.L *+NATWID
\r
2761 CLR.L D2 ; Guess false.
\r
2766 TRUE MOVEQ #1,D2 ; MOVEQ is a little faster than ADDQ.L
\r
2767 LESSST MOVE.L D2,(PSP)
\r
2772 * ( n1 n2 --- n1>n2 )
\r
2773 * Return flag true if n1 is greater than n2, false otherwise.
\r
2777 DC.L LESS-2-NATWID
\r
2778 GREAT DC.L DOCOL,SWAP,LESS
\r
2782 * ( n1 n2 n3 --- n2 n3 n1 )
\r
2783 * Rotate the top three words on stack,
\r
2784 * bringing the third word to the top.
\r
2789 DC.L GREAT-2-NATWID
\r
2791 MOVEM.L (PSP),D0/D1/D2
\r
2792 MOVEM.L D0/D1,NATWID(PSP)
\r
2801 DC.B 'SPAC' ; 'SPACE'
\r
2804 SPACE DC.L DOCOL,BL,EMIT
\r
2808 * ( n0 n1 --- min(n0,n1) )
\r
2809 * Leave the minimum of the top two integers.
\r
2810 * Being too greedy here, but, whatever.
\r
2815 DC.L SPACE-6-NATWID
\r
2822 * MIN DC.L DOCOL,OVER,OVER,GREAT,ZBRAN
\r
2823 * DC.L MIN2-*-NATWID
\r
2829 * ( n0 n1 --- max(n0,n1) )
\r
2830 * Leave the maximum of the top two integers.
\r
2831 * Really should leave this as in the model, to reduce testing.
\r
2843 * MAX DC.L DOCOL,OVER,OVER,LESS,ZBRAN
\r
2844 * DC.L MAX2-*-NATWID
\r
2852 * DUP if non-zero.
\r
2856 DC.B '-DU' ; '-DUP'
\r
2859 DDUP DC.L *+NATWID ; Just being greedy for speed.
\r
2864 * DDUP DC.L DOCOL,DUP,ZBRAN
\r
2865 * DC.L DDUP2-*-NATWID
\r
2867 * DDUP2 DC.L SEMIS
\r
2869 * ######>> screen 39 <<
\r
2870 * ======>> 98.1 <<
\r
2871 * Supplemental, intended to be used in refactoring TRAVERSE,
\r
2872 * But really would not work there without more code:
\r
2875 * Change top integer to its sign.
\r
2879 DC.B 'SIGNU' ; 'SIGNUM'
\r
2881 DC.L DDUP-5-NATWID
\r
2882 SIGNUM DC.L *+NATWID
\r
2892 * ( adr1 direction --- adr2 )
\r
2893 * TRAVERSE the symbol name.
\r
2894 * If direction is 1, find the end.
\r
2895 * If direction is -1, find the beginning.
\r
2899 DC.B 'TRAVERS' ; 'TRAVERSE'
\r
2901 DC.L SIGNUM-7-NATWID
\r
2902 *TRAV DC.L *+NATWID
\r
2903 * MOVEQ #1,D1 ; Convert negative to -1, zero or positive to 1.
\r
2907 *TRAVG MOVE.L (PSP),A0
\r
2909 ** TRAVLP LEA (A0,D1.L),A0 ; Don't look at the one we start at.
\r
2910 ** CMP.B (A0),D0 ; This follows the FORTH code, but, we could just look at sign bit.
\r
2912 * CLR.L D0 ; Scan by indexing so we can limit it.
\r
2913 *TRAVLP ADD.L D1,D0 ; Don't look at (A0).
\r
2916 * TST.L D1 ; Limit the scan in the selected direction.
\r
2920 *TRAVLN CMP.W #-31,D0
\r
2922 *TRAVDN LEA (A0,D0.L),A0
\r
2925 * Doing this in 68000 or 6809 just because it can be done was getting too greedy.
\r
2926 * Or not? I needed it to test that TRAVERSE was not screwing up.
\r
2928 * DC.L TRON ; DBUG *****
\r
2930 TRAV2 DC.L OVER,PLUS,LIT16
\r
2932 DC.L OVER,CAT,LESS,ZBRAN
\r
2933 DC.L TRAV2-*-NATWID
\r
2935 * DC.L TROFF ; DBG *****
\r
2940 * Fetch CURRENT as a per-USER constant.
\r
2944 DC.B 'LATES' ; 'LATEST'
\r
2946 DC.L TRAV-9-NATWID
\r
2947 LATEST DC.L DOCOL,CURENT,AT,AT
\r
2949 * LATEST DC.L *+NATWID
\r
2950 * Getting too greedy:
\r
2951 * MOVE.L XCURR-UORIG(UP),D0
\r
2952 * MOVE.L (UP,D0.L),A0
\r
2954 * MOVE.L A0,-(PSP)
\r
2956 * Too greedy, still too many smantic holes in the model to fall through.
\r
2957 * Also, if the address at the CFA is made relative,
\r
2958 * this is part of the code that would be affected --
\r
2959 * especially if it is in native CPU code.
\r
2962 * Wanted to do these as INCREMENTERs,
\r
2963 * but I need to stick with the model as much as possible,
\r
2964 * (mostly, LOL) adding code only to make the model more clear.
\r
2965 * ( pfa --- lfa )
\r
2966 * Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
\r
2971 DC.L LATEST-7-NATWID
\r
2972 LFA DC.L DOCOL,LIT16
\r
2973 * DC.W 4 ; on 6800
\r
2979 * ( pfa --- cfa )
\r
2980 * Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
\r
2986 * CFA DC.L DOCOL,TWO,SUB ; on 6800
\r
2987 CFA DC.L DOCOL,NATWC,SUB
\r
2991 * ( pfa --- nfa )
\r
2992 * Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
\r
2998 NFA DC.L DOCOL,LIT16
\r
2999 * DC.W 5 ; on 6800
\r
3001 DC.L SUB,ONE,MINUS,TRAV
\r
3005 * ( nfa --- pfa )
\r
3006 * Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
\r
3012 PFA DC.L DOCOL,ONE,TRAV,LIT16
\r
3013 * DC.W 5 ; on 6800
\r
3018 * ######>> screen 40 <<
\r
3021 * Save the parameter stack pointer in CSP for compiler checks.
\r
3025 DC.B '!CS' ; '!CSP'
\r
3028 *SCSP DC.L DOCOL,SPAT,CSP,STORE
\r
3030 SCSP DC.L *+NATWID
\r
3031 MOVE.L PSP,XCSP-UORIG(UP)
\r
3033 * How would the optimizer have been able to work through the following
\r
3034 * to get the above?
\r
3035 *SCSP DC.L *+NATWID
\r
3036 * MOVE.L PSP,-(PSP)
\r
3037 ** MOVE.L (W),D0 ; Offset into the table.
\r
3038 ** LEA (UP,D0.L),A0
\r
3039 * LEA XCSP-UORIG(UP),A0
\r
3040 * MOVE.L A0,-(PSP)
\r
3041 * MOVEM.L (PSP)+,D0/A0
\r
3049 * ( 0 n --- ) ( *** )
\r
3050 * ( true n --- IN BLK ) ( anything *** nothing )
\r
3051 * If flag is false, do nothing.
\r
3052 * If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
\r
3053 * Leaves cursor position (IN)
\r
3054 * and currently loading block number (BLK) on stack, for analysis.
\r
3056 * This one is too important to be high-level Forth codes.
\r
3057 * When we have an error, we want to disturb as little as possible.
\r
3058 * But fixing that cascades through ERROR and MESSAGE
\r
3059 * into the disk block system.
\r
3060 * And we aren't ready for that yet.
\r
3064 DC.B '?ERRO' ; '?ERROR'
\r
3066 DC.L SCSP-5-NATWID
\r
3067 * QERR DC.L *+NATWID
\r
3068 * TST.L NATWID(PSP)
\r
3070 * LEA NATWID(PSP),PSP
\r
3072 ** this doesn't work anyway:
\r
3073 * QERROR BRA.W ERROR
\r
3074 QERR DC.L DOCOL,SWAP,ZBRAN
\r
3075 DC.L QERR2-*-NATWID
\r
3077 DC.L QERR3-*-NATWID
\r
3082 * STATE is compiling:
\r
3084 * STATE is not compiling:
\r
3085 * ( --- IN BLK ) ( anything *** nothing )
\r
3086 * ERROR if not compiling.
\r
3089 DC.B '?COM' ; '?COMP'
\r
3091 DC.L QERR-7-NATWID
\r
3092 QCOMP DC.L DOCOL,STATE,AT,ZEQU,LIT16
\r
3098 * STATE is executing:
\r
3100 * STATE is not executing:
\r
3101 * ( --- IN BLK ) ( anything *** nothing )
\r
3102 * ERROR if not executing.
\r
3105 DC.B '?EXE' ; '?EXEC'
\r
3107 DC.L QCOMP-6-NATWID
\r
3108 QEXEC DC.L DOCOL,STATE,AT,LIT16
\r
3114 * ( n1 n1 --- ) ( *** )
\r
3115 * ( n1 n2 --- IN BLK ) ( anything *** nothing )
\r
3116 * ERROR if top two are unequal.
\r
3117 * MESSAGE says compiled conditionals do not match.
\r
3121 DC.B '?PAIR' ; '?PAIRS'
\r
3123 DC.L QEXEC-6-NATWID
\r
3124 QPAIRS DC.L DOCOL,SUB,LIT16
\r
3130 * CSP and parameter stack are balanced (equal):
\r
3132 * CSP and parameter stack are not balanced (unequal):
\r
3133 * ( --- IN BLK ) ( anything *** nothing )
\r
3134 * ERROR if return/control stack is not at same level as last !CSP.
\r
3135 * Usually indicates that a definition has been left incomplete.
\r
3139 DC.B '?CS' ; '?CSP'
\r
3141 DC.L QPAIRS-7-NATWID
\r
3142 QCSP DC.L DOCOL,SPAT,CSP,AT,SUB,LIT16
\r
3148 * Active BLK input:
\r
3150 * No active BLK input:
\r
3151 * ( --- IN BLK ) ( anything *** nothing )
\r
3152 * ERROR if not loading, i. e., if BLK is zero.
\r
3156 DC.B '?LOADIN' ; '?LOADING'
\r
3158 DC.L QCSP-5-NATWID
\r
3159 QLOAD DC.L DOCOL,BLK,AT,ZEQU,LIT16
\r
3164 * ######>> screen 41 <<
\r
3167 * Compile an in-line literal value from the instruction stream.
\r
3170 DC.B 'COMPIL' ; 'COMPILE'
\r
3172 DC.L QLOAD-9-NATWID
\r
3173 * COMPIL DC.L DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
\r
3174 * COMPIL DC.L DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
\r
3175 COMPIL DC.L DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
\r
3180 * Clear the compile state bit(s) (shift to interpret).
\r
3182 DC.B $C1 ; [ immediate
\r
3184 DC.L COMPIL-8-NATWID
\r
3185 LBRAK DC.L DOCOL,ZERO,STATE,STORE
\r
3192 * Set the compile state bit(s) (shift to compile).
\r
3196 DC.L LBRAK-2-NATWID
\r
3197 *RBRAK DC.L DOCOL,LIT16
\r
3199 * DC.L STATE,STORE
\r
3201 RBRAK DC.L *+NATWID
\r
3202 MOVE.L #STCOMP,XSTATE-UORIG(UP)
\r
3207 * Toggle SMUDGE bit of LATEST definition header,
\r
3208 * to hide it until defined or reveal it after definition.
\r
3212 DC.B 'SMUDG' ; 'SMUDGE'
\r
3214 DC.L RBRAK-2-NATWID
\r
3215 SMUDGE DC.L DOCOL,LATEST,LIT16
\r
3222 * Set the conversion base to sixteen (b00010000).
\r
3227 DC.L SMUDGE-7-NATWID
\r
3230 DC.W 16 ; decimal sixteen
\r
3236 * Set the conversion base to ten (b00001010).
\r
3239 DC.B 'DECIMA' ; 'DECIMAL'
\r
3244 DC.W 10 ; decimal ten
\r
3248 * ######>> screen 42 <<
\r
3250 * ( --- ) ( IP *** )
\r
3251 * Pop the saved IP and use it to
\r
3252 * compile the latest symbol as a reference to a ;CODE definition;
\r
3253 * overwrite the code field of the symbol found by LATEST
\r
3254 * with the address of the low-level characteristic code
\r
3255 * provided in the defining definition.
\r
3256 * Look closely at where things return, consider the operation of R> and >R .
\r
3258 * The machine-level code which follows (;CODE) in the instruction stream
\r
3259 * is not executed by the defining symbol,
\r
3260 * but becomes the characteristic of the defined symbol.
\r
3261 * This is the usual way to generate the characteristics of VARIABLEs,
\r
3262 * CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
\r
3264 * Finally, note that, if code shifts from low level back to high
\r
3265 * (native CPU machine code calling into a list of FORTH codes),
\r
3266 * the low level code can't just call a high-level definition.
\r
3267 * Leaf definitions can directly call other leaf definitions,
\r
3268 * but not non-leafs.
\r
3269 * It will need an anonymous list, probably embedded in the low-level code,
\r
3270 * and Y and X will have to be set appropriately before entering the list.
\r
3273 DC.B '(;CODE' ; '(;CODE)'
\r
3276 * PSCODE DC.L DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
\r
3277 PSCODE DC.L DOCOL,FROMR ; A5/IP is post-inc, needs no adjustment.
\r
3278 DC.L LATEST,PFA,CFA,STORE
\r
3283 * ?CSP to see if there are loose ends in the defining definition
\r
3284 * before shifting to the assembler,
\r
3285 * compile (;CODE) in the defining definition's instruction stream,
\r
3286 * shift to interpreting,
\r
3287 * make the ASSEMBLER vocabulary current,
\r
3288 * and !CSP to mark the stack
\r
3289 * in preparation for assembling low-level code.
\r
3290 * Note that ;CODE, unlike DOES>, is IMMEDIATE,
\r
3291 * and compiles (;CODE),
\r
3292 * which will do the actual work of changing
\r
3293 * the LATEST definition's characteristic when the defining word runs.
\r
3294 * Assembly is done by the interpreter, rather than the compiler.
\r
3295 * I could have avoided the anomalous three-byte code fields by
\r
3297 * Note that the ASSEMBLER is not part of the model (at this time).
\r
3298 * That means that, until the assembler is ready,
\r
3299 * if you want to define low-level words,
\r
3300 * you have to poke (comma) in hand-assembled stuff.
\r
3303 DC.B $C5 immediate
\r
3304 DC.B ';COD' ; ';CODE'
\r
3306 DC.L PSCODE-8-NATWID
\r
3307 SEMIC DC.L DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
\r
3308 DC.L NOOP ; note: will be replaced by "ASSEMBLER" later
\r
3310 * note: I think I'd rather keep ?STACK here, so I'm adding a NOOP to be patched later.
\r
3312 * ######>> screen 43 <<
\r
3315 * Make the word currently being defined
\r
3316 * build a header for DOES> definitions.
\r
3317 * Actually just compiles a CONSTANT zero
\r
3318 * which can be overwritten later by DOES>.
\r
3319 * Since the fig models were established, this technique has been deprecated.
\r
3321 * Note that <BUILDS is not IMMEDIATE,
\r
3322 * and therefore executes during a definition's run-time,
\r
3323 * rather than its compile-time.
\r
3324 * It is not intended to be used directly,
\r
3325 * but rather so that one definition word can build another.
\r
3326 * Also, note that nothing particularly special happens
\r
3327 * in the defining definition until DOES> executes.
\r
3328 * The name <BUILDS is intended to be a reminder of what is about to occur.
\r
3330 * <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
\r
3333 DC.B '<BUILD' ; '<BUILDS'
\r
3335 DC.L SEMIC-6-NATWID
\r
3336 BUILDS DC.L DOCOL,ZERO,CON
\r
3340 * ( --- ) ( IP *** ) C
\r
3341 * Define run-time behavior of definitions compiled/defined
\r
3342 * by a high-level defining definition --
\r
3343 * the FORTH equivalent of a compiler-compiler.
\r
3344 * DOES> assumes that the LATEST symbol table entry
\r
3345 * has at least one word of parameter field,
\r
3346 * which <BUILDS provides.
\r
3347 * Note that DOES> is also not IMMEDIATE.
\r
3349 * When the defining word containing DOES> executes the DOES> icode,
\r
3350 * it overwrites the LATEST symbol's CFA with jsr <XDOES,
\r
3351 * overwrites the first word of that symbol's parameter field with its own IP,
\r
3352 * and pops the previous IP from the return stack.
\r
3353 * The icodes which follow DOES> in the stream
\r
3354 * do not execute at the defining word's run-time.
\r
3356 * Examining XDOES in the virtual machine shows
\r
3357 * that the defined word will execute those icodes
\r
3358 * which follow DOES> at its own run-time.
\r
3360 * The advantage of this kind of behaviour,
\r
3361 * which you will also note in ;CODE,
\r
3362 * is that the defined word can contain
\r
3363 * both operations and data to be operated on.
\r
3364 * This is how FORTH data objects define their own behavior.
\r
3366 * Finally, note that the effective parameter field for DOES> definitions
\r
3367 * starts two NATWID words after the CFA, instead of just one
\r
3368 * (eight bytes instead of four in a thirty-two-bit addressing Forth).
\r
3370 * VOCABULARYs will use this. See definition of word FORTH.
\r
3373 DC.B 'DOES' ; 'DOES>'
\r
3375 DC.L BUILDS-8-NATWID
\r
3376 * DOES DC.L DOCOL,FROMR,TWOP,LATEST,PFA,STORE
\r
3377 DOES DC.L DOCOL,FROMR ; A5/IP is post-inc, needs no adjustment.
\r
3378 DC.L LATEST,PFA,STORE
\r
3381 * ( --- PFA+NATWID ) ( *** IP )
\r
3382 * Characteristic of a DOES> defined word.
\r
3383 * The characteristics of DOES> definitions are written in high-level
\r
3384 * Forth codes rather than native CPU machine level code.
\r
3385 * The first parameter word points to the high-level characteristic.
\r
3386 * This routine's job is to push the IP,
\r
3387 * load the high level characteristic pointer in IP,
\r
3388 * and leave the address following the characteristic pointer on the stack
\r
3389 * so the parameter field can be accessed.
\r
3390 DODOES MOVE.L (RP),A0
\r
3391 MOVE.L IP,(RP) ; Save/nest the current IP on the return stack.
\r
3392 MOVE.L (W),IP ; First parameter is new IP.
\r
3393 LEA NATWID(W),A1 ; Address of second parameter.
\r
3394 MOVE.L A1,-(PSP) ; Note that PEA would push on Forth RP
\r
3395 JMP (A0) ; return to NEXT.
\r
3397 * ######>> screen 44 <<
\r
3399 * ( strptr --- strptr+1 count )
\r
3400 * Convert counted string to string and count.
\r
3401 * (Fetch the byte at strptr, post-increment.)
\r
3404 DC.B 'COUN' ; 'COUNT'
\r
3406 DC.L DOES-6-NATWID
\r
3407 *COUNT DC.L DOCOL,DUP,ONEP,SWAP,CAT
\r
3409 COUNT DC.L *+NATWID
\r
3418 * ( strptr count --- )
\r
3419 * EMIT count characters at strptr.
\r
3423 DC.B 'TYP' ; 'TYPE'
\r
3425 DC.L COUNT-6-NATWID
\r
3426 *TYPE DC.L DOCOL,DDUP,ZBRAN
\r
3427 * DC.L TYPE3-*-NATWID
\r
3428 * DC.L OVER,PLUS,SWAP,XDO
\r
3429 *TYPE2 DC.L I,CAT,EMIT,XLOOP
\r
3430 * DC.L TYPE2-*-NATWID
\r
3432 * DC.L TYPE4-*-NATWID
\r
3436 TYPE DC.L *+NATWID
\r
3437 MOVEM.L (PSP)+,D0/A0
\r
3449 * ( strptr count1 --- strptr count2 )
\r
3450 * Supress trailing blanks (subtract count of trailing blanks from strptr).
\r
3453 DC.B '-TRAILIN' ; '-TRAILING'
\r
3455 DC.L TYPE-5-NATWID
\r
3456 DTRAIL DC.L DOCOL,DUP,ZERO,XDO
\r
3457 DTRAL2 DC.L OVER,OVER,PLUS,ONE,SUB,CAT,BL
\r
3459 DC.L DTRAL3-*-NATWID
\r
3461 DC.L DTRAL4-*-NATWID
\r
3462 DTRAL3 DC.L ONE,SUB
\r
3464 DC.L DTRAL2-*-NATWID
\r
3469 * TYPE counted string out of instruction stream (updating IP).
\r
3473 DC.B '(."' ; '(.")'
\r
3475 DC.L DTRAIL-10-NATWID
\r
3476 * PDOTQ DC.L DOCOL,R,TWOP,COUNT,DUP,ONEP
\r
3477 * PDOTQ DC.L DOCOL,R,NATP,COUNT,DUP,ONEP
\r
3478 *PDOTQ DC.L DOCOL,R ; A5/IP is post-inc.
\r
3479 * DC.L COUNT,DUP,ONEP ; There's a count byte, too.
\r
3480 * DC.L ZERO,ALGNB,PLUS ; Align the count.
\r
3481 * DC.L FROMR,PLUS,TOR ; IP ready to continue after the string.
\r
3483 * DC.L BREAK ; DBG *****
\r
3486 PDOTQ DC.L *+NATWID ; DOCOL
\r
3487 MOVE.L IP,-(PSP) ; R -- Without DOCOL, IP (post-inc) is where the pointer is.
\r
3488 BSR.W COUNT+NATWID ; Don't want to break the binding to COUNT.
\r
3489 MOVEM.L (PSP),D0/A0 ; count and pointer to string, leave ready for TYPE
\r
3490 ADD.L A0,D0 ; pointer to end of string in D0
\r
3493 ADDQ #1,D0 ; Bump it even.
\r
3494 PDOTQZ MOVE.L D0,IP ; Bump IP over the string.
\r
3495 BRA.W TYPE ; Tail-call.
\r
3499 * { ." something-to-be-printed " } typical input
\r
3500 * Use WORD to parse to trailing quote;
\r
3501 * if compiling, compile XDOTQ and string parsed,
\r
3502 * otherwise, TYPE string.
\r
3505 DC.B $C2 immediate
\r
3508 DC.L PDOTQ-5-NATWID
\r
3511 DC.W $22 ascii quote
\r
3512 DC.L STATE,AT,ZBRAN
\r
3513 DC.L DOTQ1-*-NATWID
\r
3514 DC.L COMPIL,PDOTQ,WORD
\r
3515 DC.L HERE,CAT,ONEP,DUP,ALLOT
\r
3516 DC.L ALGNB,ZBRAN ; Rely on PDOTQ to adjust the IP for the odd length.
\r
3517 DC.L DOTQ0-*-NATWID
\r
3518 DC.L ZERO,CCOMM ; Align and fill with NUL
\r
3520 DC.L DOTQ2-*-NATWID
\r
3521 DOTQ1 DC.L WORD,HERE,COUNT,TYPE
\r
3524 * ######>> screen 45 <<
\r
3525 * ======>> 126 <<== MACHINE DEPENDENT
\r
3527 * ( --- IN BLK ) ( anything *** nothing )
\r
3528 * ERROR if parameter stack out of bounds.
\r
3530 * But checking whether the stack is in bounds or not
\r
3531 * really should not use the stack.
\r
3532 * And there really should be a ?RSTACK, as well.
\r
3536 DC.B '?STAC' ; '?STACK'
\r
3538 DC.L DOTQ-3-NATWID
\r
3539 QSTACK DC.L DOCOL,LIT16
\r
3542 * But why use that instead of XSPZER (S0)?
\r
3543 * Multi-user or multi-tasking would not want that.
\r
3544 * CMP.L XSPZER-UORIG(UP),PSP ; something like this
\r
3545 * DC.L PORIG,AT,TWO,SUB,SPAT,LESS,ONE
\r
3546 DC.L PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
\r
3548 * prints 'empty stack'
\r
3551 * Here, we compare with a value at least 128
\r
3552 * higher than dict. ptr. (DICTPT)
\r
3554 * DC.W $80 ; This is a rough check anyway, leave it as is.
\r
3555 * But shouldn't it be the terminal width?
\r
3556 DC.L HERE,COLUMS,AT
\r
3557 DC.L PLUS,LESS,ZBRAN
\r
3558 DC.L QSTAC3-*-NATWID
\r
3559 DC.L TWO ; NOT the NATWID constant!
\r
3561 * prints 'full stack'
\r
3565 * ======>> 127 << this word's function
\r
3566 * is done by ?STACK in this version
\r
3571 * DC.L QSTACK-7-NATWID
\r
3572 *QFREE DC.L DOCOL,SPAT,HERE,LIT16
\r
3574 * DC.L PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
\r
3578 * ######>> screen 46 <<
\r
3580 * ( buffer n --- )
\r
3581 * ***** Check that this is how it works here:
\r
3582 * Get up to n-1 characters from the keyboard,
\r
3583 * storing at buffer and echoing, with backspace editing,
\r
3584 * quitting when a CR is read.
\r
3585 * Terminate it with a NUL.
\r
3589 DC.B 'EXPEC' ; 'EXPECT'
\r
3591 DC.L QSTACK-7-NATWID
\r
3592 EXPECT DC.L DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
\r
3593 * EXPEC2 DC.L KEY,DUP,LIT16
\r
3596 DC.W BACKSP-ORIG ; again, this should be in the per-task table
\r
3597 DC.L PORIG,AT,EQUAL,ZBRAN ; check for backspacing
\r
3598 DC.L EXPEC3-*-NATWID
\r
3600 DC.W 8 ; ( backspace character to emit )
\r
3601 DC.L OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
\r
3603 DC.L EXPEC6-*-NATWID
\r
3604 EXPEC3 DC.L DUP,LIT16
\r
3605 DC.W $D ; ( carriage return )
\r
3607 DC.L EXPEC4-*-NATWID
\r
3608 * DC.L BREAK ; dbg
\r
3609 DC.L LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
\r
3610 DC.L EXPEC5-*-NATWID
\r
3612 * DC.L BREAK ; dbg
\r
3613 EXPEC5 DC.L I,CSTORE,ZERO,I,ONEP,CSTORE,ZERO,I,TWOP,CSTORE ; save two NULs to make sure address is even
\r
3614 EXPEC6 DC.L EMIT,XLOOP
\r
3615 DC.L EXPEC2-*-NATWID
\r
3621 * EXPECT terminal width characters to TIB.
\r
3624 DC.B 'QUER' ; 'QUERY'
\r
3626 DC.L EXPECT-7-NATWID
\r
3627 QUERY DC.L DOCOL,TIB,AT,COLUMS,AT
\r
3628 * DC.L TRON ; dbg *****
\r
3629 DC.L EXPECT,ZERO,IN,STORE
\r
3630 * DC.L TROFF ; dbg *****
\r
3635 * End interpretation of a line or screen, and/or prepare for a new block.
\r
3636 * Note that the name of this definition is an empty string,
\r
3637 * so it matches on the terminating NUL in the terminal or block buffer.
\r
3639 DC.B $C1 ; immediate < carriage return >
\r
3640 DC.B $00|$80 ; NUL character (end of buffered text)
\r
3641 DC.L QUERY-6-NATWID
\r
3642 NULL DC.L DOCOL,BLK,AT,ZBRAN
\r
3643 DC.L NULL2-*-NATWID
\r
3644 DC.L ONE,BLK,PSTORE
\r
3645 DC.L ZERO,IN,STORE,BLK,AT,BSCR,MOD
\r
3647 * check for end of screen
\r
3649 DC.L NULL1-*-NATWID
\r
3650 DC.L QEXEC,FROMR,DROP
\r
3652 DC.L NULL3-*-NATWID
\r
3653 NULL2 DC.L FROMR,DROP
\r
3658 * ######>> screen 47 <<
\r
3661 * Fill n bytes at adr with b.
\r
3662 * This relies on CMOVE having a certain lack of parameter checking,
\r
3663 * where overlapping regions are not properly inverted in copy.
\r
3664 * And this really should be done in low-level.
\r
3665 * None of the advantages of doing things in high-level apply to fill.
\r
3669 DC.B 'FIL' ; 'FILL'
\r
3671 DC.L NULL-2-NATWID
\r
3673 * DC.L BREAK ; DBG
\r
3674 DC.L SWAP,TOR,OVER,CSTORE,DUP,ONEP
\r
3675 DC.L FROMR,ONE,SUB,CMOVE
\r
3680 * Fill n bytes with 0.
\r
3683 DC.B 'ERAS' ; 'ERASE'
\r
3685 DC.L FILL-5-NATWID
\r
3686 ERASE DC.L DOCOL,ZERO,FILL
\r
3691 * Fill n bytes with ASCII SPACE.
\r
3695 DC.B 'BLANK' ; 'BLANKS'
\r
3697 DC.L ERASE-6-NATWID
\r
3698 BLANKS DC.L DOCOL,BL,FILL
\r
3703 * Format a character at the left of the HLD output buffer.
\r
3707 DC.B 'HOL' ; 'HOLD'
\r
3709 DC.L BLANKS-7-NATWID
\r
3710 HOLD DC.L DOCOL,LIT
\r
3711 DC.L -1 ; $FFFF in 16-bit model, but -1 is -1. DPL flag.
\r
3712 DC.L HLD,PSTORE,HLD,AT,CSTORE
\r
3717 * Give the address of the output PAD buffer.
\r
3718 * PAD points to the end of a 68 byte buffer for numeric conversion.
\r
3719 * 68 bytes is enough to convert a 64-bit integer to binary.
\r
3724 DC.L HOLD-5-NATWID
\r
3725 PAD DC.L DOCOL,HERE,LIT16
\r
3730 * ######>> screen 48 <<
\r
3733 * Scan a string terminated by the character c or ASCII NUL out of input;
\r
3734 * store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
\r
3735 * Leading c are passed over, per ENCLOSE.
\r
3736 * Scans from BLK, or from TIB if BLK is zero.
\r
3737 * May overwrite the numeric conversion pad,
\r
3738 * if really long (length > 31) symbols are scanned.
\r
3739 * Does not ALLOCate the symbol.
\r
3743 DC.B 'WOR' ; 'WORD'
\r
3746 WORD DC.L DOCOL,BLK,AT,ZBRAN
\r
3747 DC.L WORD2-*-NATWID
\r
3748 DC.L BLK,AT,BLOCK,BRAN
\r
3749 DC.L WORD3-*-NATWID
\r
3751 WORD3 DC.L IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT16
\r
3753 DC.L BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
\r
3754 DC.L CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
\r
3757 * ######>> screen 49 <<
\r
3759 * ( d1 string --- d2 adr )
\r
3760 * Convert the text at string into a number, accumulating the result into d1,
\r
3761 * leaving adr pointing to the first character not converted.
\r
3762 * If DPL is non-negative at entry,
\r
3763 * accumulates the number of characters converted into DPL.
\r
3767 DC.B '(NUMBER' ; '(NUMBER)'
\r
3769 DC.L WORD-5-NATWID
\r
3771 * DC.L BREAK ; DBG *****
\r
3772 PNUMB2 DC.L ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
\r
3773 DC.L PNUMB4-*-NATWID
\r
3774 DC.L SWAP,BASE,AT,USTAR,DROP,ROT,BASE
\r
3775 DC.L AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
\r
3776 DC.L PNUMB3-*-NATWID
\r
3777 DC.L ONE,DPL,PSTORE
\r
3778 PNUMB3 DC.L FROMR,BRAN
\r
3779 DC.L PNUMB2-*-NATWID
\r
3781 * DC.L BREAK ; DBG *****
\r
3786 * Convert text at ctstr to a double integer,
\r
3787 * taking the 0 ERROR if the conversion is not valid.
\r
3788 * If a decimal point is present,
\r
3789 * accumulate the count of digits to the decimal point's right into DPL
\r
3790 * (negative DPL at exit indicates single precision).
\r
3791 * ctstr is a counted string
\r
3792 * -- the first byte at ctstr is the length of the string,
\r
3793 * but NUMBER ignores the count and expects a NUL terminator instead.
\r
3797 DC.B 'NUMBE' ; 'NUMBER'
\r
3799 DC.L PNUMB-9-NATWID
\r
3800 NUMB DC.L DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT16
\r
3801 DC.W "-" minus sign
\r
3802 DC.L EQUAL,DUP,TOR,PLUS,LIT
\r
3803 DC.L -1 ; $FFFF in 16-bit model, but -1 is -1. DPL flag.
\r
3804 NUMB1 DC.L DPL,STORE,PNUMB,DUP,CAT,BL,SUB
\r
3806 DC.L NUMB2-*-NATWID
\r
3807 DC.L DUP,CAT,LIT16
\r
3809 DC.L SUB,ZERO,QERR,ZERO,BRAN
\r
3810 DC.L NUMB1-*-NATWID
\r
3811 NUMB2 DC.L DROP,FROMR,ZBRAN
\r
3812 DC.L NUMB3-*-NATWID
\r
3817 * ( --- locptr length true ) { -FIND name } typical input
\r
3819 * Parse a word, then FIND,
\r
3820 * first in the definition vocabulary,
\r
3821 * then in the CONTEXT (interpretation) vocabulary, if necessary.
\r
3822 * Returns what (FIND) returns, flag and optional location and length.
\r
3825 DC.B '-FIN' ; '-FIND'
\r
3827 DC.L NUMB-7-NATWID
\r
3828 DFIND DC.L DOCOL,BL,WORD,HERE,CONTXT,AT,AT
\r
3829 DC.L PFIND,DUP,ZEQU,ZBRAN
\r
3830 DC.L DFIND2-*-NATWID
\r
3831 DC.L DROP,HERE,LATEST,PFIND
\r
3835 * ######>> screen 50 <<
\r
3837 * ( anything --- nothing ) ( anything *** nothing )
\r
3838 * An indirection for ABORT, for ERROR,
\r
3839 * which may be modified carefully.
\r
3840 * We are now using PABORT for what it probably was originally intended --
\r
3841 * a way to break the dependency cycle in ERROR.
\r
3844 DC.B '(ABORT' ; '(ABORT)'
\r
3846 DC.L DFIND-6-NATWID
\r
3847 *PABORT DC.L DOCOL,ABORT
\r
3849 PABORT DC.L *+NATWID
\r
3850 MOVE.L #ABORT+NATWID,IP
\r
3851 BRA.W NEXT ; Don't even return.
\r
3854 * ERROR ( anything line --- IN BLK ) ( anything *** nothing )
\r
3855 * ( anything --- nothing )
\r
3856 * ( anything *** nothing ) WARNING < 0
\r
3857 * Prints out the last symbol scanned and MESSAGE number line. If
\r
3858 * WARNING is less than zero, ABORTs through (ABORT), otherwise,
\r
3859 * clears the parameter stack, pushes the INput cursor and
\r
3860 * interpretaion BLK, and QUITs.
\r
3863 DC.B 'ERRO' ; 'ERROR'
\r
3865 DC.L PABORT-8-NATWID
\r
3866 * It's time to make this low-level.
\r
3867 ERROR DC.L DOCOL,WARN,AT,ZLESS
\r
3869 DC.L ERROR2-*-NATWID
\r
3870 * note: WARNING is
\r
3872 * 0 to print error #
\r
3873 * and 1 to print error message from disc
\r
3875 ERROR2 DC.L HERE,COUNT,TYPE,PDOTQ
\r
3876 DC.B 4,7 ; ( bell )
\r
3878 DC.B 0 ; hand-align
\r
3879 DC.L MESS,SPSTOR,IN,AT,BLK,AT,QUIT
\r
3884 * Mask byte at adr with n.
\r
3885 * Not in FIG, don't need it for 8 bit characters after all.
\r
3888 * DC.B 'CMAS' ; 'CMASK'
\r
3890 * DC.L ERROR-6-NATWID
\r
3891 * CMASK DC.L *+NATWID
\r
3892 * MOVE.L (PSP)+,A0 ; adr
\r
3893 * MOVE.L (PSP)+,D0 ; prepare for mask
\r
3898 * Mask high bit of tail of name in PAD buffer.
\r
3899 * Not in FIG, need it for characters with high bit set.
\r
3903 DC.B 'IDFLA' ; 'IDFLAT'
\r
3905 DC.L ERROR-6-NATWID
\r
3906 IDFLAT DC.L *+NATWID
\r
3908 MOVE.B (A0),D1 ; get the count
\r
3910 AND.B #$7F,(A0,D1.W) ; point to the tail and clear the EndOfName flag bit.
\r
3914 * Print definition's name from its NFA.
\r
3919 DC.L IDFLAT-7-NATWID
\r
3920 IDDOT DC.L DOCOL,PAD
\r
3921 * DC.L BREAK ; DBG *****
\r
3923 DC.W MAXNML ; Why did I hard code this?
\r
3924 * DC.L WIDTH,ONEP ; Because WIDTH is a (USER) variable.
\r
3926 DC.W '_' ( underline )
\r
3927 DC.L FILL,DUP,PFA,LFA,OVER,SUB,PAD
\r
3928 * DC.L SWAP,CMOVE,PAD,COUNT,LIT16
\r
3930 DC.L SWAP,CMOVE,PAD
\r
3934 DC.L AND,TYPE,SPACE
\r
3937 * ######>> screen 51 <<
\r
3939 * ( --- ) { CREATE name } input
\r
3940 * Parse a name (length < MAXNML characters) and create a header,
\r
3941 * reporting first duplicate found in either the defining vocabulary
\r
3942 * or the context (interpreting) vocabulary.
\r
3943 * Install the header in the defining vocabulary
\r
3944 * with CFA dangerously pointing to the parameter field.
\r
3945 * Leave the name SMUDGEd.
\r
3949 DC.B 'CREAT' ; 'CREATE'
\r
3951 DC.L IDDOT-4-NATWID
\r
3952 CREATE DC.L DOCOL,DFIND,ZBRAN
\r
3953 DC.L CREAT2-*-NATWID
\r
3958 DC.B 0 ; hand align
\r
3959 DC.L NFA,IDDOT,LIT16
\r
3962 *CREAT2 DC.L HERE,DUP,CAT,WIDTH,AT,MIN ; clip to WIDTH
\r
3963 CREAT2 DC.L BREAK,HERE,CAT,WIDTH,AT,MIN ; clip to WIDTH, hold off copying HERE ; DBG *****
\r
3964 * Make sure it ends up aligned by moving the name.
\r
3965 * Note that we don't need to copy beyond WIDTH.
\r
3966 DC.L DUP,HERE,PLUS,ONEP ; tentative LFA
\r
3967 DC.L ONE,AND,ZBRAN ; Will LFA, as is, be even?
\r
3968 DC.L CREATN-*-NATWID ; will be even
\r
3970 DC.L HERE,OVER,HERE,ONEP,SWAP,ONEP ; source, destination, length including count
\r
3971 DC.L CMOVD ; Use descending copy so it doesn't just fill.
\r
3973 DC.L ZERO,CCOMM ; insert a NUL byte, update HERE.
\r
3975 * Now build header.
\r
3976 CREATN DC.L HERE,SWAP,ONEP,ALLOT,DUP,LIT16
\r
3977 DC.W ($80|FSMUDG) ; Bracket the name.
\r
3979 DC.L HERE,ONE,SUB,LIT16
\r
3982 DC.L LATEST,COMMA,CURENT,AT,STORE
\r
3983 * DC.L HERE,TWOP,COMMA
\r
3984 DC.L HERE,NATP,COMMA
\r
3987 * ######>> screen 52 <<
\r
3990 * { [COMPILE] name } typical use
\r
3991 * -DFIND next WORD and COMPILE it, literally;
\r
3992 * used to compile immediate definitions into words.
\r
3994 DC.B $C9 immediate
\r
3995 DC.B '[COMPILE' ; '[COMPILE]'
\r
3997 DC.L CREATE-7-NATWID
\r
3998 BCOMP DC.L DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
\r
4002 * ( n --- ) if compiling. P
\r
4003 * ( n --- n ) if interpreting.
\r
4004 * Compile n as a literal, if compiling.
\r
4006 DC.B $C7 immediate
\r
4007 DC.B 'LITERA' ; 'LITERAL'
\r
4009 DC.L BCOMP-10-NATWID
\r
4010 LITER DC.L DOCOL,STATE,AT,ZBRAN
\r
4011 DC.L LITER2-*-NATWID
\r
4012 DC.L COMPIL,LIT,COMMA
\r
4016 * ( d --- ) if compiling. P
\r
4017 * ( d --- d ) if interpreting.
\r
4018 * Compile d as a double literal, if compiling.
\r
4021 DC.B $C8 immediate
\r
4022 DC.B 'DLITERA' ; 'DLITERAL'
\r
4024 DC.L LITER-8-NATWID
\r
4025 DLITER DC.L DOCOL,STATE,AT,ZBRAN
\r
4026 DC.L DLITE2-*-NATWID
\r
4027 DC.L SWAP,LITER,LITER ; Just two literals in the right order.
\r
4030 * ######>> screen 53 <<
\r
4033 * Interpret or compile, according to STATE.
\r
4034 * Searches words parsed in dictionary first, via -FIND,
\r
4035 * then checks for valid NUMBER.
\r
4036 * Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
\r
4037 * ERROR checks the stack via ?STACK before returning to its caller.
\r
4040 DC.B 'INTERPRE' ; 'INTERPRET'
\r
4042 * DC.L LITER-8-NATWID
\r
4043 DC.L DLITER-9-NATWID
\r
4045 INTER2 DC.L DFIND,ZBRAN
\r
4046 DC.L INTER5-*-NATWID
\r
4047 DC.L STATE,AT,LESS
\r
4049 DC.L INTER3-*-NATWID
\r
4050 DC.L CFA,COMMA,BRAN
\r
4051 DC.L INTER4-*-NATWID
\r
4052 INTER3 DC.L CFA,EXEC
\r
4054 DC.L INTER7-*-NATWID
\r
4055 INTER5 DC.L HERE,NUMB,DPL,AT,ONEP,ZBRAN
\r
4056 DC.L INTER6-*-NATWID
\r
4058 DC.L INTER7-*-NATWID
\r
4059 INTER6 DC.L DROP,LITER
\r
4060 INTER7 DC.L QSTACK,BRAN
\r
4061 *INTER7 DC.L BREAK,QSTACK,BRAN ; DBG
\r
4062 DC.L INTER2-*-NATWID
\r
4063 * DC.L SEMIS never executed
\r
4066 * ######>> screen 54 <<
\r
4069 * Toggle precedence bit of LATEST definition header.
\r
4070 * During compiling, most symbols scanned are compiled.
\r
4071 * IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
\r
4072 * but may be compiled via ' (TICK).
\r
4075 DC.B 'IMMEDIAT' ; 'IMMEDIATE'
\r
4077 DC.L INTERP-10-NATWID
\r
4078 IMMED DC.L DOCOL,LATEST,LIT16
\r
4084 * ( --- ) { VOCABULARY name } input
\r
4085 * Create a vocabulary entry with a flag for terminating vocabulary searches.
\r
4086 * Store the current search context in it for linking.
\r
4087 * At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
\r
4091 DC.B 'VOCABULAR' ; 'VOCABULARY'
\r
4093 DC.L IMMED-10-NATWID
\r
4094 VOCAB DC.L DOCOL,BUILDS,LIT,VOCFLG,COMMA,CURENT,AT,CFA
\r
4095 DC.L COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
\r
4096 * DOVOC DC.L TWOP,CONTXT,STORE
\r
4097 DOVOC DC.L NATP,CONTXT,STORE
\r
4102 * Note: FORTH does not go here in the rom-able dictionary,
\r
4103 * since FORTH is a type of variable.
\r
4105 * (Should make a proper architecture for this at some point.)
\r
4110 * Makes the current interpretation CONTEXT vocabulary
\r
4111 * also the CURRENT defining vocabulary.
\r
4114 DC.B 'DEFINITION' ; 'DEFINITIONS'
\r
4116 DC.L VOCAB-11-NATWID
\r
4117 DEFIN DC.L DOCOL,CONTXT,AT,CURENT,STORE
\r
4122 * Parse out a comment and toss it away.
\r
4123 * Leaves the leading characters in WORDPAD, which may or may not be useful.
\r
4125 DC.B $C1 immediate (
\r
4127 DC.L DEFIN-12-NATWID
\r
4128 PAREN DC.L DOCOL,LIT16
\r
4133 * ######>> screen 55 <<
\r
4135 * ( anything *** nothing )
\r
4136 * Clear return stack.
\r
4137 * Then INTERPRET and, if not compiling, prompt with OK,
\r
4138 * in infinite loop.
\r
4142 DC.B 'QUI' ; 'QUIT'
\r
4144 DC.L PAREN-2-NATWID
\r
4145 QUIT DC.L DOCOL,ZERO,BLK,STORE
\r
4146 DC.L BREAK ; DBG ****
\r
4149 * Here is the outer interpretter
\r
4150 * which gets a line of input, does it, prints " OK"
\r
4152 QUIT2 DC.L RPSTOR,CR,QUERY
\r
4153 DC.L BREAK ; DBG *****
\r
4154 DC.L INTERP,STATE,AT,ZEQU
\r
4156 DC.L QUIT3-*-NATWID
\r
4159 DC.B ' OK' ; ' OK'
\r
4161 DC.L QUIT2-*-NATWID
\r
4162 * DC.L SEMIS ( never executed )
\r
4165 * ( anything --- nothing ) ( anything *** nothing )
\r
4166 * Clear parameter stack,
\r
4167 * set STATE to interpret and BASE to DECIMAL,
\r
4168 * return to input from terminal,
\r
4169 * restore DRIVE OFFSET to 0,
\r
4170 * print out "Forth-68",
\r
4171 * set interpret and define vocabularies to FORTH,
\r
4172 * and finally, QUIT.
\r
4173 * Used to force the system to a known state
\r
4174 * and return control to the initial INTERPRETer.
\r
4177 DC.B 'ABOR' ; 'ABORT'
\r
4179 DC.L QUIT-5-NATWID
\r
4180 *ABORT DC.L DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
\r
4181 ABORT DC.L DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,BREAK,PDOTQ
\r
4183 DC.B "fig-Forth-68000"
\r
4184 * DC.B 0 ; hand align
\r
4186 * DC.L CR,TROFF,VLIST ; (whole line is) DBG ****
\r
4188 * DC.L SEMIS never executed
\r
4191 * ######>> screen 56 <<
\r
4192 * bootstrap code... moves rom contents to ram :
\r
4197 DC.B 'COL' ; 'COLD'
\r
4199 DC.L ABORT-6-NATWID
\r
4200 COLD DC.L *+NATWID
\r
4201 * Ultimately, we want position indepence,
\r
4202 * so I'm using PCR where it seems reasonable.
\r
4203 * Time for some testing.
\r
4204 CENT MOVE.L RINIT(PC),RP ; Get a useable initial return stack,
\r
4205 MOVE.L SINIT(PC),PSP ; a useable initial parameter stack,
\r
4206 * MOVE.L #IUP,UP ; and a useable initial task base (not in init table).
\r
4207 MOVE.L #UORIG,UP ; and a useable initial task base (not in init table).
\r
4209 LEA ERAM(PC),A2 ; end of stuff to move, A2 as loop terminator
\r
4210 MOVE.L #RBEG,A1 ; bottom of (open-ended) destination
\r
4211 LEA RAM(PC),A0 ; bottom of stuff to move
\r
4212 COLD2 MOVE.B (A0)+,(A1)+ ; move TASK & FORTH to ram
\r
4215 * The above leaves USE and PREV uninitialized.
\r
4216 MOVE.L BUFINT(PC),A2
\r
4217 MOVE.L A2,XUSE-UORIG(UP)
\r
4218 MOVE.L A2,XPREV-UORIG(UP)
\r
4219 * ... or we could go top to bottom.
\r
4220 * Definitely no need to use the return stack pointer like in the 6800 model,
\r
4221 * nor to fiddle with it, since it is already pointing to a place that should be safe.
\r
4222 MOVE.L COLINT(PC),XCOLUM-UORIG(UP)
\r
4223 MOVE.L DELINT(PC),XDELAY-UORIG(UP)
\r
4224 MOVE.L VOCINT(PC),XVOCL-UORIG(UP)
\r
4225 MOVE.L DPINIT(PC),XDICTP-UORIG(UP)
\r
4226 MOVE.L FENCIN(PC),XFENCE-UORIG(UP)
\r
4228 WENT MOVE.L RINIT(PC),RP ; Get a useable initial return stack,
\r
4229 MOVE.L SINIT(PC),PSP ; a useable initial parameter stack,
\r
4230 * MOVE.L #IUP,UP ; and a useable initial task base (not in init table).
\r
4231 MOVE.L #UORIG,UP ; and a useable initial task base (not in init table).
\r
4233 LEA SINIT(PC),A2 ; for loop termination
\r
4234 LEA XFENCE-UORIG(UP),A1 ; top of destination
\r
4235 LEA FENCIN(PC),A0 ; top of stuff to move
\r
4236 WARM2 MOVE.L -(A0),-(A1) ; All entries are 32 bit.
\r
4240 LEA ABORT+NATWID(PC),IP ; IP never points to DOCOL!
\r
4242 NOP ; Here is a place to jump to special user
\r
4243 NOP ; initializations such as I/0 interrups
\r
4248 * For systems with TRACE:
\r
4249 CLR.L (RP) ; The hole above the return stack
\r
4250 CLR.L (PSP) ; The hole above the parameter stack
\r
4252 CLR.W TRLIM-N(A0) ; clear trace limit (all bytes)
\r
4253 CLR.W TRACEM-N(A0) ; and mode (all bytes)
\r
4255 * ADDQ.W #1,TRACEM-N(A0) ; DBG *******************
\r
4256 CLR.L BRKPT-N(A0) ; clear breakpoint address
\r
4257 BRA.W RPSTOR+NATWID ; start the virtual machine running !
\r
4258 * RPSTOR's NEXT will pick up the IP set above, and start ABORT.
\r
4259 * RP! sets up the return stack pointer, then IP references abort.
\r
4261 * Comment out the branch above and use something like this to jump direct to test code:
\r
4262 * LEA TESTMIN(PC),IP
\r
4266 * Here is the stuff that gets copied to ram :
\r
4267 * (not * at address $140:)
\r
4268 * at an appropriate address:
\r
4270 * RAM DC.L $3000,$3000,0,0
\r
4271 * RAM DC.L BUFBAS,BUFBAS,0,0 ; ... except the direct page has moved.
\r
4272 * These initialization values for USE and PREV were here to help pack the code.
\r
4273 * They don't belong here unless we move the USER table
\r
4274 * back below the writable dictionary,
\r
4275 * *and* move these USER variables to the end of the direct page --
\r
4276 * *or* let these definitions exist in the USER table.
\r
4277 RAM EQU * ; Does RAM need to have the BUFfer BASe address before RFORTH?
\r
4279 * ======>> (152) <<
\r
4281 * Makes FORTH the current interpretation vocabulary.
\r
4282 * In order to make this ROMmable,
\r
4283 * this entry is set up as the tail-end of its VOCABULARY,
\r
4284 * and copied to RAM in the start-up code.
\r
4285 * We want a more elegant solution to this, too. Greedy, maybe.
\r
4287 DC.B $C5 immediate
\r
4288 DC.B 'FORT' ; 'FORTH'
\r
4290 DC.L NOOP-5-NATWID ; Note that this does not link to COLD!
\r
4291 RFORTH DC.L DODOES,DOVOC,VOCFLG,TASK-5-NATWID
\r
4293 DC.B "Copyright 1979 Forth Interest Group, David Lion,"
\r
4295 DC.B "Parts Copyright 2019 Joel Matthew Rees"
\r
4301 DC.B 'TAS' ; 'TASK'
\r
4303 DC.L FORTH-6-NATWID
\r
4304 RTASK DC.L DOCOL,SEMIS
\r
4306 ERAMSZ EQU *-RAM ; So we can get a look at it.
\r
4309 * ######>> screen 57 <<
\r
4312 * Sign extend n0 to a double integer.
\r
4316 DC.B 'S->' ; 'S->D'
\r
4318 DC.L COLD-5-NATWID ; Note that this does not link to FORTH (RFORTH)!
\r
4319 *STOD DC.L DOCOL,DUP,ZLESS,MINUS
\r
4321 STOD DC.L *+NATWID ; Make it directly callable.
\r
4332 *STODS MOVE.L D0,-(PSP)
\r
4339 * MOVE.L D0,-(PSP)
\r
4343 * ( multiplier multiplicand --- product )
\r
4344 * Signed word multiply.
\r
4348 DC.L STOD-5-NATWID
\r
4350 DC.L USTAR,DROP,SEMIS ; Drop high word.
\r
4351 * STAR DC.L *+NATWID
\r
4352 * BSR.W USTAR+NATWID
\r
4353 * LEA NATWID(PSP),PSP ; Drop high word. Seems like magic, doesn't it?
\r
4357 * ( dividend divisor --- remainder quotient )
\r
4358 * M/ in word-only form, i. e., signed division of 2nd word by top word,
\r
4359 * yielding signed word quotient and remainder.
\r
4360 * Except *BUG* it isn't signed.
\r
4364 DC.B '/MO' ; '/MOD'
\r
4366 DC.L STAR-2-NATWID
\r
4367 SLMOD DC.L DOCOL,TOR,STOD,FROMR,USLASH
\r
4371 * ( dividend divisor --- quotient )
\r
4372 * Signed word divide without remainder.
\r
4373 * Except *BUG* it isn't signed.
\r
4377 DC.L SLMOD-5-NATWID
\r
4378 SLASH DC.L DOCOL,SLMOD,SWAP,DROP
\r
4382 * ( dividend divisor --- remainder )
\r
4383 * Remainder function, result takes sign of dividend.
\r
4388 DC.L SLASH-2-NATWID
\r
4389 MOD DC.L DOCOL,SLMOD,DROP
\r
4393 * ( multiplier multiplicand divisor --- remainder quotient )
\r
4394 * Signed precise division of product:
\r
4395 * multiply 2nd and 3rd words on stack
\r
4396 * and divide the 31-bit product by the top word,
\r
4397 * leaving both quotient and remainder.
\r
4398 * Remainder takes sign of product.
\r
4399 * Guaranteed not to lose significant bits in 16 bit integer math.
\r
4402 DC.B '*/MO' ; '*/MOD'
\r
4405 SSMOD DC.L DOCOL,TOR,USTAR,FROMR,USLASH
\r
4409 * ( multiplier multiplicand divisor --- quotient )
\r
4410 * */MOD without remainder.
\r
4416 DC.L SSMOD-6-NATWID
\r
4417 SSLASH DC.L DOCOL,SSMOD,SWAP,DROP
\r
4421 * ( ud1 u1 --- u2 ud2 )
\r
4422 * U/ with an (unsigned) double quotient.
\r
4423 * Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
\r
4424 * if you are prepared to deal with the extra 16 bits of result.
\r
4427 DC.B 'M/MO' ; 'M/MOD'
\r
4429 DC.L SSLASH-3-NATWID
\r
4430 MSMOD DC.L DOCOL,TOR,ZERO,R,USLASH
\r
4431 DC.L FROMR,SWAP,TOR,USLASH,FROMR
\r
4437 * Convert the top of stack to its absolute value.
\r
4442 DC.L MSMOD-6-NATWID
\r
4443 ABS DC.L DOCOL,DUP,ZLESS,ZBRAN
\r
4444 DC.L ABS2-*-NATWID
\r
4451 * Convert the top double to its absolute value.
\r
4455 DC.B 'DAB' ; 'DABS'
\r
4458 DABS DC.L DOCOL,DUP,ZLESS,ZBRAN
\r
4459 DC.L DABS2-*-NATWID
\r
4464 * ######>> screen 58 <<
\r
4465 * Disc primitives :
\r
4468 * Least Recently Used buffer.
\r
4469 * Really should be with FIRST and LIMIT in the per-task table.
\r
4474 DC.L DABS-5-NATWID
\r
4476 DC.L XUSE ; The address of XUSE is the constant.
\r
4479 * Most Recently Used buffer.
\r
4480 * Really should be with FIRST and LIMIT in the per-task table.
\r
4484 DC.B 'PRE' ; 'PREV'
\r
4488 DC.L XPREV ; The address of XPREV is the constant.
\r
4490 * ( buffer1 --- buffer2 f )
\r
4491 * Bump to next buffer,
\r
4492 * flag false if result is PREVious buffer,
\r
4493 * otherwise flag true.
\r
4494 * Used in the LRU allocation routines.
\r
4498 DC.B '+BU' ; '+BUF'
\r
4500 DC.L PREV-5-NATWID
\r
4501 * PBUF DC.L DOCOL,LIT16
\r
4502 * DC.W $84 ; This was a hard-wiring bug.
\r
4503 PBUF DC.L DOCOL,BBUF,BCTL,PLUS ; Size of the buffer record.
\r
4504 * DC.L PLUS,DUP,LIMIT,EQUAL,ZBRAN
\r
4505 DC.L PLUS,DUP,LIMIT,LESS,ZEQU,OVER,FIRST,LESS,OR,ZBRAN
\r
4506 DC.L PBUF2-*-NATWID ; Use defensive programming.
\r
4508 PBUF2 DC.L DUP,PREV,AT,SUB
\r
4513 UPDATB EQU $80000000 ; $8000 in the 6800 model -- puts limits on sector count.
\r
4516 * Flag to mark a buffer dirty, in need of being written out.
\r
4517 * This flag limits the max number of sectors in a disk to ((256^NATWID)/2)-1.
\r
4518 * It also hard-codes an implicit test which is used elsewhere.
\r
4522 DC.B 'UPDATE-BI' ; 'UPDATE-BIT'
\r
4524 DC.L PBUF-5-NATWID
\r
4529 * Mark PREVious buffer dirty, in need of being written out.
\r
4533 DC.B 'UPDAT' ; 'UPDATE'
\r
4535 DC.L UPDBIT-11-NATWID
\r
4536 * UPDATE DC.L DOCOL,PREV,AT,AT,LIT,UPDATB,OR,PREV,AT,STORE
\r
4537 UPDATE DC.L DOCOL,PREV,AT,AT,UPDBIT,OR,PREV,AT,STORE
\r
4542 * Going to leave the 0 sector bug in place, I guess. Maybe.
\r
4544 ** Mark the buffer addressed as empty.
\r
4545 ** Have to add code to avoid block 0 appearing to be in a buffer from COLD.
\r
4546 ** Usually, there is no sector 0 (?), but the RAM buffers are too simple.
\r
4547 ** Note that without this block number being made illegal,
\r
4548 ** about 8 binaryMegabytes (256 bytes/block) of disk can be addressed total.
\r
4549 ** With this block number made illegal, the max is 1 block less,
\r
4550 ** still about 8 biMeg.
\r
4553 * DC.B 'KILL-BUFFE' ; 'KILL-BUFFER'
\r
4555 * DC.L UPDATE-7-NATWID
\r
4556 *KILBUF DC.L *+NATWID ; DOCOL,UPDBIT,ONE,SUB,SWAP,STORE
\r
4557 * MOVE.L (PSP)+,A0
\r
4558 * MOVE.L UPDBIT+NATWID(PC),D0
\r
4564 * Mark all buffers empty.
\r
4568 * DC.B 'KILL-BUFFER' ; 'KILL-BUFFERS'
\r
4570 * DC.L KILBUF-12-NATWID
\r
4571 *KLBFS DC.L DOCOL,FIRST,LIT16
\r
4572 * DC.W 4 ; Want to make sure it's only four.
\r
4573 * DC.L ZERO,XDO ; It would be "cleaner" to let +BUF control the loop.
\r
4574 * DC.L DUP,KILBUF,PBUF,DROP,XLOOP
\r
4576 ** KLBFS DC.L *+NATWID
\r
4579 ** LDD FIRST+NATWID,PCR
\r
4584 ** BSR KILBUF+NATWID
\r
4587 ** ADDD BBUF+NATWID,PCR
\r
4588 ** ADDD BCTL+NATWID,PCR
\r
4594 ** LEAU NATWID*2,U
\r
4599 * Erase and mark all buffers empty.
\r
4600 * Standard method of discarding changes.
\r
4603 DC.B 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
\r
4605 * DC.L KLBFS-13-NATWID
\r
4606 DC.L UPDATE-7-NATWID
\r
4607 MTBUF DC.L DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
\r
4608 * DC.L FIRST,DUP,KILBUF,PBUF,DROP,DUP,KILBUF
\r
4609 * DC.L PBUF,DROP,DUP,KILBUF,PBUF,DROP,KILBUF
\r
4615 * Clear the current offset to the block numbers in the drive interface.
\r
4616 * The drives need to be re-architected.
\r
4617 * Would be cool to have RAM and ROM drives supported
\r
4618 * in addition to regular physical persistent store.
\r
4623 DC.L MTBUF-14-NATWID
\r
4624 DRZERO DC.L DOCOL,ZERO,OFSET,STORE
\r
4627 * ======>> 174 <<== system dependant word
\r
4629 * Set the current offset in the drive interface to reference the second drive.
\r
4630 * The hard-coded number in there needs to be in a table.
\r
4635 DC.L DRZERO-4-NATWID
\r
4636 *DRONE DC.L DOCOL,LIT,$07D0,OFSET,STORE
\r
4637 ; **** hard-codes the size of the disc !!!!
\r
4638 DRONE DC.L DOCOL,LIT,RAMDSZ,OFSET,STORE
\r
4641 * ######>> screen 59 <<
\r
4643 * ( n --- buffer )
\r
4644 * Get a free buffer,
\r
4645 * assign it to block n,
\r
4646 * return buffer address.
\r
4647 * Will free a buffer by writing it, if necessary.
\r
4648 * Does not actually read the block.
\r
4649 * A bug in the fig LRU algorithm, which I have not fixed,
\r
4650 * gives the PREVious buffer if USE gets set to PREVious.
\r
4651 * (The bug is that USE sometimes gets set to PREVious.)
\r
4652 * This bug sometimes causes sector moves to become sector fills.
\r
4656 DC.B 'BUFFE' ; 'BUFFER'
\r
4658 DC.L DRONE-4-NATWID
\r
4659 BUFFER DC.L DOCOL,USE,AT,DUP,TOR
\r
4660 BUFFR2 DC.L PBUF,ZBRAN
\r
4661 DC.L BUFFR2-*-NATWID
\r
4662 DC.L USE,STORE,R,AT,ZLESS
\r
4664 DC.L BUFFR3-*-NATWID
\r
4665 * DC.L R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
\r
4666 DC.L R,NATP,R,AT,UPDBIT,LNOT,AND,ZERO,RW
\r
4667 * BUFFR3 DC.L R,STORE,R,PREV,STORE,FROMR,TWOP
\r
4668 BUFFR3 DC.L R,STORE,R,PREV,STORE,FROMR,NATP
\r
4671 * ######>> screen 60 <<
\r
4673 * ( n --- buffer )
\r
4674 * Get BUFFER containing block n, relative to OFFSET.
\r
4675 * If block n is not in a buffer, bring it in.
\r
4676 * Returns buffer address.
\r
4679 DC.B 'BLOC' ; 'BLOCK'
\r
4681 DC.L BUFFER-7-NATWID
\r
4682 BLOCK DC.L DOCOL,OFSET,AT,PLUS,TOR
\r
4683 DC.L PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
\r
4684 DC.L BLOCK5-*-NATWID
\r
4685 BLOCK3 DC.L PBUF,ZEQU,ZBRAN
\r
4686 DC.L BLOCK4-*-NATWID
\r
4687 * DC.L DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
\r
4688 DC.L DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
\r
4689 BLOCK4 DC.L DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
\r
4690 DC.L BLOCK3-*-NATWID
\r
4691 DC.L DUP,PREV,STORE
\r
4692 * BLOCK5 DC.L FROMR,DROP,TWOP
\r
4693 BLOCK5 DC.L FROMR,DROP,NATP
\r
4696 * ######>> screen 61 <<
\r
4698 * ( line screen --- buffer C/L)
\r
4699 * Bring in the sector containing the specified line of the specified screen.
\r
4700 * Returns the buffer address and the width of the screen.
\r
4701 * Screen number is relative to OFFSET.
\r
4702 * The line number may be beyond screen 4,
\r
4703 * (LINE) will get the appropriate screen.
\r
4707 DC.B '(LINE' ; '(LINE)'
\r
4709 DC.L BLOCK-6-NATWID
\r
4710 PLINE DC.L DOCOL,TOR,LIT16
\r
4712 DC.L BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT16
\r
4717 * ( line screen --- )
\r
4718 * Print the line of the screen as found by (LINE), suppress trailing BLANKS.
\r
4721 DC.B '.LIN' ; '.LINE'
\r
4723 DC.L PLINE-7-NATWID
\r
4724 DLINE DC.L DOCOL,PLINE,DTRAIL,TYPE
\r
4729 * If WARNING is 0, print "MESSAGE #n";
\r
4730 * otherwise, print line n relative to screen 4,
\r
4731 * the line number may be negative.
\r
4732 * Uses .LINE, but counter-adjusts to be relative to the real drive 0.
\r
4733 * BUG: -DUP will cause this to reach farther into the stack than the error number
\r
4734 * when WARNING is set and err# is zero (can't find entry in dictionary).
\r
4737 DC.B 'MESSAG' ; 'MESSAGE'
\r
4739 DC.L DLINE-6-NATWID
\r
4740 MESS DC.L DOCOL,WARN,AT,ZBRAN
\r
4741 DC.L MESS3-*-NATWID
\r
4742 DC.L DDUP,ZBRAN ; -DUP here is a bug from the original 6800 model, at least.
\r
4743 DC.L MESS3-*-NATWID
\r
4746 DC.L OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
\r
4747 DC.L MESS4-*-NATWID
\r
4750 DC.B 'err # ' ; 'err # '
\r
4751 DC.B 0 ; hand align
\r
4757 * Begin interpretation of screen (block) n.
\r
4758 * See also ARROW, SEMIS, and NULL.
\r
4762 DC.B 'LOA' ; 'LOAD' : input:scr #
\r
4764 DC.L MESS-8-NATWID
\r
4765 LOAD DC.L DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
\r
4766 DC.L BSCR,STAR,BLK,STORE
\r
4767 DC.L INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
\r
4772 * Continue interpreting source code on the next screen.
\r
4777 DC.L LOAD-5-NATWID
\r
4778 ARROW DC.L DOCOL,QLOAD,ZERO,IN,STORE,BSCR
\r
4779 DC.L BLK,AT,OVER,MOD,SUB,BLK,PSTORE
\r
4784 * ######>> screen 63 <<
\r
4785 * The next clot of subroutines are machine dependent.
\r
4786 * PEMIT, PKEY, PQTER, and PCR (_P_arenthetic versions) are called by
\r
4787 * EMIT, KEY, QTERM, and CR, words 13 through 16 in the dictionary.
\r
4788 * This is all native CPU code.
\r
4790 * ATARI BIOS call parameters on _A7_ == SP. (Not PSP!)
\r
4791 * Defining for Atari ST BIOS:
\r
4792 * Atari BIOS messes with D0-D2/A0-A2.
\r
4793 * We do not know D0/D1/A0/A1 are safe to overwrite in our runtime.
\r
4795 * ======>> 185 << code for CR
\r
4796 * ( --- ) No stack effect.
\r
4797 * Output a CR/LF combo to the CONSOLE device
\r
4798 * using the Atari ST BIOS.
\r
4799 * Move this here to keep it in reach of short branch.
\r
4800 PCR MOVEM.L D1,-(SP) Don't destroy D1.
\r
4804 BSR.S PEMIT ; Don't rob PEMIT's return.
\r
4805 MOVEM.L (SP)+,D1 ; Restore D1
\r
4808 * ( --- ) No parameter stack effect.
\r
4809 * Assume volatile registers saved,
\r
4810 * Use Atari terminal emulation to turn the text cursor on.
\r
4811 PCURON MOVEM.L D1,-(SP) Don't destroy D1.
\r
4815 BSR.S PEMIT ; Don't rob PEMIT's return.
\r
4816 MOVEM.L (SP)+,D1 ; Restore D1
\r
4819 * ( --- ) No parameter stack effect.
\r
4820 * Assume volatile registers saved,
\r
4821 * Use Atari terminal emulation to turn the text cursor off.
\r
4822 PCROFF MOVEM.L D1,-(SP) Don't destroy D1.
\r
4826 BSR.S PEMIT ; Don't rob PEMIT's return.
\r
4827 MOVEM.L (SP)+,D1 ; Restore D1
\r
4830 * ======>> 182 << code for EMIT
\r
4831 * ( --- ) No parameter stack effect.
\r
4832 * Put one byte from D1 out on the CONSOLE device
\r
4833 * using Atari ST BIOS.
\r
4834 PEMIT MOVEM.L D0/D1/D2/A0/A1/A2,-(PSP) ; Save volatile registers, D0 lowest.
\r
4835 LEA -6(SP),SP ; allocate BIOS parameter space
\r
4836 PEMITW MOVE.W #2,2(SP) ; console device
\r
4837 MOVE.W #8,(SP) ; bcostat
\r
4838 TRAP #13 ; BIOS call
\r
4839 TST.L D0 ; not really necessary?
\r
4840 BEQ.S PEMITW ; wait for CONSOLE out ready
\r
4841 MOVE.W NATWID+NATWID/2(PSP),4(SP) ; low word of PSP top is character to output
\r
4842 MOVE.W #2,2(SP) ; console device
\r
4843 MOVE.W #3,(SP) ; bconout
\r
4844 TRAP #13 ; BIOS call
\r
4845 LEA 6(SP),SP ; deallocate BIOS workspace
\r
4846 MOVEM.L (PSP)+,D0/D1/D2/A0/A1/A2 ; Restore volatile registers and parameter stack.
\r
4849 * ======>> 183 << code for KEY
\r
4850 * ( --- ) No parameter stack effect.
\r
4851 * Wait for one keypress from the CONSOLE device
\r
4852 * and return the character code for the key pressed in D1
\r
4853 * using Atari ST BIOS.
\r
4854 PKEY MOVEM.L D0/D2/A0/A1/A2,-(PSP) ; Save volatile registers.
\r
4855 BSR.S PCURON ; Show the cursor
\r
4856 PKEYG MOVE.W #2,-(SP) ; console device
\r
4857 MOVE.W #2,-(SP) ; bconin
\r
4858 TRAP #13 ; BIOS call
\r
4859 LEA 4(SP),SP ; clean up stack
\r
4860 PKEYT BSR.S PCROFF
\r
4861 CMP.B #3,D0 ; CTL-C? (Atari BIOS emulates a nice terminal.)
\r
4863 OR.L #$FFFFFF00,D0 ; set the N flag
\r
4864 PKEYX MOVE.L D0,D1 ; KEY and QTERM expect it in D1.
\r
4865 MOVEM.L (PSP)+,D0/D2/A0/A1/A2 ; Restore registers without touching flags.
\r
4868 * ######>> screen 64 <<
\r
4869 * ======>> 184 << code for ?TERMINAL
\r
4870 * ( --- ) No stack effect.
\r
4871 * Check for break key on the CONSOLE device without waiting
\r
4872 * using Atari ST BIOS.
\r
4873 PQTER MOVEM.L D0/D2/A0/A1/A2,-(PSP) ; Save D2.
\r
4874 MOVE.W #2,-(SP) ; console device
\r
4875 MOVE.W #1,-(SP) ; bconstat
\r
4876 TRAP #13 ; BIOS call
\r
4877 LEA 4(SP),SP ; clean up stack, don't wait
\r
4878 TST.L D0 ; Got a key?
\r
4879 BMI.S PKEYG ; Get the key, but D2 already saved.
\r
4880 BRA.S PKEYX ; Rob PKEY's tail and restore.
\r
4882 * ######>> screen 66 <<
\r
4885 * Query the disk, I suppose.
\r
4886 * Not sure what the model had in mind for this stub.
\r
4889 DC.B '?DIS' ; '?DISC'
\r
4891 DC.L ARROW-4-NATWID
\r
4892 QDISC DC.L *+NATWID
\r
4895 * ######>> screen 67 <<
\r
4898 * Write one block of data to disk.
\r
4899 * Parameters unspecified in model. Stub in model.
\r
4902 DC.B 'BLOCK-WRIT' ; 'BLOCK-WRITE'
\r
4904 DC.L QDISC-6-NATWID
\r
4905 BWRITE DC.L *+NATWID
\r
4908 * ######>> screen 68 <<
\r
4911 * Read one block of data from disk.
\r
4912 * Parameters unspecified in model. Stub in model.
\r
4916 DC.B 'BLOCK-REA' ; 'BLOCK-READ'
\r
4918 DC.L BWRITE-12-NATWID
\r
4919 BREAD DC.L *+NATWID
\r
4922 *The next 3 words are written to create a substitute for disc
\r
4923 * mass memory,located between MASSLO & MASSHI in ram --
\r
4924 * ($3210 and $3fff in the 6800 model).
\r
4925 * ======>> 190.1 <<
\r
4931 DC.L BREAD-11-NATWID
\r
4933 DC.L MEMEND a system dependent equate at front
\r
4935 * ======>> 190.2 <<
\r
4943 DC.L MEMTOP ( $3FFF or $7FFF in this version )
\r
4945 * ######>> screen 69 <<
\r
4947 * ( buffer sector f --- )
\r
4948 * Read or Write the specified (absolute -- ignores OFFSET) sector
\r
4949 * from or to the specified buffer.
\r
4950 * A zero flag specifies write,
\r
4951 * non-zero specifies read.
\r
4952 * Sector is an unsigned integer,
\r
4953 * buffer is the buffer's address.
\r
4954 * Will need to use the CoCo ROM disk routines.
\r
4955 * For now, provides a virtual disk in RAM.
\r
4961 RW DC.L DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
\r
4965 DC.B ' Range ?' ; ' Range ?'
\r
4966 DC.B 0 ; hand align
\r
4968 RW2 DC.L FROMR,ZBRAN
\r
4971 RW3 DC.L BBUF,CMOVE
\r
4976 * LDY $C006 control table
\r
4977 * LDX #DROFFS+7 ; This is BIF's table of drive sizes.
\r
4979 * RWD SUBD ,X++ sectors
\r
4981 * BVC RWR table end?
\r
4985 * RWR ADDD ,--X back one
\r
4988 * LDD #18 sectors/track
\r
4998 * PULS D table entry
\r
5004 * LDB #2 coco READ
\r
5011 * JSR [$C004] ROM handles timeout
\r
5012 * PULS Y,U,DP if IRQ enabled
\r
5015 * LDB 6,X coco status
\r
5027 * ######>> screen 72 <<
\r
5029 * ( --- ) compiling P
\r
5030 * ( --- adr ) interpreting
\r
5031 * { ' name } input
\r
5032 * Parse a symbol name from input and search the dictionary for it, per -FIND;
\r
5033 * compile the address as a literal if compiling,
\r
5034 * otherwise just push it.
\r
5036 DC.B $C1 ; immediate
\r
5037 DC.B "'"|$80 ; ' ( tick )
\r
5039 TICK DC.L DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
\r
5043 * ( --- ) { FORGET name } input
\r
5044 * Parse out name of definition to FORGET to, -DFIND it,
\r
5045 * then lop it and everything that follows out of the dictionary.
\r
5046 * In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
\r
5050 DC.B 'FORGE' ; 'FORGET'
\r
5052 DC.L TICK-2-NATWID
\r
5053 FORGET DC.L DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT16
\r
5055 DC.L QERR,TICK,DUP,FENCE,AT,LESS,LIT16
\r
5057 DC.L QERR,DUP,ZERO,PORIG,GREAT,LIT16
\r
5059 DC.L QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
\r
5062 * ######>> screen 73 <<
\r
5065 * Calculate a back reference from HERE and compile it.
\r
5069 DC.B 'BAC' ; 'BACK'
\r
5071 DC.L FORGET-7-NATWID
\r
5072 * BACK DC.L DOCOL,HERE,SUB,COMMA
\r
5073 BACK DC.L DOCOL,HERE,NATP,SUB,COMMA
\r
5078 * typical use: BEGIN code-loop test UNTIL
\r
5079 * typical use: BEGIN code-loop AGAIN
\r
5080 * typical use: BEGIN code-loop test WHILE code-true REPEAT
\r
5081 * ( --- adr n ) compile time P,C
\r
5082 * Push HERE for BACK reference for general (non-counting) loops,
\r
5083 * with BEGIN construct flag.
\r
5084 * A better flag: $4245 (ASCII for 'BE').
\r
5087 DC.B 'BEGI' ; 'BEGIN'
\r
5089 DC.L BACK-5-NATWID
\r
5090 BEGIN DC.L DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
\r
5095 * typical use: test IF code-true ELSE code-false ENDIF
\r
5096 * ENDIF is just a sort of intersection piece,
\r
5097 * marking where execution resumes after both branches.
\r
5098 * ( adr n --- ) compile time
\r
5099 * Check the mark and resolve the IF.
\r
5100 * A better flag: $4846 (ASCII for 'IF').
\r
5103 DC.B 'ENDI' ; 'ENDIF'
\r
5105 DC.L BEGIN-6-NATWID
\r
5106 ENDIF DC.L DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
\r
5107 * DC.L OVER,SUB,SWAP,STORE
\r
5108 DC.L OVER,NATP,SUB,SWAP,STORE
\r
5113 * typical use: test IF code-true ELSE code-false ENDIF
\r
5115 * Alias for ENDIF .
\r
5119 DC.B 'THE' ; 'THEN'
\r
5121 DC.L ENDIF-6-NATWID
\r
5122 THEN DC.L DOCOL,ENDIF
\r
5126 * ( limit index --- ) runtime
\r
5127 * typical use: DO code-loop LOOP
\r
5128 * typical use: DO code-loop increment +LOOP
\r
5129 * Counted loop, index is initial value of index.
\r
5130 * Will loop until index equals (positive going)
\r
5131 * or passes (negative going) limit.
\r
5132 * ( --- adr n ) compile time P,C
\r
5133 * Compile (DO), push HERE for BACK reference,
\r
5134 * and push DO control construct flag.
\r
5135 * A better flag: $444F (ASCII for 'DO').
\r
5141 DC.L THEN-5-NATWID
\r
5142 DO DC.L DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
\r
5147 * typical use: DO code-loop LOOP
\r
5148 * Increments the index by one and branches back to beginning of loop.
\r
5149 * Will loop until index equals limit.
\r
5150 * ( adr n --- ) compile time P,C
\r
5151 * Check the mark and compile (LOOP), fill in BACK reference.
\r
5152 * A better flag: $444F (ASCII for 'DO').
\r
5156 DC.B 'LOO' ; 'LOOP'
\r
5159 LOOP DC.L DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
\r
5163 * ( n --- ) runtime
\r
5164 * typical use: DO code-loop increment +LOOP
\r
5165 * Increments the index by n and branches back to beginning of loop.
\r
5166 * Will loop until index equals (positive going)
\r
5167 * or passes (negative going) limit.
\r
5168 * ( adr n --- ) compile time P,C
\r
5169 * Check the mark and compile (+LOOP), fill in BACK reference.
\r
5170 * A better flag: $444F (ASCII for 'DO').
\r
5173 DC.B '+LOO' ; '+LOOP'
\r
5175 DC.L LOOP-5-NATWID
\r
5176 PLOOP DC.L DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
\r
5180 * ( n --- ) runtime
\r
5181 * typical use: BEGIN code-loop test UNTIL
\r
5182 * Will loop until UNTIL tests true.
\r
5183 * ( adr n --- ) compile time P,C
\r
5184 * Check the mark and compile (0BRANCH), fill in BACK reference.
\r
5185 * A better flag: $4245 (ASCII for 'BE').
\r
5188 DC.B 'UNTI' ; 'UNTIL' : ( same as END )
\r
5190 DC.L PLOOP-6-NATWID
\r
5191 UNTIL DC.L DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
\r
5194 * ######>> screen 74 <<
\r
5196 * ( n --- ) runtime
\r
5197 * typical use: BEGIN code-loop test END
\r
5199 * Alias for UNTIL .
\r
5204 DC.L UNTIL-6-NATWID
\r
5205 END DC.L DOCOL,UNTIL
\r
5210 * typical use: BEGIN code-loop AGAIN
\r
5211 * Will loop forever
\r
5212 * (or until something uses R> DROP to force the current definition to die,
\r
5213 * or perhaps ABORT or ERROR or some such other drastic means stops things).
\r
5214 * ( adr n --- ) compile time P,C
\r
5215 * Check the mark and compile (0BRANCH), fill in BACK reference.
\r
5216 * A better flag: $4245 (ASCII for 'BE').
\r
5219 DC.B 'AGAI' ; 'AGAIN'
\r
5222 AGAIN DC.L DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
\r
5227 * typical use: BEGIN code-loop test WHILE code-true REPEAT
\r
5228 * Will loop until WHILE tests false, skipping code-true on end.
\r
5229 * REPEAT marks where execution resumes after the WHILE find a false flag.
\r
5230 * ( aadr1 n1 adr2 n2 --- ) compile time P,C
\r
5231 * Check the marks for WHILE and BEGIN,
\r
5232 * compile BRANCH and BACK fill adr1 reference,
\r
5233 * FILL-IN 0BRANCH reference at adr2.
\r
5234 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
\r
5238 DC.B 'REPEA' ; 'REPEAT'
\r
5240 DC.L AGAIN-6-NATWID
\r
5241 REPEAT DC.L DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
\r
5242 DC.L TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
\r
5246 * ( n --- ) runtime
\r
5247 * typical use: test IF code-true ELSE code-false ENDIF
\r
5248 * Will pass execution to the true part on a true flag
\r
5249 * and to the false part on a false flag.
\r
5250 * ( --- adr n ) compile time P,C
\r
5251 * Compile a 0BRANCH and dummy offset
\r
5252 * and push IF reference to fill in and
\r
5253 * IF control construct flag.
\r
5254 * A better flag: $4946 (ASCII for 'IF').
\r
5260 DC.L REPEAT-7-NATWID
\r
5261 IF DC.L DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
\r
5266 * typical use: test IF code-true ELSE code-false ENDIF
\r
5267 * ELSE is just a sort of intersection piece,
\r
5268 * marking where execution resumes on a false branch.
\r
5269 * ( adr1 n --- adr2 n ) compile time P,C
\r
5270 * Check the marks,
\r
5271 * compile BRANCH with dummy offset,
\r
5272 * resolve IF reference,
\r
5273 * and leave reference to BRANCH for ELSE.
\r
5274 * A better flag: $4946 (ASCII for 'IF').
\r
5278 DC.B 'ELS' ; 'ELSE'
\r
5281 ELSE DC.L DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
\r
5282 DC.L ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
\r
5286 * ( n --- ) runtime
\r
5287 * typical use: BEGIN code-loop test WHILE code-true REPEAT
\r
5288 * Will loop until WHILE tests false, skipping code-true on end.
\r
5289 * ( --- adr n ) compile time P,C
\r
5290 * Compile 0BRANCH with dummy offset (using IF),
\r
5291 * push WHILE reference.
\r
5292 * BEGIN flag will sit underneath this.
\r
5293 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
\r
5296 DC.B 'WHIL' ; 'WHILE'
\r
5298 DC.L ELSE-5-NATWID
\r
5299 WHILE DC.L DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
\r
5304 * ######>> screen 75 <<
\r
5307 * EMIT count spaces, for non-zero, non-negative counts.
\r
5311 DC.B 'SPACE' ; 'SPACES'
\r
5313 DC.L WHILE-6-NATWID
\r
5314 SPACES DC.L DOCOL,ZERO,MAX,DDUP,ZBRAN
\r
5315 DC.L SPACE3-*-NATWID
\r
5317 SPACE2 DC.L SPACE,XLOOP
\r
5318 DC.L SPACE2-*-NATWID
\r
5323 * Initialize HLD for converting a double integer.
\r
5324 * Stores the PAD address in HLD.
\r
5330 DC.L SPACES-7-NATWID
\r
5331 BDIGS DC.L DOCOL,PAD,HLD,STORE
\r
5335 * ( d --- string length )
\r
5336 * Terminate numeric conversion,
\r
5337 * drop the number being converted,
\r
5338 * leave the address of the conversion string and the length, ready for TYPE.
\r
5344 DC.L BDIGS-3-NATWID
\r
5345 EDIGS DC.L DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
\r
5350 * Put sign of n (as a flag) at the head of the conversion string.
\r
5351 * Drop the sign flag.
\r
5355 DC.B 'SIG' ; 'SIGN'
\r
5357 DC.L EDIGS-3-NATWID
\r
5358 SIGN DC.L DOCOL,ROT,ZLESS,ZBRAN
\r
5359 DC.L SIGN2-*-NATWID
\r
5366 * ( d --- d/base )
\r
5367 * Generate next most significant digit in the conversion BASE,
\r
5368 * putting the digit at the head of the conversion string.
\r
5372 DC.L SIGN-5-NATWID
\r
5373 DIG DC.L DOCOL,BASE,AT,MSMOD,ROT,LIT16
\r
5375 DC.L OVER,LESS,ZBRAN
\r
5376 DC.L DIG2-*-NATWID
\r
5381 DC.W "0" ; ascii zero
\r
5387 * Convert d to a numeric string using # until the result is zero.
\r
5388 * Leave the double result on the stack for #> to drop.
\r
5396 DIGS2 DC.L DIG,OVER,OVER,OR,ZEQU,ZBRAN
\r
5397 DC.L DIGS2-*-NATWID
\r
5400 * ######>> screen 76 <<
\r
5403 * Print n on the output device in the current conversion base,
\r
5405 * right aligned in a field at least width wide.
\r
5411 DC.L DIGS-3-NATWID
\r
5412 DOTR DC.L DOCOL,TOR,STOD,FROMR,DDOTR
\r
5417 * Print d on the output device in the current conversion base,
\r
5419 * right aligned in a field at least width wide.
\r
5424 DC.L DOTR-3-NATWID
\r
5425 DDOTR DC.L DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
\r
5426 DC.L EDIGS,FROMR,OVER,SUB,SPACES,TYPE
\r
5431 * Print d on the output device in the current conversion base,
\r
5433 * in free format with trailing space.
\r
5439 DC.L DDOTR-4-NATWID
\r
5440 DDOT DC.L DOCOL,ZERO,DDOTR,SPACE
\r
5445 * Print n on the output device in the current conversion base,
\r
5447 * in free format with trailing space.
\r
5451 DC.L DDOT-3-NATWID
\r
5452 *DOT DC.L DOCOL,STOD,DDOT
\r
5453 DOT DC.L DOCOL,BREAK,STOD,DDOT ; DBG *****
\r
5458 * Print signed word at adr, per DOT.
\r
5463 QUEST DC.L DOCOL,AT,DOT
\r
5468 * ######>> screen 77 <<
\r
5471 * Print out screen n as a field of ASCII,
\r
5472 * with line numbers in decimal.
\r
5473 * Needs a console more than 70 characters wide.
\r
5477 DC.B 'LIS' ; 'LIST'
\r
5479 DC.L QUEST-2-NATWID
\r
5480 LIST DC.L DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
\r
5483 DC.B 0 ; hand align
\r
5487 LIST2 DC.L CR,I,THREE
\r
5488 DC.L DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
\r
5489 DC.L LIST2-*-NATWID
\r
5494 * ( start end --- )
\r
5495 * Print comment lines (line 0, and line 1 if C/L < 41) of screens
\r
5496 * from start to end.
\r
5497 * Needs a console more than 70 characters wide.
\r
5500 DC.B 'INDE' ; 'INDEX'
\r
5502 DC.L LIST-5-NATWID
\r
5503 INDEX DC.L DOCOL,CR,ONEP,SWAP,XDO
\r
5504 INDEX2 DC.L CR,I,THREE
\r
5505 DC.L DOTR,SPACE,ZERO,I,DLINE
\r
5507 DC.L INDEX3-*-NATWID
\r
5510 DC.L INDEX2-*-NATWID
\r
5515 * List a printer page full of screens.
\r
5516 * Line and screen number are in current base.
\r
5517 * Needs a console more than 70 characters wide.
\r
5520 DC.B 'TRIA' ; 'TRIAD'
\r
5522 DC.L INDEX-6-NATWID
\r
5523 TRIAD DC.L DOCOL,THREE,SLASH,THREE,STAR
\r
5524 DC.L THREE,OVER,PLUS,SWAP,XDO
\r
5526 DC.L LIST,QTERM,ZBRAN
\r
5527 DC.L TRIAD3-*-NATWID
\r
5530 DC.L TRIAD2-*-NATWID
\r
5536 * ######>> screen 78 <<
\r
5539 * List the definitions in the current vocabulary.
\r
5540 * Expects to output to full-width screen of printer, not a 32- or 40- column screen
\r
5543 DC.B 'VLIS' ; 'VLIST'
\r
5545 DC.L TRIAD-6-NATWID
\r
5547 * DC.L TRON ; DBG ******
\r
5548 * DC.L LIT16 ; should not be hard coded.
\r
5551 DC.L OUT,STORE,CONTXT,AT,AT
\r
5552 VLIST1 DC.L OUT,AT,COLUMS,AT
\r
5553 * DC.L LIT16 ; Should not be hard coded.
\r
5556 DC.L SUB,GREAT,ZBRAN
\r
5557 DC.L VLIST2-*-NATWID
\r
5558 DC.L CR,ZERO,OUT,STORE
\r
5559 VLIST2 DC.L DUP,IDDOT
\r
5560 * DC.L BREAK ; dbg *****
\r
5561 DC.L SPACE,SPACE,PFA,LFA,AT
\r
5562 DC.L DUP,ZEQU,QTERM,OR,ZBRAN
\r
5563 DC.L VLIST1-*-NATWID
\r
5565 * DC.L TROFF,BREAK ; DBG ********
\r
5568 * Need some utility stuff that isn't in the fig FORTH:
\r
5570 * Emit dot if c is less than blank, else emit c
\r
5573 DC.B 'BEMI' ; 'BEMIT'
\r
5575 DC.L VLIST-6-NATWID
\r
5577 DC.L DUP,BL,LESS,ZBRAN
\r
5578 DC.L BEMITO-*-NATWID
\r
5585 * Output n in hexadecimal with field width.
\r
5590 DC.L BEMIT-6-NATWID
\r
5592 DC.L BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
\r
5595 BYTPLN EQU 16 ; bytes to dump per line
\r
5597 * Dump a line of 16 bytes in memory, in hex and as characters.
\r
5600 DC.B 'BLIN' ; 'BLINE'
\r
5602 DC.L XDOTR-4-NATWID
\r
5606 DC.L PLUS,OVER,XDO
\r
5607 BLINEX DC.L I,CAT,THREE,XDOTR,XLOOP
\r
5608 DC.L BLINEX-*-NATWID
\r
5612 DC.L PLUS,SWAP,XDO
\r
5613 BLINEC DC.L I,CAT,BEMIT,XLOOP
\r
5614 DC.L BLINEC-*-NATWID
\r
5618 * Dump memory via BLINE from adr to ct (ceiling BYTPLN) bytes.
\r
5621 DC.B 'BDUM' ; 'BDUMP'
\r
5623 DC.L BLINE-6-NATWID
\r
5625 DC.L CR,OVER,PLUS,SWAP,XDO
\r
5626 BDUMPL DC.L I,LIT16
\r
5631 DC.L I,BLINE,CR,LIT16
\r
5634 DC.L BDUMPL-*-NATWID
\r
5639 * Place holder for triggering low-level debuggers (not in fig Forth).
\r
5642 DC.B 'BREA' ; 'BREAK'
\r
5644 DC.L BDUMP-6-NATWID
\r
5645 BREAK DC.L *+NATWID
\r
5646 BREAKF NOP ; set a low-level break in here
\r
5654 DC.B 'TROF' ; 'TROFF'
\r
5656 DC.L BREAK-6-NATWID
\r
5657 TROFF DC.L *+NATWID
\r
5658 CLR.W TRACEM-UORIG(UP)
\r
5664 DC.B 'TRO' ; 'TRON'
\r
5666 DC.L TROFF-6-NATWID
\r
5667 TRON DC.L *+NATWID
\r
5668 MOVE.W #1,TRACEM-UORIG(UP)
\r
5672 * NOOP NEXT a useful no-op
\r
5676 * Mostly for place holding (fig Forth).
\r
5680 DC.B 'NOO' ; 'NOOP'
\r
5682 DC.L TRON-5-NATWID
\r
5683 NOOP DC.L *+NATWID
\r
5688 * NOOP NEXT a useful no-op
\r
5689 ZZZZ DC.L 0,0,0,0,0,0,0,0 end of rom program
\r
5691 * About 10.3K in the dictionary image proper.
\r
5692 * This is not surprising, given that the 6809 image is about 6.9K.
\r
5693 * (The 6800 image is about 6.3K, if I remember right.)
\r
5694 * Since the image is mostly pointers, and pointers in the 68000 are 32 bits, not 16
\r
5695 * (since we don't want to limit ourselves to a 32K or so dictionary),
\r
5696 * the 68000 image should be something less than double the size of the 6809 or 6800 image.
\r
5703 * Build test lists here:
\r
5705 * DC.L LIT,$FEEDBEEF
\r
5711 * DC.L TESTNEXT-*-NATWID
\r
5723 * DC.L LIT,$DEEFEED
\r
5724 * DC.L LIT,$FEDDEBB
\r
5725 * DC.L SUB ; DEEFEED - FEDDEBB
\r
5727 * DC.L TESTNEXT-*-NATWID
\r
5730 * Here you can see some of the advantages and disadvantages of the inner interpreter loop,
\r
5731 * and of indirect threading.
\r
5732 * PTRACE saves and restores D0/D1/D2/A2 so it can use them.
\r
5733 * PEMIT will also save and restore D1/D2/A2 to protect them from the BIOS calls.
\r
5739 ADD.B #'A'-'9'-1,D1
\r
5753 ROL.L #4,D1 ; Grab the top four bits.
\r
5760 MOVEM.L D0/D1/D2/A2,-(SP)
\r
5767 MOVE.L NATWID(PSP),D1
\r
5777 MOVEM.L (SP)+,D0/D1/D2/A2
\r
5781 SUBQ #1,D2 ; for DBF count
\r
5782 PSTRL MOVE.B (A2)+,D1
\r
5789 LEA -2*NATWID(W),A2 ; back up to one past the mode byte.
\r
5790 TST.B -(A2) ; is it a mode byte?
\r
5791 BPL.S IXNAMX ; If this is not an end/mode byte, stop.
\r
5792 IXNAML TST.B -(A2) ; back up to the length byte
\r
5796 PNAMN0 DC.B $0E ; Not a dictionary entry, unadorned length,
\r
5797 DC.B '** NOT NAME **' ; and no tail char flag.
\r
5801 MOVE.B (A2)+,D2 ; Length byte, point to 1st character
\r
5803 AND.W #$1F,D2 ; extract length, word for DBF
\r
5804 BEQ.S PNAMEF ; all names have length, even NUL
\r
5807 PNAMEF LEA PNAMN0(PC),A2
\r
5808 MOVE.B (A2)+,D2 ; Error message has length (unadorned), too.
\r
5811 ZZZZ2 DC.L 0,0,0,0,0,0,0,0 ; "real" end of "rom" program
\r
5812 * ALIGN 256 ; want to do this, but the ATARI CNOP directive doesn't look standard to me.
\r
5814 * substitute for disc mass memory
\r
5815 *NBLK EQU 4 ; # of disc buffer blocks for virtual memory, must be defined before using
\r
5816 * Should NBLK be SCRSZ/RBLKSZ? maybe not.
\r
5817 * each block is RBLKSZ+SECTRL bytes in size,
\r
5818 * holding RBLKSZ characters
\r
5819 *RBLKSZ EQU 256 ; must be defined before using.
\r
5820 *SECTRL EQU 2*NATWID ; Currently held sector number, etc., define with rest
\r
5821 *BUFSZ EQU (RBLKSZ+SECTRL)*NBLK ; define with rest
\r
5824 * This is a really awkward place to define the disk buffer records.
\r
5826 * *BUG* SECTRL was magic-number hard-wired into several definitions.
\r
5827 * It will take a bit of work to ferret them out.
\r
5828 * It is too small, and it should not be hard-wired.
\r
5829 * RBLKSZ was also magic-number hard-wired into several definitions,
\r
5830 * will I find them all?
\r
5831 DC.L 0,0,0,0,0,0,0,0 ; put a little space between
\r
5832 * ALIGN 256 ; Again, I want to, but ...
\r
5835 *SCRSZ EQU 1024 ; must be defined before using
\r
5841 * Screens for drive 0, including error messages.
\r
5844 DC.B "000~000: ( Index to disk SCREENS SCREEN 0 ) " 0
\r
5845 DC.B "001~002: ( More Index lines ) " 1
\r
5846 DC.B "003~003: ( FIG Title page, FIG Copyright Notice ) " 2
\r
5847 DC.B "004~005: ( FIG ERROR MESSAGES ) " 3
\r
5848 DC.B "006~007: ( Custom Error Messages ) " 4
\r
5849 DC.B "008~???: ( Modifications, copyright notices ) " 5
\r
5850 DC.B "XXX~XXX: " 6
\r
5851 DC.B "XXX~XXX: " 7
\r
5852 DC.B "XXX~XXX: " 8
\r
5853 DC.B "XXX~XXX: " 9
\r
5854 DC.B "XXX~XXX: " 10
\r
5855 DC.B "XXX~XXX: " 11
\r
5856 DC.B "XXX~XXX: " 12
\r
5857 DC.B "XXX~XXX: " 13
\r
5858 DC.B "XXX~XXX: " 14
\r
5859 DC.B "XXX~XXX: " 15
\r
5861 DC.B "XXX~XXX: ( More index SCREEN 1 ) " 0
\r
5862 DC.B "XXX~XXX: " 1
\r
5863 DC.B "XXX~XXX: " 2
\r
5864 DC.B "XXX~XXX: " 3
\r
5865 DC.B "XXX~XXX: " 4
\r
5866 DC.B "XXX~XXX: " 5
\r
5867 DC.B "XXX~XXX: " 6
\r
5868 DC.B "XXX~XXX: " 7
\r
5869 DC.B "XXX~XXX: " 8
\r
5870 DC.B "XXX~XXX: " 9
\r
5871 DC.B "XXX~XXX: " 10
\r
5872 DC.B "XXX~XXX: " 11
\r
5873 DC.B "XXX~XXX: " 12
\r
5874 DC.B "XXX~XXX: " 13
\r
5875 DC.B "XXX~XXX: " 14
\r
5876 DC.B "XXX~XXX: " 15
\r
5878 DC.B "XXX~XXX: ( More index SCREEN 2 ) " 0
\r
5879 DC.B "XXX~XXX: " 1
\r
5880 DC.B "XXX~XXX: " 2
\r
5881 DC.B "XXX~XXX: " 3
\r
5882 DC.B "XXX~XXX: " 4
\r
5883 DC.B "XXX~XXX: " 5
\r
5884 DC.B "XXX~XXX: " 6
\r
5885 DC.B "XXX~XXX: " 7
\r
5886 DC.B "XXX~XXX: " 8
\r
5887 DC.B "XXX~XXX: " 9
\r
5888 DC.B "XXX~XXX: " 10
\r
5889 DC.B "XXX~XXX: " 11
\r
5890 DC.B "XXX~XXX: " 12
\r
5891 DC.B "XXX~XXX: " 13
\r
5892 DC.B "XXX~XXX: " 14
\r
5893 DC.B "XXX~XXX: " 15
\r
5895 DC.B "*************** Code from the fig-FORTH MODEL *************** " 0
\r
5897 DC.B " Through the courtesy of " 2
\r
5899 DC.B " FORTH INTEREST GROUP " 4
\r
5900 DC.B " P. O. BOX 1105 " 5
\r
5901 DC.B " SAN CARLOS, CA. 94070 " 6
\r
5904 DC.B " RELEASE 1 " 9
\r
5905 DC.B " WITH COMPILER SECURITY " 10
\r
5907 DC.B " VARIABLE LENGTH NAMES " 12
\r
5910 DC.B " Further distribution must include the above notice. " 15
\r
5912 DC.B "( ERROR MESSAGES ) " 0
\r
5913 DC.B "DATA STACK UNDERFLOW " 1
\r
5914 DC.B "DICTIONARY FULL " 2
\r
5915 DC.B "HAS INCORRECT ADDRESS MODE " 3
\r
5916 DC.B "ISN'T UNIQUE " 4
\r
5918 DC.B "DISC RANGE? " 6
\r
5919 DC.B "DATA STACK OVERFLOW " 7
\r
5920 DC.B "DISC ERROR! " 8
\r
5927 DC.B "FORTH INTEREST GROUP " 15
\r
5929 DC.B "( ERROR MESSAGES ) " 0
\r
5930 DC.B "COMPILATION ONLY, USE IN DEFINITION " 1
\r
5931 DC.B "EXECUTION ONLY " 2
\r
5932 DC.B "CONDITIONALS NOT PAIRED " 3
\r
5933 DC.B "DEFINITION NOT FINISHED " 4
\r
5934 DC.B "IN PROTECTED DICTIONARY " 5
\r
5935 DC.B "USE ONLY WHEN LOADING " 6
\r
5936 DC.B "OFF CURRENT EDITING SCREEN " 7
\r
5937 DC.B "DECLARE VOCABULARY " 8
\r
5944 DC.B "FORTH INTEREST GROUP " 15
\r
5946 DC.B "( MORE ERROR MESSAGES SCREEN 6 ) " 0
\r
5964 DC.B " ( MORE ERROR MESSAGES SCREEN 7 ) " 0
\r
5982 DC.B " ( TEXT, LINE WFR-79MAY01 ) " 0
\r
5983 DC.B " FORTH DEFINITIONS HEX " 1
\r
5985 DC.B " 64 CONSTANT C/L " 3
\r
5987 DC.B " : TEXT ( ACCEPT FOLLOWING TEXT TO PAD *) " 5
\r
5988 DC.B " HERE C/L 1+ BLANKS WORD HERE PAD C/L 1+ CMOVE ; " 6
\r
5990 DC.B " : LINE ( RELATIVE TO SCR, LEAVE ADDRESS OF LINE *) " 8
\r
5991 DC.B " DUP FFF0 AND 17 ?ERROR ( KEEP ON THIS SCREEN ) " 9
\r
5992 DC.B " SCR @ (LINE) DROP ; " 10
\r
6000 DC.B " ( More crude editing facilities. -- one byte characters ) " 0
\r
6002 DC.B " 0 VARIABLE LNEDBUF 62 ALLOT ( buffer for line editing ) " 2
\r
6004 DC.B " ( ns nl -- ) ( overwrite one line of the screen ) " 4
\r
6005 DC.B " : PUTLINE LNEDBUF 64 BLANKS ( just enough to write to disc ) " 5
\r
6006 DC.B " CR LNEDBUF 64 EXPECT CR ( just enough to write ) " 6
\r
6007 DC.B " SL2BB LNEDBUF SWAP 64 CMOVE UPDATE ; " 7
\r
6008 DC.B " ( Full screen editing requires keyboard control codes. ) " 8
\r
6126 RAMDSZ EQU VDR1-VDISK
\r
6139 * "end" of "usable ram" (If disc mass memory emulation is removed, actual end.)
\r
OSDN Git Service
