• R/O
  • HTTP
  • SSH
  • HTTPS

fig-forth-68000: Commit

Source code for fig-forth-68000


Commit MetaInfo

Revision53cacfcea34e60c6836554d6e3d1f17706a1e4f6 (tree)
Time2023-07-01 23:02:36
AuthorJoel Matthew Rees <joel.rees@gmai...>
CommiterJoel Matthew Rees

Log Message

Adding a README and another intermediate false step source file.

Change Summary

Incremental Difference

--- /dev/null
+++ b/README
@@ -0,0 +1,36 @@
1+Two relatively functional versions of fig-Forth for the 68000 exist in this repository:
2+
3+FIG68K.S is a straight adaptation of the fig 6800 model by Dave Lion, et. al.,
4+mapping the VM in the 6800 model to registers and instructions in the 68000
5+(via my previous not-quite functional adaptation to the 6809).
6+
7+FIG68KRT.S modifies the adaptaion to use a native 68000 subroutine call/return
8+in the inner interpreter, instead of the JMP NEXT mechanism of the straight model.
9+
10+Both of the above are stand-alone, and should be easily adapted to single-board
11+computers and such. Look at the memory map and the IO routines.
12+
13+Neither contain actual disk I/O, only including disk simulations of blocks of RAM.
14+Adding disk I/O really shouldn't be hard, however.
15+
16+The memory map used is restored to the map used in the 6800 model, backing out the
17+remapping I had attempted in the 6809 adaptation. (At this point, I still need to
18+check whether the modified memory map is the source of the bugs in the 6809
19+adaptation.)
20+
21+FIGRL68K.S and FIGSB68K.S were early false steps.
22+
23+FIG68KSB.S is another false step that goes partway through using subroutine calls
24+instead of pointers to thread the definitions. It's not the right step after
25+FIG68KRT.S, and has also been abandoned.
26+
27+fig58kts.s was sort of between FIG68KSB.S and FIG68KRT.S
28+
29+The 6800, 6801, and 6809 source files are provided for reference here, but will
30+not be kept up-to-date.
31+
32+I'm not sure whether I will proceed from here to flatten FIG68KRT.S (and probably
33+add the assembler), or proceed to convert BIF-6809 to the 68000.
34+
35+The license follows the MIT model license and is in each file itself.
36+
--- /dev/null
+++ b/fig68kts.s
@@ -0,0 +1,6172 @@
1+ OPT LIST,SYMTAB
2+ MACHINE MC68000
3+ OPT DEBUG
4+ OUTPUT
5+* fig-FORTH FOR 68000
6+* ASSEMBLY SOURCE LISTING
7+
8+* RELEASE 0
9+* JAN-FEB 2023
10+* WITH COMPILER SECURITY
11+* AND VARIABLE LENGTH NAMES
12+* Try again with literal subroutine substitution mode, one step at a time.
13+*
14+* Adapted by Joel Matthew Rees
15+* from fig-FORTH for 6800 (via buggy fig-FORTH for 6809) by Dave Lion, et. al.
16+
17+* This free/libre/open source publication is provided
18+* through the courtesy of:
19+* FORTH
20+* INTEREST
21+* GROUP
22+* fig
23+* and other interested parties.
24+
25+* Ancient address:
26+* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
27+* URL: http://www.forth.org
28+* Further distribution must include this notice.
29+ PAGE
30+ TTL Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
31+* OPT NOG,PAG
32+* filename fig-forth-hand68000.asm
33+* === FORTH-68000 {date} {time}
34+
35+
36+* Permission is hereby granted, free of charge, to any person obtaining a copy
37+* of this software and associated documentation files (the "Software"), to deal
38+* in the Software without restriction, including without limitation the rights
39+* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
40+* copies of the Software, and to permit persons to whom the Software is
41+* furnished to do so, subject to the following conditions:
42+*
43+* The above copyright notice and this permission notice shall be included in
44+* all copies or substantial portions of the Software.
45+
46+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
47+* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
48+* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
49+* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
50+* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
51+* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
52+* THE SOFTWARE.
53+*
54+* "Associated documentation" for this declaration of license
55+* shall be interpreted to include only the comments in this file,
56+* or, if the code is split into multiple files,
57+* all files containing the complete source.
58+*
59+* This is the MIT model license, as published by the Open Source Consortium,
60+* with associated documentation defined.
61+* It was chosen to reflect the spirit of the original
62+* terms of use, which used archaic legal terminology.
63+*
64+* Authors of the 6800 model:
65+* === Primary: Dave Lion,
66+* === with help from
67+* === Bob Smith,
68+* === LaFarr Stuart,
69+* === The Forth Interest Group
70+* === PO Box 1105
71+* === San Carlos, CA 94070
72+* === and
73+* === Unbounded Computing
74+* === 1134-K Aster Ave.
75+* === Sunnyvale, CA 94086
76+*
77+ PAGE
78+
79+*********
80+* NOTICE! the fig Forth model has problems,
81+* including known bugs and unknown,
82+* and including vulnerabilities.
83+*
84+* While it might be used to bootstrap more correct and secure systems,
85+* it should be primarily used for study, practice, and research.
86+*********
87+
88+* Some processor-specific stuff:
89+NATWID EQU 4 ; bytes per natural integer/pointer
90+* The assembler ought to have defined these, but I don't see them in the manual:
91+* User program condition codes:
92+F_CARY EQU $0001
93+F_OVER EQU $0002
94+F_ZERO EQU $0004
95+F_NEG EQU $0008
96+F_EXT EQU $0010
97+* System status flags (68000/68010/CPU32):
98+F_SYS EQU $2000
99+F_TRAC EQU $8000
100+* Ignoring the interrupt flags for now
101+*
102+* The original version was developed on an AMI EVK 300 PROTO
103+* system using an ACIA for the I/O.
104+* This version is developed targeting the Atar ST.
105+
106+* All terminal 1/0
107+* is done in three subroutines:
108+* PEMIT ( word # 182 )
109+* PKEY ( 183 )
110+* PQTERM ( 184 )
111+*
112+* The FORTH words for disc related I/O follow the model
113+* of the FORTH Interest Group, but have not yet been
114+* tested using a real disc.
115+*
116+* Addresses in the 6800 implementation reflect the fact that,
117+* on the development system, it was convenient to
118+* write-protect memory at hex 1000, and leave the first
119+* 4K bytes write-enabled. As a consequence, code from
120+* location $1000 to label ZZZZ could be put in ROM.
121+* Minor deviations from the model were made in the
122+* initialization and words ?STACK and FORGET
123+* in order to do this.
124+*
125+* Those definitions will be altered somewhat in this
126+* implementation for the 68000 -- Atari ST.
127+*
128+ PAGE
129+* MEMORY MAP for this approximately 128K system:
130+* ( arranged for systems with high-memory ROM/write-protect )
131+*
132+* Won't be using the ACIA directly, no need to define addresses.
133+* ACIAC EQU $XXXXXXXX the ACIA control address and
134+* ACIAD EQU ACIAC+1 data address for PROTO
135+*
136+* Moving the definitions of the memory area since the usual 68000 assemblers are
137+* so kind as to make sure that definitions dependent on negative offsets and such
138+* are not supported as ORG arguments, etc.
139+*
140+* These will be defined elsewhere:
141+*
142+* NBLK EQU 4 # of disc buffer blocks for virtual memory
143+* MEMEND EQU 132*NBLK+ENDofCODE end of ram
144+* each block is 132 bytes in size,
145+* holding 128 characters
146+*
147+* MEMTOP EQU $WAYupHIGH absolute end of all ram
148+* MEMORY MAP for this 16K system:
149+* ( positioned so that systems with 4k byte write-
150+* protected segments can write protect FORTH )
151+*
152+* addr. contents pointer init by
153+* **** ******************************* ******* ******
154+* MEMTOP HI
155+* substitute for disc mass memory
156+* MEMEND LO
157+* MEMEND-1
158+* 4 buffer sectors of VIRTUAL MEMORY
159+* ENDofCODE+1 FIRST
160+* >>>>>> memory from here up must be RAM <<<<<<
161+*
162+* ENDofCODE
163+* >>>>>>--------Two words to start RAMmable dictionary--------<<<<<<
164+*
165+* ~12k of romable "FORTH" <== IP ABORT
166+* <== W
167+* the VIRTUAL FORTH MACHINE
168+*
169+* ENTRY+4 <<< WARM START ENTRY >>>
170+* ENTRY <<< COLD START ENTRY >>>
171+*
172+* >>>>>> memory from here down must be RAM <<<<<<
173+* IRP RETURN STACK base <== RP RINIT
174+*
175+* SFTBND
176+* INPUT LINE BUFFER
177+* holds up to 132 characters
178+* and is scanned upward by IN
179+* starting at TIB
180+* ITIB <== IN TIB
181+* IPSP DATA STACK <== SP SP0,SINIT
182+* | grows downward from here
183+* v
184+* - -
185+* ^
186+* | DICTIONARY grows upward
187+*
188+* These two entries will be copied from the end of the "ROMmable" dictionary
189+* into the bottom of the "RAMmable" dictionary area to link the two parts together.
190+*
191+* end of ram-dictionary. <== DP DPINIT
192+* "TASK"
193+*
194+* "FORTH" ( a word ) <=, <== CONTEXT
195+* `==== CURRENT
196+* start of RAM dictionary area.
197+*
198+* RTDICT+(something) "FORTH" ( definition ) <=, <== CONTEXT
199+* `==== CURRENT
200+* RTDICT start of ram-dictionary.
201+*
202+* USERSP user #1 table of variables <= UP DPINIT
203+* --- No need for registers & pointers for the virtual machine
204+* No need for scratch area used by various words
205+* --- lowest address used by FORTH
206+* Linker/loader structures produced by assembler and linker
207+* CODEBEG
208+* >>>>>> memory from here down left alone <<<<<<
209+* >>>>>> so we can safely call ROM routines <<<<<<
210+*
211+* UNK don't care stuff, if anything
212+*
213+* $400
214+* EXCVCT 68000 exception vectors
215+* 0000==RSTVCT
216+
217+ PAGE
218+
219+* ORG $30000 ; Not on the Atari ST under EMUTOS.
220+
221+* Edit this according to the desired size for the dictionary.
222+RTDCSZ EQU 8*1024 ; Must be even on 68000. For now, keep total size under 32K.
223+
224+* This should be adjusted to the target:
225+* CODEBG EQU $800
226+CODEBG EQU * ; On the Atari ST, the assembler should determine this.
227+*
228+* per-task (per-user) tables
229+USERAL EQU 64*NATWID ; allocatable
230+USERCT EQU 4 ; maybe, someday?
231+*
232+* USERSP EQU * ; (task-local variable space, addressable by UP) ; NOPE!
233+USERSP EQU USERAL*USERCT ; (task-local variable space, addressable by UP)
234+* IUP EQU USERSP ; USERSZ*USERCT ; Nope!
235+* The per-user (or task-local) table definitions are moved to the end
236+* to avoid using BSS segments, because I don't know how well they are
237+* supported in various 68K assemblers.
238+
239+* This system is built for one "user", or task,
240+* but additional users (tasks) may be added
241+* by allocating additional user tables.
242+*
243+* Some of this stuff gets initialized during
244+* COLD start and WARM start:
245+* [ names correspond to FORTH words of similar (no X) name ]
246+*
247+* A few useful VM variables --
248+* Will be removed when they are no longer needed.
249+* All are replaced by 68000 registers.
250+
251+* The Atari apparently wants the beginning of the image to be a jump to the entry point.
252+* Put a jump around stuff here, anyway.
253+START:
254+* MOVE.L #ORIG-SURPRISE,D7
255+* SURPRISE:
256+* JMP (PC,D7) ; monku monku mutter mutter mumble mumble butsu butsu
257+ JMP ORIG ; In case the distance is greater than 32K.
258+* And this is why people don't understand true position independent coding.
259+RSRV DS.L 8
260+N DS.L 8 ; might be used as scratch if we really needed it.
261+
262+* These locations could be used by a TRACE routine :
263+TRLIM DS.W 1 ; the count for tracing without user intervention
264+TRACEM DS.W 1 ; non-zero = trace mode
265+BRKPT DS.L 1 ; the breakpoint address at which
266+* the program will go into trace mode
267+VECT DS.L 1 ; vector to machine code
268+* (only needed if the TRACE routine is resident)
269+
270+* Registers used by the FORTH virtual machine:
271+* Starting at $OOFO in the 6800, unneeded here:
272+*
273+* All of these are defined below, with explanation.
274+* W RMB NATWID ; the instruction register remembers IP.
275+* IP RMB NATWID ; the instruction pointer points to pointer to 6800 code
276+* RP RMB NATWID ; the return stack pointer
277+* PSP RMB NATWID ; the parameter stack pointer (Forth SP)
278+* UP RMB NATWID ; the pointer to base of current user's 'USER' table
279+* ( altered by a task switch )
280+*
281+GAP EQU *
282+ DS.B USERAL-(GAP-START)
283+*
284+UORIG DS.L 3 ; 3 reserved variables
285+XSPZER DS.L 1 ; initial top of data stack for this user
286+XRZERO DS.L 1 ; initial top of return stack
287+XTIB DS.L 1 ; start of terminal input buffer
288+XWIDTH DS.L 1 ; name field width ****** could be byte
289+XWARN DS.L 1 ; warning message mode (0 = no disc) ****** could be byte
290+XFENCE DS.L 1 ; fence for FORGET
291+XDICTP DS.L 1 ; dictionary pointer
292+XVOCL DS.L 1 ; vocabulary linking
293+XBLK DS.L 1 ; disc block being accessed
294+XIN DS.L 1 ; scan pointer into the block ****** could be 16-bit
295+XOUT DS.L 1 ; cursor position ****** could be 16-bit
296+XSCR DS.L 1 ; disc screen being accessed ( O=terminal )
297+XOFSET DS.L 1 ; disc sector offset for multi-disc
298+XCONT DS.L 1 ; last word in primary search vocabulary
299+XCURR DS.L 1 ; last word in extensible vocabulary
300+XSTATE DS.L 1 ; flag for 'interpret' or 'compile' modes ****** could be byte?
301+XBASE DS.L 1 ; number base for I/O numeric conversion ****** could be byte
302+XDPL DS.L 1 ; decimal point place ****** could be 16-bit
303+XFLD DS.L 1 ; conversion field ****** could be 16-bit
304+XCSP DS.L 1 ; current stack position, for compile checks
305+XRNUM DS.L 1 ; ****** could be 16-bit?
306+XHLD DS.L 1 ; ****** could be 16-bit?
307+XDELAY DS.L 1 ; carriage return delay count ****** could be byte
308+XCOLUM DS.L 1 ; carriage width ****** could be 16-bit
309+IOSTAT DS.L 1 ; last acia status from write/read ****** could be byte or 16-bit
310+*
311+* end of user table, start of (theoretical) common system variables
312+*
313+* These need to be moved to where they will be
314+* initialized globals in variable space, not in the USER table.
315+* Or, more accurately, need to be turned into monitored or semaphored resources.
316+XUSE DS.L 1
317+XPREV DS.L 1
318+ DS.L 2 ( spares )
319+*
320+XUCURR DS.L 1 ; user table current allocation
321+*
322+XDEF EQU *
323+ DS.B USERAL-(XDEF-UORIG) ; allocatable
324+*
325+*USERSZ EQU *-UORIG
326+ DS.B USERAL*(USERCT-1)
327+*
328+ PAGE
329+***** Need to come back to these later.
330+VOCFLG EQU $832020A0 ; flag (dummy) entry to switch vocabularies by.
331+* These things, up through the label 'REND', are overwritten
332+* at time of cold load and should have the same contents
333+* as shown here:
334+*
335+ EVEN
336+RBEG EQU *
337+ DC.B $C5 immediate
338+ DC.B 'FORT' ; 'FORTH'
339+ DC.B 'H'|$80
340+ DC.L NOOP-5-NATWID
341+FORTH: DC.L DODOES,DOVOC,VOCFLG,TASK-5-NATWID
342+ DC.L 0
343+*
344+ DC.B "Copyright 1979 Forth Interest Group, David Lion,"
345+ DC.B $0D
346+ DC.B "Parts Copyright 2019 Joel Matthew Rees"
347+ DC.B $0D
348+*
349+ EVEN
350+ DC.B 0
351+ DC.B $84
352+ DC.B 'TAS' ; 'TASK'
353+ DC.B 'K'|$80
354+ DC.L FORTH-6-NATWID
355+TASK: DC.L DOCOL,SEMIS
356+*
357+REND EQU * ( first empty location in dictionary )
358+RSIZE EQU *-RBEG ; So we can look at it.
359+ PAGE
360+***
361+*
362+* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
363+*
364+* IP points to the next FORTH VM instruction ( pre-increment mode )
365+IP EQUR A5 ; post-inc mode, as opposed to 6800 model.
366+* RP points to last return address pushed on return stack
367+RP EQUR A7 ; Yes, we are going to break with fig false traditions.
368+* PSP points to last item pushed on data (parameter) stack
369+PSP EQUR A6 ; SP is already defined as A7 on 68K.
370+* may conflict with using A6 as frame pointer? Not really.
371+* Note that 6800 S points one below last byte pushed. We don't have to do that.
372+*
373+* A5 must be IP when NEXT is entered (when using the inner loop).
374+*
375+* D0 handles all of what is A:B on 6801/6809.
376+*
377+* UP (could be DP on 6809) is the base of per-task ("user") variables.
378+UP EQUR A3
379+* (Be careful of the stray semantics of "user".)
380+*
381+* W (hardware X) is the pointer to the "code field" address of native CPU
382+* But W is now ephemeral, maybe in VEC, but always top of return stack at entry.
383+W EQUR A4
384+* Points to pointer to machine code to be executed for the definition
385+* of the dictionary word to be executed/currently executing.
386+* The following natural integer (word) begins any "parameter section"
387+* (body) -- similar to a "this" pointer, but not the same.
388+* It may be native CPU machine code, or it may be a global variable,
389+* or it may be a list of Forth definition words (addresses).
390+*
391+* Since we have it, give it a handle. The execute vector:
392+* (Only valid until used elsewhere.)
393+VEC EQUR A2
394+*
395+* A0 and A1 used as scratch indexes.
396+* D0 through D7 used as scratch registers.
397+* Some related routines (for example, LOOP) use D0 as a shared parameter.
398+*
399+* Except that I want to keep this close to the fig model:
400+** We've got the registers, might as well use 'em.
401+** Defined for the I-level loop variables:
402+* LUPLIM EQUR D5 ; limit was pushed first,
403+* LUPCT EQUR D4 ; then index/count
404+** J-level is on the return stack.
405+*
406+* ======
407+* This implementation uses the indirect subroutine architecture
408+* -- a postponed-push call that the 6800 model VM also uses
409+* to save code and time in leaf routines.
410+*
411+* It won't allow mixing assembly language directly into Forth word lists.
412+* ======
413+*
414+* boolean flags:
415+* 0 is false, anything else is true.
416+* Most places in this model that set a boolean flag set true as 1.
417+* This is in contrast to many models that set a boolean flag as -1.
418+*
419+***
420+
421+* The run-time dictionary allocation area begins here,
422+* initialized with the FORTH and TASK definitions that will be
423+* actually used.
424+
425+RTDICT DS.B RTDCSZ ; dictionary allocation space
426+*
427+PSPSPC EQU 256*NATWID ; for the parameter stack
428+ DS.B PSPSPC
429+SPBUMP EQU 4*NATWID
430+IPSP DS.L SPBUMP ; initial PSP below, bumper zone above
431+*
432+* Don't want terminal input and parameter underflow collisions
433+TIBSZ EQU 80 ; bytes of input buffer, must be even on 68000.
434+ITIB DS.B TIBSZ ; Also, must match terminal width. (Bad design.)
435+*
436+* *** This is quite clearly a vulnerability! ***
437+SFTBND EQU * ; (pseudo boundary between TIB and return stack)
438+*
439+RPSPAC EQU 128*NATWID ; for the return stack
440+ DS.B RPSPAC
441+RPBUMP EQU 4*NATWID
442+IRP DS.B RPBUMP ; initial RP below, bumper zone above
443+
444+ PAGE
445+* Expecting 8K to 12K for the kernel, because pointers are 4 bytes.
446+VMBASE EQU *
447+
448+* "ROMmable" init tables and pre-compiled dictionary
449+*
450+* The FORTH interpreter will be organized
451+* so that it can be in a ROM, or write-protected if desired,
452+* but right now we're just getting it running.
453+
454+* ######>> screen 3 <<
455+*
456+***************************
457+** C O L D E N T R Y **
458+***************************
459+*
460+ORIG NOP
461+ BRA.W CENT ; ROMmable dictionary size is less than 32K
462+***************************
463+** W A R M E N T R Y **
464+***************************
465+ NOP
466+ BRA.W WENT warm-start code, keeps current dictionary intact
467+
468+*
469+MAXNML EQU 32 ; max name length of words (symbols) in the dictionary
470+NMLMSK EQU MAXNML-1 ; MAXNML must be a power of 2.
471+******* startup parmeters **************************
472+*
473+ DC.L $68000,00000000 ; cpu & revision
474+ DC.L 0 ; topmost word in FORTH vocabulary
475+* BACKSP DC.L $7F ; backspace character for editing
476+BACKSP DC.L $08 ; backspace character for editing
477+UPINIT DC.L UORIG ; initial user area
478+SINIT DC.L IPSP ; initial top of data stack
479+RINIT DC.L IRP ; initial top of return stack
480+ DC.L ITIB ; terminal input buffer
481+IWIDTH DC.L MAXNML ; initial name field width
482+ DC.L 0 ; initial warning mode (0 = no disc)
483+FENCIN DC.L REND ; initial fence
484+DPINIT DC.L REND ; cold start value for DICTPT
485+BUFINT DC.L BUFBAS ; Start of the disk buffers area
486+VOCINT DC.L FORTH+4*NATWID
487+COLINT DC.L TIBSZ ; initial terminal carriage width
488+DELINT DC.L 4 ; initial carriage return delay
489+****************************************************
490+*
491+*
492+ PAGE
493+*
494+* ######>> screen 13 <<
495+* These are of questionable use anyway,
496+* and are too much trouble to use with native subroutine call anyway.
497+* POPD0X MOVE.L (PSP)+,D0 ; These may actually not end up being used.
498+* STD0X MOVE.L D0,(A0)
499+* BRA.S NEXT
500+* GETX MOVE.L (A0),D0
501+* PUSHD0 MOVE.L D0,-(PSP) ; fall through to NEXT
502+
503+* "NEXT" takes ?? cycles if TRACE is removed,
504+*
505+* and ?? cycles if trace is present and NOT tracing.
506+*
507+* = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
508+* =
509+* NEXT itself might just completely go away.
510+* About the only reason to keep it is to allow executing a list
511+* which allows a cheap TRACE routine.
512+*
513+* NEXT is a loop which implements the Forth VM.
514+* It basically cycles through calling the code out of code lists,
515+* one at a time.
516+* Using a native CPU return for this uses a few extra cycles per call,
517+* compared to simply jumping to each definition and jumping back
518+* to the known beginning of the loop,
519+* but the loop itself is really only there for convenience,
520+* in the first place.
521+*
522+* This implementation uses native subroutine threading,
523+* still leaving a low wall between Forth VM code and non-Forth VM code.
524+*
525+NEXT: ; IP is a register.
526+NEXT2 MOVE.L (IP)+,VEC ; IP is list of code pointers, W is now ephemeral (top of R at entry)
527+* NEXT2 MOVE.L (IP)+,W ; get W which points to CFA of word to be done
528+* NEXT3 MOVE.L (W)+,VEC ; get characteristic address, point to Parameter Field.
529+* These NOPs can be patched at run-time to JMP TRACE =
530+* if a TRACE routine is available: =
531+* NOP =
532+* NOP =
533+* NOP =
534+* NOP =
535+* NOP =
536+ TST.W TRACEM-UORIG(UP) =
537+ BEQ.S NEXTJ =
538+ BSR.W PTRACE =
539+NEXTJ: JSR (VEC) =
540+ BRA.S NEXT =
541+* In other words, with the call and the NOP,
542+* there is room to patch the loop with a call to your TRACE
543+* routine, which you have to provide.
544+* =
545+* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
546+
547+ PAGE
548+*
549+* ======>> 1 <<
550+* ( --- n )
551+* Pushes the following natural width integer from the instruction stream
552+* as a literal, or immediate value.
553+*
554+* DC.L {OP}
555+* DC.L {OP}
556+* DC.L LIT
557+* DC.L LITERAL-TO-BE-PUSHED
558+* DC.L {OP}
559+*
560+* In native processor code, there should be a better way, use that instead.
561+* More specifically, DO NOT CALL THIS from assembly language code.
562+* (Note that there is no compile-only flag in the fig model.)
563+*
564+* See (FIND), or PFIND , for layout of the header format.
565+*
566+ EVEN
567+ DC.B $83
568+ DC.B 'LI' ; 'LIT' : NOTE: this is different from LITERAL
569+ DC.B 'T'|$80 ; character code for T, with high bit set.
570+ DC.L 0 ; link of zero to terminate dictionary scan
571+*LIT DC.L *+NATWID ; Note also that LIT is meaningless in native code.
572+* And, in fact, we simply should not be using it in this version.
573+* But if we were to use it, it would look like this:
574+LIT MOVE.L (IP)+,-(PSP)
575+ RTS
576+*
577+* ######>> screen 14 <<
578+* ======>> 2 <<
579+* ( --- n )
580+* Save a little dictionary space by pushing a half-width value as a full-width value.
581+* LIT8 won't really work with the 68000 because of alignment problems,
582+* but LIT16 will save a little space.
583+* Pushes the following 16-bit word from the instruction stream
584+* as a literal, or immediate value.
585+*
586+* If this is kept, it should have a header for TRACE to read.
587+* If the data bus is wider than a byte, consider whether you want to do this.
588+* Byte shaving like this is often counter-productive anyway.
589+* Changing the name to LIT16, hoping that will be more understandable.
590+* Also, see comments for LIT: DO NOT CALL THIS from assembly language code.
591+* (Note that there is no compile-only flag in the fig model.)
592+ EVEN
593+ DC.B $85
594+ DC.B 'LIT1' ; 'LIT16' ; half a LIT
595+ DC.B '6'|$80
596+ DC.L LIT-4-NATWID
597+*LIT16 DC.L *+NATWID ; (this was an invisible word, with no header)
598+* See comments on LIT. If we were to use it, it would look like this:
599+LIT16 CLR.L -(PSP) ; The fig model does not sign extend.
600+ MOVE.W (IP)+,NATWID/2(PSP)
601+ RTS
602+*
603+* ======>> 3 <<
604+* ( adr --- )
605+* Jump to address on stack. Used by the "outer" interpreter to
606+* interactively invoke routines.
607+* Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
608+ EVEN
609+ DC.B $87
610+ DC.B 'EXECUT' ; 'EXECUTE'
611+ DC.B 'E'|$80 ; $C5
612+ DC.L LIT16-6-NATWID
613+*EXEC DC.L *+NATWID
614+* MOVE.L (PSP)+,W ; Get the adr parameter.
615+* MOVE.L (W)+,VEC ; Or, pretend we are the inner interpreter
616+EXEC MOVE.L (PSP)+,VEC ; The adr parameter now points directly to code.
617+ JMP (VEC) ; tail return
618+*
619+*
620+* ######>> screen 15 <<
621+* ======>> 4 <<
622+*
623+* *** Since we are using NEXT (i-code lists), we are using BRANCH, et. al.
624+
625+* ( --- ) C
626+* Add the following word from the instruction stream to the
627+* instruction pointer (Y++). Causes a program branch in Forth code stream.
628+*
629+* In native processor code, there should be a better way, use that instead.
630+* More specifically, DO NOT CALL THIS from assembly language code.
631+* This is only for Forth code stream.
632+* Also, see comments for LIT.
633+ EVEN
634+ DC.B 0
635+ DC.B $86
636+ DC.B 'BRANC' ; 'BRANCH'
637+ DC.B 'H'|$80
638+ DC.L EXEC-8-NATWID
639+*BRAN DC.L *+NATWID
640+*ZBYES: ; No more code stealing needed here.
641+BRAN MOVE.L (IP)+,D1
642+ LEA (IP,D1.L),IP ; IP is postinc
643+ RTS
644+* ======>> 5 <<
645+* ( f --- ) C
646+* BRANCH if flag is zero.
647+*
648+* In native processor code, there should be a better way, use that instead.
649+* More specifically, DO NOT CALL THIS from assembly language code.
650+* This is only for Forth code stream.
651+* Also, see comments for LIT.
652+ EVEN
653+ DC.B $87
654+ DC.B '0BRANC' ; '0BRANCH'
655+ DC.B 'H'|$80
656+ DC.L BRAN-7-NATWID
657+*ZBRAN DC.L *+NATWID
658+* No more code stealing needed here.
659+*ZBRAN TST.L (PSP)+
660+* BNE.S ZBNO
661+*ZBYES MOVE.L (IP)+,D0
662+* LEA (IP,D0.L),IP ; IP is postinc
663+* RTS
664+*ZBNO LEA NATWID(IP),IP ; No branch.
665+* RTS
666+ZBRAN MOVE.L (IP)+,D1 ; Grab offset and update IP first.
667+ TST.L (PSP)+
668+ BNE.S ZBNO
669+ LEA (IP,D1.L),IP ; IP is postinc
670+ZBNO RTS
671+*
672+
673+* ######>> screen 16 <<
674+
675+* ======>> 6 <<
676+* ( --- ) ( limit index *** limit index+1) C
677+* ( limit index *** )
678+* Counting loop primitive. The counter and limit are the top two
679+* words on the return stack. If the updated index/counter does
680+* not exceed the limit, a branch occurs. If it does, the branch
681+* does not occur, and the index and limit are dropped from the
682+* return stack.
683+*
684+* Loop words share the counter increment via D0.
685+*
686+* In native processor code, there should be a better way, use that instead.
687+* More specifically, DO NOT CALL THIS from assembly language code.
688+* This is only for Forth code stream.
689+* Also, see comments for LIT.
690+* D0 and various code paths are shared with XPLOOP.
691+* Having to dodge the return address on the stack might be reason
692+* for loop variables in registers, but not yet.
693+LUPLIM EQU NATWID*2 ; limit was pushed first,
694+LUPCT EQU NATWID ; then index/count
695+*
696+ EVEN
697+ DC.B 0
698+ DC.B $86
699+ DC.B '(LOOP' ; '(LOOP)'
700+ DC.B ')'|$80
701+ DC.L ZBRAN-8-NATWID
702+*XLOOP DC.L *+NATWID
703+*XLOOP MOVEQ #1,D0 ; Loop counter and limit on return stack.
704+*XLOOPA ADD.L LUPCT(RP),D0
705+* MOVE.L D0,LUPCT(RP)
706+* CMP.L LUPLIM(RP),D0
707+* BMI.S ZBYES ; pseudo-signed-unsigned
708+*XLOOPN LEA NATWID(IP),IP
709+* MOVE.L (RP),A0 ; Get the return to NEXT.
710+* LEA LUPLIM+NATWID(RP),RP ; drop loop control variables
711+* JMP (A0)
712+XLOOP MOVEQ #1,D0 ; Loop counter and limit on return stack.
713+XLOOPA MOVE.L (IP)+,D1 ; Grab offset and update IP first.
714+ ADD.L LUPCT(RP),D0
715+ MOVE.L D0,LUPCT(RP)
716+ CMP.L LUPLIM(RP),D0
717+ BPL.S XLOOPN ; pseudo-signed-unsigned
718+XLOOPY LEA (IP,D1.L),IP ; IP is postinc
719+ RTS
720+XLOOPN MOVE.L (RP),A0 ; Get the return to NEXT.
721+ LEA LUPLIM+NATWID(RP),RP ; drop loop control variables, too
722+ JMP (A0)
723+*
724+* Old notes for loop counter and limit in registers:
725+* MOVEQ #1,D0 ; Loop counter and limit in registers.
726+* XLOOPA ADD.L D0,LUPCT
727+* CMP.L LUPLIM,LUPCT
728+* BMI.S ZBYES ; pseudo-signed-unsigned
729+* XLOOPN LEA NATWID(IP),IP
730+* MOVEM.L (RP)+,LUPLIM/LUPCT ; restore possible outer loop controls
731+* RTS
732+*
733+* ======>> 7 <<
734+* ( n --- ) ( limit index *** limit index+n ) C
735+* ( limit index *** )
736+* Loop with a variable increment. Terminates when the index
737+* crosses the boundary from one below the limit to the limit. A
738+* positive n will cause termination if the result index equals the
739+* limit. A negative n must cause the index to become less than
740+* the limit to cause loop termination.
741+*
742+* Note that the end conditions are not symmetric around zero.
743+*
744+* In native processor code, there should be a better way, use that instead.
745+* More specifically, DO NOT CALL THIS from assembly language code.
746+* This is only for Forth code stream.
747+* Also, see comments for LIT.
748+* D0 and various code paths are shared with XLOOP.
749+ EVEN
750+ DC.B $87
751+ DC.B '(+LOOP' ; '(+LOOP)'
752+ DC.B ')'|$80
753+ DC.L XLOOP-7-NATWID
754+*XPLOOP DC.L *+NATWID ; Loop counter and limit in registers.
755+XPLOOP MOVE.L (PSP)+,D0 ; inc val
756+ BPL.S XLOOPA ; Steal plain loop code for forward count.
757+ ADD.L LUPCT(RP),D0
758+ MOVE.L D0,LUPCT(RP)
759+ CMP.L LUPLIM(RP),D0
760+ BPL.S XLOOPY ; pseudo-signed-unsigned
761+ BRA.S XLOOPN ; Which path is less time-sensitive?
762+*
763+* Notes for loop counter and limit in registers:
764+* MOVE.L (PSP)+,D0 ; inc val
765+* BPL.S XLOOPA ; Steal plain loop code for forward count.
766+* ADD.L D0,LUPCT
767+* CMP.L LUPLIM,LUPCT
768+* BPL.S ZBYES ; pseudo-signed-unsigned
769+* BRA.S XLOOPN ; This path might be less time-sensitive.
770+*
771+* ######>> screen 17 <<
772+* ======>> 8 <<
773+* ( limit index --- ) ( *** outerlimit outerindex )
774+* Save whatever is in limit and index registers, Load the loop parameters.
775+* This would NOT be a synonym for D>R (2>R) if we were keeping the control variables in registers.
776+ EVEN
777+ DC.B 0
778+ DC.B $84
779+ DC.B '(DO' ; '(DO)'
780+ DC.B ')'|$80
781+ DC.L XPLOOP-8-NATWID
782+*XDO DC.L *+NATWID ; This is the RUNTIME DO, not the COMPILING DO
783+XDO MOVEM.L (PSP)+,D0/D1 ; MOVEM preserves the order.
784+ MOVE.L (RP)+,A0 ; get the return to NEXT out of the way.
785+ MOVEM.L D0/D1,-(RP) ; Control variables are now on the return stack.
786+ JMP (A0) ; Back to NEXT
787+*
788+* Notes for loop counter and limit in registers:
789+* MOVE.L (RP)+,A0 ; Get the reurn to NEXT out of the way
790+* MOVEM.L LUPLIM/LUPCT,-(RP) ; save possible outer loop limit and count
791+* MOVEM.L (PSP)+,LUPLIM/LUPCT ; limit must be higher register number to be deeper in stack.
792+* JMP (A0) ; Back to NEXT
793+*
794+* ======>> 9 <<
795+* ( --- index ) ( limit index *** limit index )
796+* Copy the loop index from the index register.
797+* This would NOT be a synonym for R if we were keeping the control variables in registers.
798+ EVEN
799+ DC.B $81
800+ DC.B 'I'|$80 ; I
801+ DC.L XDO-5-NATWID
802+*I DC.L *+NATWID
803+I MOVE.L LUPCT(RP),-(PSP) ; hide dodge in LUPCT
804+ RTS
805+*
806+* Notes for loop counter and limit in registers:
807+* MOVE.L LUPCT,-(PSP) ; nothing to dodge
808+* RTS
809+*
810+* ######>> screen 18 <<
811+* ======>> 10 <<
812+* ( c base --- false )
813+* ( c base --- n true )
814+* Translate C in base, yielding a translation valid flag.
815+* If the translation is not valid in the specified base,
816+* only the false flag is returned.
817+ EVEN
818+ DC.B $85
819+ DC.B 'DIGI' ; 'DIGIT'
820+ DC.B 'T'|$80
821+ DC.L I-2-NATWID
822+*DIGIT DC.L *+NATWID ; NOTE: legal input range is 0-9, A-Z
823+DIGIT MOVE.L NATWID(PSP),D0 ; Check the whole 32 bits.
824+ CMP.L #'Z',D0 ; Allow byte width from here.
825+ BHI.S DIGITN
826+ SUB.L #'0',D0 ; ascii zero
827+ BLO.S DIGITN ; IF LESS THAN '0', ILLEGAL
828+ CMP.B #9,D0
829+ BLS.S DIGITB ; IF '9' OR LESS
830+ SUB.B #'A'-('9'+1),D0 ; translate 'A' thru 'Z'
831+ CMP.B #$A,D0 ; between '9' and 'A'?
832+ BLO.S DIGITN ; if less than 'A'
833+DIGITB CMP.B NATWID-1(PSP),D0 ; Check the base.
834+ BHS.S DIGITN ; error if not less than the base
835+ MOVE.L D0,NATWID(PSP) ; Store converted digit. (High bytes known zero.)
836+ MOVE.L #1,(PSP) ; store valid flag
837+ RTS
838+DIGITN LEA NATWID(PSP),PSP ; pop base
839+ MOVE.L #0,(PSP) ; set not valid flag
840+ RTS
841+*
842+* ######>> screen 19 <<
843+*
844+* The word definition format in the dictionary:
845+*
846+* (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
847+*
848+* EVEN address alignment on 68K.
849+* Optional byte of zero for odd name fields on 68K.
850+* NFA (name field address):
851+* char-count + $80 Length of symbol name, flagged with high bit set.
852+* char 1 Characters of symbol name.
853+* char 2
854+* ...
855+* char n + $80 symbol termination flag (char set < 128 code points)
856+* LFA (link field address):
857+* link high byte \
858+* ... inner byte \___pointer to previous word in list
859+* ... inner byte / (List is combined allocation/dictionary list.)
860+* link low byte /
861+* The definition label is now the code field.
862+* Code follows immediately after the allocation link.
863+*
864+* When there is a parameter field, the code here is a branch to the characteristic code.
865+* Branches have different sizes, so PFA is no longer a constant offset from CFA.
866+* See TCFAB.
867+*
868+* When the definition contains only low-level code, the code is the parameter --
869+* PFA is CFA in the low-level code case.
870+*
871+* parameter fields -- Machine code for low-level native machine CPU code starts at label,
872+* " instruction list for high-level Forth code,
873+* " constant data for constants, pointers to per task variables,
874+* " space for variables, for global variables, etc.
875+*
876+* Note that CFA and PFA entanglement is now much tighter.
877+
878+* Definition attributes:
879+FIMMED EQU $40 ; Immediate word flag.
880+FSMUDG EQU $20 ; Smudged => definition not ready.
881+CTMASK EQU ($FF&(~($80|FIMMED))) ; For unmasking the length byte.
882+* Note that the SMUDGE bit is not masked out.
883+*
884+* But we really want more flags (Thinking for a new model, need one more byte):
885+* FCOMPI EQU $10 ; Compile-time-only.
886+* FASSEM EQU $08 ; Assembly-language code only.
887+* F4THLV EQU $04 ; Must not be called from assembly language code.
888+* These would require some significant adjustments to the model.
889+* We also want to put the low-level VM stuff in its own vocabulary, eventually.
890+*
891+* ======>> 11 <<
892+* (FIND) ( name vocptr --- locptr length true )
893+* ( name vocptr --- false )
894+* Search vocabulary for a symbol called name.
895+* name is a pointer to a high-bit bracketed string with length head.
896+* vocptr is a pointer to the NFA of the tail-end (LATEST) definition
897+* in the vocabulary to be searched.
898+* Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
899+* Use the stack and registers instead of temp area N.
900+PA0 EQU NATWID ; pointer to the length byte of name being searched against
901+YPA0 EQUR A2 ; ditto
902+PD EQU 0 ; pointer to NFA of dict word being checked
903+XPD EQUR A1 ; ditto
904+ EVEN
905+ DC.B 0
906+ DC.B $86
907+ DC.B '(FIND' ; '(FIND)'
908+ DC.B ')'|$80
909+ DC.L DIGIT-6-NATWID
910+*PFIND DC.L *+NATWID
911+PFIND MOVE.L PD(PSP),XPD ; Start in on the vocabulary (NFA).
912+PFNDLP MOVE.L PA0(PSP),YPA0 ; Point to the name to check against.
913+ MOVE.B (XPD)+,D1 ; get dict name length byte
914+ MOVE.B D1,D0 ; Save it in case it matches.
915+ AND.B #CTMASK,D1
916+ CMP.B (YPA0)+,D1 ; Compare lengths
917+ BNE.S PFNDUN
918+PFNDBR MOVE.B (XPD)+,D1 ; Is high bit of character in dictionary entry set?
919+ BPL.S PFNDCH
920+ AND.B #$7F,D1 ; Clear high bit in char from dictionary.
921+ CMP.B (YPA0)+,D1 ; Compare "last" characters.
922+ BEQ.S PFOUND ; Matches even if dictionary actual length is shorter.
923+PFNDLN MOVE.L (XPD)+,D0 ; Get previous link in vocabulary. (Note flag entry to switch vocabularies by.)
924+ MOVE.L D0,XPD ; On 68K, flags not in effect for MOVEA, TST not available, and this is what we wanted.
925+ BNE.S PFNDLP ; Continue if link not=0
926+*
927+* not found :
928+ LEA NATWID(PSP),PSP ; Return only false flag.
929+ CLR.L (PSP)
930+ RTS
931+*
932+PFNDCH CMP.B (YPA0)+,D1 ; Compare characters.
933+ BEQ.S PFNDBR
934+PFNDUN:
935+PFNDSC MOVE.B (XPD)+,D1 ; scan forward to end of this name in dictionary
936+ BPL.S PFNDSC
937+ BRA.S PFNDLN
938+*
939+* found :
940+*
941+PFOUND LEA 2*NATWID(XPD),XPD ; point to parameter field
942+ MOVE.L XPD,NATWID(PSP)
943+ CLR.L D1 ; make sure count is valid
944+ MOVE.B D0,D1
945+ MOVE.L D1,(PSP)
946+ MOVEQ #1,D1 ; set a true flag
947+ MOVE.L D1,-(PSP)
948+ RTS
949+*
950+* ######>> screen 20 <<
951+* ======>> 12 <<
952+* ( buffer ch --- buffer symboloffset delimiteroffset scancount )
953+* ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
954+* ( buffer ch --- buffer nuloffset onepast scancount )
955+* Scan buffer for a symbol delimited by ch or ASCII NUL,
956+* return the length of the buffer region scanned,
957+* the offset to the trailing delimiter,
958+* and the offset of the first character of the symbol.
959+* Leave the buffer on the stack.
960+* Scancount is also offset to first character not yet looked at.
961+* If no symbol in buffer, scancount and symboloffset point to NUL
962+* and delimiteroffset points one beyond for some reason.
963+* On trailing NUL, delimiteroffset == scancount.
964+* (Buffer is the address of the buffer array to scan.)
965+* (This is a bit too tricky, really.)
966+* NOTE :
967+* FC means offset (bytes) to First Character of next word
968+* EW " " to End of Word
969+* NC " " to Next Character to start next enclose at
970+ EVEN
971+ DC.B $87
972+ DC.B 'ENCLOS' ; 'ENCLOSE'
973+ DC.B 'E'|$80
974+ DC.L PFIND-7-NATWID
975+*ENCLOS DC.L *+NATWID
976+ENCLOS MOVE.B NATWID-1(PSP),D0 ; Delimiter character to match against in D0.
977+ MOVE.L NATWID(PSP),A0 ; Buffer to scan in.
978+ CLR.L D1 ; Initialize offset. (No particular limit on Buffer width.)
979+* Scan to a non-delimiter or a NUL
980+ENCDEL TST.B (A0,D1.W) ; NUL ?
981+ BEQ.S ENCNUL
982+ CMP.B (A0,D1.W),D0 ; Delimiter?
983+ BNE.S ENC1ST
984+ ADDQ.L #1,D1 ; count character
985+ BRA.S ENCDEL
986+* Found first character. Save the offset.
987+ENC1ST MOVE.L D1,(PSP) ; Found first non-delimiter character -- store the count.
988+* Scan to a delimiter or a NUL
989+ENCSYM TST.B (A0,D1.W) ; NUL ?
990+ BEQ.S ENC0TR
991+ CMP.B (A0,D1.W),D0 ; delimiter?
992+ BEQ.S ENCEND
993+ ADDQ.L #1,D1
994+ BRA.S ENCSYM
995+* Found end of symbol. Push offset to delimiter found.
996+ENCEND MOVE.L D1,-(PSP) ; Offset to seen delimiter.
997+* Advance and push address of next character to check.
998+ ADDQ.L #1,D1 ; one past
999+ MOVE.L D1,-(PSP)
1000+ RTS
1001+* Found NUL before non-delimiter, therefore there is no word
1002+ENCNUL MOVE.L D1,(PSP) ; offset to NUL.
1003+ ADDQ.L #1,D1 ; Point after NUL to allow (FIND) to match it.
1004+ MOVE.L D1,-(PSP) ;
1005+ SUBQ.L #1,D1 ; Next is not passed NUL.
1006+ MOVE.L D1,-(PSP) ; Stealing code will save only one byte.
1007+ RTS
1008+* Found NUL following the word instead of delimiter.
1009+ENC0TR
1010+ MOVE.L D1,-(PSP) ; Save offset to first after symbol (NUL)
1011+ MOVE.L D1,-(PSP) ; and count scanned.
1012+ RTS
1013+*
1014+ PAGE
1015+*
1016+* ######>> screen 21 <<
1017+* The next 4 words call system dependant I/O routines
1018+* which are listed after word "-->" ( label: "arrow" )
1019+* in the dictionary.
1020+*
1021+* ======>> 13 <<
1022+* ( c --- )
1023+* Write c to the output device (screen or printer).
1024+******* Need to write this for the ST ROM BIOS.
1025+******* Probably want to go ahead and define PEMIT, PKEY, PQTER, and PCR.
1026+******* Also might want to tune UORIG variable sizes.
1027+******* Need to find a way to set default operand size to Long.
1028+* ROM Uses the ECB device number at address $6F,
1029+* -2 is printer, 0 is screen.
1030+ EVEN
1031+ DC.B 0
1032+ DC.B $84
1033+ DC.B 'EMI' ; 'EMIT'
1034+ DC.B 'T'|$80
1035+ DC.L ENCLOS-8-NATWID
1036+*EMIT DC.L *+NATWID
1037+EMIT MOVE.L (PSP)+,D1
1038+ BSR.W PEMIT ; PEMIT expects the character in D1.
1039+ ADDQ.L #1,XOUT-UORIG(UP) ; Bump the output count.
1040+EMITDN RTS
1041+*
1042+* ======>> 14 <<
1043+* ( --- c )
1044+* ( --- BREAK )
1045+* Wait for a key from the keyboard.
1046+* If the key is BREAK, set the high byte (result $FF03).
1047+ EVEN
1048+ DC.B $83
1049+ DC.B 'KE' ; 'KEY'
1050+ DC.B 'Y'|$80
1051+ DC.L EMIT-5-NATWID
1052+*KEY DC.L *+NATWID
1053+KEY BSR.W PKEY ; PKEY leaves the scancode|key/break in D1.
1054+ AND.L #$000000FF,D1
1055+ MOVE.L D1,-(PSP)
1056+ RTS
1057+*
1058+* ======>> 15 <<
1059+* ( --- f )
1060+* Scan keyboard, but do not wait.
1061+* Return 0 if no key,
1062+* BREAK ($ff03) if BREAK is pressed,
1063+* or key currently pressed.
1064+ EVEN
1065+ DC.B $89
1066+ DC.B '?TERMINA' ; '?TERMINAL'
1067+ DC.B $CC
1068+ DC.L KEY-4-NATWID
1069+*QTERM DC.L *+NATWID
1070+QTERM BSR.W PQTER ; PQTER leaves the flag/key in D1.
1071+ MOVE.L D1,-(PSP)
1072+ RTS
1073+*
1074+* ======>> 16 <<
1075+* ( --- )
1076+* EMIT a Carriage Return (ASCII CR).
1077+ EVEN
1078+ DC.B 0
1079+ DC.B $82
1080+ DC.B 'C' ; 'CR'
1081+ DC.B 'R'|$80
1082+ DC.L QTERM-10-NATWID
1083+*CR DC.L *+NATWID
1084+CR BSR.W PCR ; Nothing really to do here.
1085+ RTS
1086+*
1087+* ######>> screen 22 <<
1088+* ======>> 17 <<
1089+* ( source target count --- )
1090+* Copy/move count bytes from source to target.
1091+* Moves ascending addresses,
1092+* so that overlapping only works if the source is above the destination.
1093+* CMOVE provides a nice testbed for the intersection between clever and real.
1094+* It also raises questions about why one might want to move all of memory.
1095+* The 68000 DBF instruction only does up to 2^16 moves, which is probably a reasonable limit;
1096+* but, rather than answer that question and/or the logic of split count, use a straight count.
1097+ EVEN
1098+ DC.B $85
1099+ DC.B 'CMOV' ; 'CMOVE' : source, destination, count
1100+ DC.B 'E'|$80
1101+ DC.L CR-3-NATWID
1102+*CMOVE DC.L *+NATWID
1103+CMOVE MOVEM.L (PSP)+,D1/A0/A1 ; No effect in flags.
1104+ TST.L D1 ; Don't let zero count equal 2^32.
1105+ BEQ.S CMOVEX ; Stack clean.
1106+CMOVEL MOVE.B (A1)+,(A0)+
1107+ SUBQ.L #1,D1
1108+ BNE.S CMOVEL
1109+CMOVEX RTS
1110+*
1111+** One possible way to use DBcc (untested):
1112+* MOVEM.L (PSP)+,D1/A0/A1 ; No effect in flags.
1113+* TST.L D1 ; Don't let zero count equal 2^32.
1114+* BEQ.L CMOVEX ; Stack clean.
1115+* SUBQ.W #1,D1 ; Adjust for DBcc
1116+*CMOVEL MOVE.B (A1)+,(A0)+
1117+* DBF D1,CMOVEL
1118+* SUB.L #$10000,D1
1119+* BCC.S CMOVEL
1120+*CMOVEX RTS ;
1121+*
1122+* ( source target count --- )
1123+* Copy/move count bytes from source to target.
1124+* Moves descending addresses,
1125+* so that overlapping does work if the source is below the destination.
1126+* And, conversely, does not work if the source is above the destination.
1127+* Not in fig, provided here for aligning header names in CREATE.
1128+ EVEN
1129+ DC.B 0
1130+ DC.B $86
1131+ DC.B 'CMOVE' ; 'CMOVED' : source, destination, count
1132+ DC.B 'D'|$80
1133+ DC.L CMOVE-6-NATWID
1134+*CMOVD DC.L *+NATWID
1135+CMOVD MOVEM.L (PSP)+,D1/A0/A1 ; No effect in flags.
1136+ TST.L D1 ; Don't let zero count equal 2^32.
1137+ BEQ.S CMOVDX ; Stack clean.
1138+ LEA (A1,D1.L),A1 ; Point to (one past) the ends.
1139+ LEA (A0,D1.L),A0
1140+CMOVDL MOVE.B -(A1),-(A0)
1141+ SUBQ.L #1,D1
1142+ BNE.S CMOVDL
1143+CMOVDX RTS
1144+* Could use MOVE.B (A1,D0.L),(A0,D0.L), too, but that would take extra cycles.
1145+*
1146+* ######>> screen 23 <<
1147+* ======>> 18 <<
1148+* ( u1 u2 --- ud )
1149+* Multiplies the top two unsigned integers,
1150+* yielding a double integer product.
1151+* Word at a time, but significantly faster than bit-at-a-time.
1152+ EVEN
1153+ DC.B 0
1154+ DC.B $82
1155+ DC.B 'U' ; 'U*'
1156+ DC.B '*'|$80
1157+ DC.L CMOVD-7-NATWID
1158+*USTAR DC.L *+NATWID
1159+USTAR MOVEM.W (PSP),D0/D1/D2/D3 ; MOVEM is a cheap way to split the low and high words.
1160+ MULU.W D3,D1 ; U2 low by U1 low, and it's in place
1161+ MULU.W D2,D0 ; U2 high by U1 high, and it's in place
1162+ MULU.W NATWID/2(PSP),D2 ; U1 high by U2 low
1163+ MULU.W (PSP),D3 ; U1 low by U2 high
1164+ ADD.L D3,D2 ; sum of inner products
1165+ CLR.L D3 ; X-carry is not affected
1166+ ADDX.L D3,D3 ; grab the X-carry (no ADDX #0!)
1167+ SWAP D3 ; move the carry into place
1168+ SWAP D2 ; fast 16 bit rotate
1169+ MOVE.W D2,D3 ; high half of inner product, carry in place
1170+ AND.L #$FFFF0000,D2 ; low half of inner product
1171+ ADD.L D2,D1
1172+ ADDX.L D3,D0 ; along with both carries!
1173+ MOVEM.L D0/D1,(PSP) ; stack is as we want it.
1174+ RTS
1175+*
1176+*
1177+* ######>> screen 24 <<
1178+* ======>> 19 <<
1179+* ( ud u --- uremainder uquotient )
1180+* Divides the top unsigned integer
1181+* into the second and third words on the stack
1182+* as a single unsigned double integer,
1183+* leaving the remainder and quotient (quotient on top)
1184+* as unsigned integers.
1185+*
1186+* The reason for this oddity is that U/ was intended to be the inverse of U* :
1187+* in other words,
1188+* U/ can only divide without overflow if the dividend is the result of
1189+* the divisor multiplied by the quotient using U* ,
1190+* with an added constant less than the divisor (the remainder portion).
1191+*
1192+* This is particularly useful in columnar division,
1193+* when the divisor fits within the defined column:
1194+*
1195+* The smaller the divisor, the more likely dropping the high word
1196+* of the quotient loses significant bits. See M/MOD .
1197+*
1198+* An example of a dividend/divisor pair that would not work:
1199+* HEX 200000000 2 U/
1200+* -- The largest multiple of 2 that U* could produce in a 32-bit environment would be
1201+* HEX 1FFFFFFFE
1202+* Thus, HEX 1FFFFFFFF would be the maximum 64-bit number
1203+* that U/ would divide by 2 without overflow.
1204+*
1205+* Note (from M/MOD) that U/ can be chained, as long as the divisor is single-width.
1206+*
1207+* For a library routine, I would probably want to run-time optimize the divide,
1208+* following four paths:
1209+* If divisor is zero, (1) give saturation result of max quotient, max remainder --
1210+* else if divisor fits in 16 bits,
1211+* if dividend fits in 16 bits, (2) use native DIVU --
1212+* else (3) use chained native DIVU (can be one less than full divide);
1213+* else, (4) for each 16-bit column,
1214+* use native DIVU to guess high word of quotient
1215+* multiply and subtract intermediate product
1216+* if too guess too large, decrement guess and add divisor to get remainder
1217+* shift to the next right column
1218+* But light testing would not be sufficient.
1219+* Each path would need to be tested against its next more optimal path.
1220+* And the resulting routine could be full M/MOD, if paths 3 and 4 are fully worked out.
1221+*
1222+* For now, for the fig model --
1223+ EVEN
1224+ DC.B 0
1225+ DC.B $82
1226+ DC.B 'U' ; 'U/'
1227+ DC.B '/'|$80
1228+ DC.L USTAR-3-NATWID
1229+* Using the bit divide to reduce testing burden, working in registers.
1230+USLASH:
1231+* DC.L *+NATWID
1232+ MOVEM.L (PSP),D0/D1/D2 ; D1:D2 by D0 (40~ ignore attempts to count cycles)
1233+ MOVE.W #32,D3 ; bit ct for DBcc (8~)
1234+USLDIV:
1235+ CMP.L D0,D1 ; divisor (6~)
1236+ BHS.S USLSUB (8/10~)
1237+ AND #~F_EXT,CCR ; X-carry clear (20~)
1238+ BRA.S USLBIT (10~)
1239+USLSUB:
1240+ SUB.L D0,D1 (6~)
1241+ OR #F_EXT,CCR ; quotient, (X-carry set) (20~)
1242+USLBIT:
1243+ ROXL.L #1,D2 ; save it (8~)
1244+ DBF D3,USLMOR ; more bits? Don't mess with CCR ((12/14)/10~)
1245+USLR:
1246+ LEA NATWID(PSP),PSP (8~)
1247+ MOVE.L D1,NATWID(PSP) (16~)
1248+ MOVE.L D2,(PSP) (12~)
1249+ RTS
1250+USLMOR:
1251+ ROXL.L #1,D1 ; remainder (8~)
1252+ BCC.S USLDIV (8/10~)
1253+ BRA.S USLSUB (10~) (~90*32=~2880+entry+exit, about 800 μS at 4 MHz)
1254+
1255+* The following is not yet functional, only here to help me remember:
1256+* cUSLASH DC.L *+NATWID
1257+* MOVE.W (PSP)+,D0
1258+* BNE USL32
1259+* MOVE.W (PSP)+,D0 ; stack pre-adjusted
1260+* BNE USL16 ; avoid DIV by 0 exception
1261+* MOVE.L #-1,(PSP) ; quotient too large
1262+* MOVE.L #-1,NATWID(PSP) ; remainder too large
1263+* RTS
1264+* cUSL16 CLR.L D1
1265+* MOVE.W (PSP),D1 ; start with highest half
1266+* DIVU.W D0,D1 ; can't overflow
1267+* MOVE.W D1,(PSP) ; remainder in high half
1268+* MOVE.W NATWID/2(PSP),D1 ; 2nd half
1269+* DIVU.W D0,D1
1270+* MOVE.W D1,NATWID/2(PSP)
1271+* MOVE.W NATWID(PSP),D1 ; 3rd half
1272+* DIVU.W D0,D1
1273+* MOVE.W D1,NATWID(PSP)
1274+* MOVE.W 3*NATWID/2(PSP),D1 ; lowest half
1275+* DIVU.W D0,D1 ; (140~) (~140*4=560+smallstuff)
1276+* MOVE.W D1,3*NATWID/2(PSP)
1277+* CLR.W D1
1278+* SWAP.W D1
1279+* RTS
1280+* cUSL32
1281+*
1282+* Following the 6809 code, working on the stack.
1283+* Untested:
1284+* B0USLASH:
1285+* DC.L *+NATWID
1286+* MOVE.W #33,D3 ; bit ct
1287+* MOVE.L NATWID(PSP),D2 ; dividend
1288+* B0USLDIV:
1289+* CMP.L (PSP),D2 ; divisor
1290+* BHS.S B0USLSUB
1291+* AND #~F_EXT,CCR ; X-carry clear
1292+* BRA.S B0USLBIT
1293+* B0USLSUB:
1294+* SUB.L (PSP),D2
1295+* OR #F_EXT,CCR ; quotient, (X-carry set)
1296+* B0USLBIT:
1297+* ROXL.W 2*NATWID+NATWID/2(PSP) ; save it
1298+* ROXL.W 2*NATWID(PSP) ; in memory has only 16-bit by 1 bit form
1299+* SUBQ.W #1,D3 ; more bits?
1300+* BEQ.S B0USLR
1301+* ROXL.L D2 ; remainder
1302+* BCC.S B0USLDIV
1303+* BRA.S B0USLSUB
1304+* B0USLR:
1305+* LEA NATWID(PSP),PSP
1306+* MOVE.L NATWID(PSP),D1
1307+* MOVEM.L D1/D2,(PSP)
1308+* RTS
1309+*
1310+
1311+ PAGE
1312+* ######>> screen 25 <<
1313+* ======>> 20 <<
1314+* ( n1 n2 --- n )
1315+* Bitwise and the top two integers.
1316+ EVEN
1317+ DC.B $83
1318+ DC.B 'AN' ; 'AND'
1319+ DC.B "D"|$80
1320+* DC.L I-2-NATWID ; ***** debug link *****
1321+ DC.L USLASH-3-NATWID ; correct link
1322+*AND DC.L *+NATWID
1323+AND MOVE.L (PSP)+,D0
1324+ AND.L D0,(PSP)
1325+ RTS
1326+*
1327+* ======>> 21 <<
1328+* ( n1 n2 --- n )
1329+* Bitwise or the top two integers.
1330+ EVEN
1331+ DC.B 0
1332+ DC.B $82
1333+ DC.B 'O' ; 'OR'
1334+ DC.B 'R'|$80
1335+ DC.L AND-4-NATWID
1336+*OR DC.L *+NATWID
1337+OR MOVE.L (PSP)+,D0
1338+ OR.L D0,(PSP)
1339+ RTS
1340+*
1341+* ======>> 22 <<
1342+* ( n1 n2 --- n )
1343+* Bitwise exclusive or the top two integers.
1344+ EVEN
1345+ DC.B $83
1346+ DC.B 'XO' ; 'XOR'
1347+ DC.B 'R'|$80
1348+ DC.L OR-3-NATWID
1349+*XOR DC.L *+NATWID
1350+XOR MOVE.L (PSP)+,D0
1351+ EOR.L D0,(PSP)
1352+ RTS
1353+*
1354+* Not in fig,
1355+* for CPUs that don't like odd addresses.
1356+* Test whether top of stack is odd, push flag: 0 => even, 1 => odd.
1357+* ( n --- n f )
1358+ EVEN
1359+ DC.B 0
1360+ DC.B $84
1361+ DC.B '?OD' ; '?ODD'
1362+ DC.B 'D'|$80
1363+ DC.L XOR-4-NATWID
1364+*QODD DC.L *+NATWID
1365+QODD MOVE.L (PSP),-(PSP)
1366+ AND.L #1,(PSP)
1367+ RTS
1368+* MOVE.L (PSP),D0
1369+* AND.L #1,D0
1370+* MOVE.L D0,-(PSP)
1371+* RTS
1372+*
1373+* Not in fig --
1374+* Calculate the bump adjustment necessary for odd or even alignment.
1375+* Odd for odd alignment, even for even.
1376+* bump is 0 (no adjustment) or 1 (adjustment needed)
1377+* ( n alignment --- n bump )
1378+ EVEN
1379+ DC.B 0
1380+ DC.B $8A
1381+ DC.B 'ALIGN-BUM' ; 'ALIGN-BUMP'
1382+ DC.B 'P'|$80
1383+ DC.L QODD-5-NATWID
1384+*ALGNB DC.L *+NATWID
1385+ALGNB MOVE.L (PSP),D0
1386+ AND.L #1,D0 ; Even or odd alignment?
1387+ MOVE.L NATWID(PSP),D1
1388+ AND.W #1,D1 ; Even address or odd?
1389+ EOR.W D0,D1 ; odd on even or even on odd is 1, else 0
1390+ MOVE.L D1,(PSP)
1391+ RTS
1392+*
1393+** Not in fig,
1394+** for CPUs that don't like odd addresses.
1395+** Floor top of stack even.
1396+** ( n --- even )
1397+* EVEN
1398+* DC.B 0
1399+* DC.B $86
1400+* DC.B 'FLOOR' ; 'FLOOR2'
1401+* DC.B '2'|$80
1402+* DC.L ALGNB-11-NATWID
1403+** FLOOR2 DC.L *+NATWID
1404+* FLOOR2 AND.W #$FFFE,NATWID/2(PSP)
1405+* RTS
1406+**
1407+** Not in fig,
1408+** for CPUs that don't like odd addresses.
1409+** Make top of stack even by adjusting it up.
1410+** ( n --- even )
1411+* EVEN
1412+* DC.B 0
1413+* DC.B $88
1414+* DC.B 'CIELING' ; 'CIELING2'
1415+* DC.B '2'|$80
1416+* DC.L FLOOR2-7-NATWID
1417+** CIEL2 DC.L *+NATWID
1418+* CIEL2 BCLR #0,NATWID-1(PSP)
1419+* BEQ.S CIEL2X
1420+* ADDQ.L #2,(PSP)
1421+* CIEL2X RTS
1422+*
1423+* ######>> screen 26 <<
1424+* ======>> 23 <<
1425+* ( anything --- anything adr )
1426+* Fetch the parameter stack pointer (before it is pushed).
1427+* This points at whatever was on the top of stack before.
1428+ EVEN
1429+ DC.B $83
1430+ DC.B 'SP' ; 'SP@'
1431+ DC.B '@'|$80
1432+ DC.L ALGNB-11-NATWID
1433+*SPAT DC.L *+NATWID
1434+SPAT MOVE.L PSP,-(PSP)
1435+ RTS
1436+*
1437+* ======>> 24 <<
1438+* ( whatever --- nothing )
1439+* Initialize the parameter stack pointer from the USER variable S0.
1440+* Effectively clears the stack.
1441+ EVEN
1442+ DC.B $83
1443+ DC.B 'SP' ; 'SP!'
1444+ DC.B $A1
1445+ DC.L SPAT-4-NATWID
1446+*SPSTOR DC.L *+NATWID
1447+SPSTOR MOVE.L XSPZER-UORIG(UP),PSP
1448+ RTS
1449+*
1450+ PAGE
1451+*
1452+* ======>> 25 <<
1453+* ( whatever *** nothing )
1454+* Initialize the return stack pointer from the initialization table
1455+* instead of the user variable R0, for some reason.
1456+* Quite possibly, this should be from R0.
1457+* Effectively aborts all in-process definitions, except the active one.
1458+* An emergency measure, to be sure.
1459+* The routine that calls this must never execute a return.
1460+* So this should never be executed from the terminal, I guess.
1461+* This is another that should be compile-time only, and in a separate vocabulary.
1462+ EVEN
1463+ DC.B $83
1464+ DC.B 'RP' ; 'RP!'
1465+ DC.B '!'|$80
1466+ DC.L SPSTOR-4-NATWID
1467+*RPSTOR DC.L *+NATWID
1468+RPSTOR MOVE.L RINIT(PC),RP
1469+ BRA.W NEXT ; This is correct here, but what will we do when NEXT goes away?
1470+*
1471+* ======>> 26 <<
1472+* ( ip *** )
1473+* Pop IP from return stack (return from high-level definition).
1474+* Can be used in a screen to force interpretion to terminate.
1475+* Must not be executed when temporaries are saved on top of the return stack.
1476+ EVEN
1477+ DC.B 0
1478+ DC.B $82
1479+ DC.B ';' ; ';S'
1480+ DC.B 'S'|$80
1481+ DC.L RPSTOR-4-NATWID
1482+*SEMIS DC.L *+NATWID
1483+SEMIS MOVEM.L (RP)+,A0/IP ; A0 will be TOS
1484+ JMP (A0) ; return to NEXT
1485+* ; SEMIS will almost disappear when NEXT goes away.
1486+* MOVE.L (RP)+,A0
1487+* MOVE.L (RP)+,IP
1488+* JMP (A0)
1489+*
1490+* ######>> screen 27 <<
1491+* ======>> 27 <<
1492+* ( limit index *** index index )
1493+* Force the terminating condition for the innermost loop by
1494+* copying its index to its limit.
1495+* Termination is postponed until the next
1496+* LOOP or +LOOP instruction is executed.
1497+* The index remains available for use until
1498+* the LOOP or +LOOP instruction is encountered.
1499+* Note that the assumption is that the current count is the correct count
1500+* to end at, rather than pushing the count to the final count.
1501+ EVEN
1502+ DC.B $85
1503+ DC.B 'LEAV' ; 'LEAVE'
1504+ DC.B 'E'|$80
1505+ DC.L SEMIS-3-NATWID
1506+*LEAVE DC.L *+NATWID
1507+LEAVE MOVE.L LUPCT(RP),LUPLIM(RP) ; Return address hidden in offset EQUs.
1508+ RTS
1509+*
1510+* Notes for loop counter and limit in registers:
1511+* MOVE.L LUPCT,LUPLIM ; No return address to dodge.
1512+* RTS
1513+*
1514+* ======>> 28 <<
1515+* ( n --- )
1516+* ( *** n )
1517+* Move top of parameter stack to top of return stack.
1518+ EVEN
1519+ DC.B 0
1520+ DC.B $82
1521+ DC.B '>' ; '>R'
1522+ DC.B 'R'|$80
1523+ DC.L LEAVE-6-NATWID
1524+*TOR DC.L *+NATWID
1525+TOR MOVE.L (RP),A0
1526+ MOVE.L (PSP)+,(RP)
1527+ JMP (A0)
1528+*
1529+* ======>> 29 <<
1530+* ( --- n )
1531+* ( n *** )
1532+* Move top of return stack to top of parameter stack.
1533+ EVEN
1534+ DC.B 0
1535+ DC.B $82
1536+ DC.B 'R' ; 'R>'
1537+ DC.B '>'|$80
1538+ DC.L TOR-3-NATWID
1539+*FROMR DC.L *+NATWID
1540+* MOVEM.L (RP)+,A0/A1 ; A0 will be TOS
1541+* MOVE.L A1,-(PSP)
1542+* JMP (A0)
1543+FROMR MOVE.L (RP)+,A0
1544+ MOVE.L (RP)+,-(PSP)
1545+ JMP (A0)
1546+*
1547+* ======>> 30 <<
1548+* ( --- n )
1549+* ( n *** n )
1550+* Copy the top of return stack to top of parameter stack.
1551+* This would NOT be a synonym for I if we were keeping the control variables in registers.
1552+ EVEN
1553+ DC.B $81 ; R
1554+ DC.B 'R'|$80
1555+ DC.L FROMR-3-NATWID
1556+*R DC.L I+NATWID ; Can't do as synonym any more.
1557+R MOVE.L NATWID(RP),-(PSP) ; dodge return address
1558+ RTS
1559+*
1560+ PAGE
1561+*
1562+* ######>> screen 28 <<
1563+* ======>> 31 <<
1564+* ( n --- ~n )
1565+* Bit-invert top.
1566+* Not part of fig model.
1567+ EVEN
1568+ DC.B $83
1569+ DC.B 'NO' ; 'NOT'
1570+ DC.B 'T'|$80
1571+ DC.L R-2-NATWID
1572+*LNOT DC.L *+NATWID
1573+LNOT NOT (PSP)
1574+ RTS
1575+*
1576+* ( n --- n=0 )
1577+* Logically invert top of stack;
1578+* or flag true if top is zero, otherwise false.
1579+ EVEN
1580+ DC.B 0
1581+ DC.B $82
1582+ DC.B '0' ; '0='
1583+ DC.B '='|$80
1584+ DC.L LNOT-4-NATWID
1585+*ZEQU DC.L *+NATWID
1586+ZEQU CLR.L D0
1587+ TST.L (PSP)
1588+ SEQ D0 ; faster than branch
1589+ZEQMSK AND.W #1,D0
1590+ MOVE.L D0,(PSP)
1591+ RTS
1592+*
1593+* Option using branch and increment:
1594+** ZEQU DC.L *+NATWID
1595+* ZEQU CLR.L D0
1596+* TST.L (PSP)
1597+* BEQ.S ZEQUS
1598+* MOVEQ #1,D0 ; ADDQ.W would work. ADDQ.L takes 8 cycles instead of 4.
1599+* ZEQUS MOVE.L D0,(PSP)
1600+* RTS
1601+*
1602+* If TRUE were -1:
1603+** ZEQU DC.L *+NATWID
1604+* ZEQU TST.L (PSP)
1605+* SEQ D0
1606+* EXT.B D0
1607+* EXT.W D0
1608+* MOVE.L D0,(PSP)
1609+* RTS
1610+*
1611+* ======>> 32 <<
1612+* ( n --- n<0 )
1613+* Flag true if top is negative (MSbit set), otherwise false.
1614+ EVEN
1615+ DC.B 0
1616+ DC.B $82
1617+ DC.B '0' ; '0<'
1618+ DC.B '<'|$80
1619+ DC.L ZEQU-3-NATWID
1620+*ZLESS DC.L *+NATWID
1621+ZLESS CLR.L D0
1622+ TST.L (PSP)
1623+ SMI D0
1624+ BRA.S ZEQMSK ; trade a few cycles for several bytes
1625+*
1626+* ######>> screen 29 <<
1627+* ======>> 33 <<
1628+* ( n1 n2 --- n1+n2 )
1629+* Add top two words.
1630+ EVEN
1631+ DC.B $81 ; '+'
1632+ DC.B '+'|$80
1633+ DC.L ZLESS-3-NATWID
1634+*PLUS DC.L *+NATWID
1635+PLUS MOVE.L (PSP)+,D0 ; Addition is commutative.
1636+ ADD.L D0,(PSP) ; This order will not work for subtraction.
1637+ RTS ; Remember, my son --
1638+* ; the left hand operator is one deeper in the stack,
1639+* ; and it is the target.
1640+*
1641+* ======>> 34 <<
1642+* ( d1 d2 --- d1+d2 )
1643+* Add top two double integers.
1644+ EVEN
1645+ DC.B 0
1646+ DC.B $82
1647+ DC.B 'D' ; 'D+'
1648+ DC.B '+'|$80
1649+ DC.L PLUS-2-NATWID
1650+*DPLUS DC.L *+NATWID
1651+DPLUS MOVEM.L (PSP)+,D0/D1/D2/D3 ; ADDX memory requires too much setup
1652+ ADD.L D1,D3 ; This order will work for subtraction, too.
1653+ ADDX.L D0,D2
1654+ MOVEM.L D2/D3,-(PSP)
1655+ RTS
1656+*
1657+* ======>> 35 <<
1658+* ( n --- -n )
1659+* Negate (two's complement) top of stack.
1660+ EVEN
1661+ DC.B $85
1662+ DC.B 'MINU' ; 'MINUS'
1663+ DC.B 'S'|$80
1664+ DC.L DPLUS-3-NATWID
1665+*MINUS DC.L *+NATWID
1666+MINUS NEG.L (PSP)
1667+ RTS
1668+*
1669+* ======>> 36 <<
1670+* ( d --- -d )
1671+* Negate (two's complement) top two words on stack as a double integer.
1672+ EVEN
1673+ DC.B 0
1674+ DC.B $86
1675+ DC.B 'DMINU' ; 'DMINUS'
1676+ DC.B 'S'|$80
1677+ DC.L MINUS-6-NATWID
1678+*DMINUS DC.L *+NATWID
1679+DMINUS NEG.L NATWID(PSP)
1680+ NEGX.L (PSP)
1681+ RTS
1682+*
1683+* ######>> screen 30 <<
1684+* ======>> 37 <<
1685+* ( n1 n2 --- n1 n2 n1 )
1686+* Push a copy of the second word on stack.
1687+ EVEN
1688+ DC.B 0
1689+ DC.B $84
1690+ DC.B 'OVE' ; 'OVER'
1691+ DC.B 'R'|$80
1692+ DC.L DMINUS-7-NATWID
1693+*OVER DC.L *+NATWID
1694+OVER MOVE.L NATWID(PSP),-(PSP)
1695+ RTS
1696+*
1697+* ======>> 38 <<
1698+* ( n --- )
1699+* Discard the top word on stack.
1700+ EVEN
1701+ DC.B 0
1702+ DC.B $84
1703+ DC.B 'DRO' ; 'DROP'
1704+ DC.B 'P'|$80
1705+ DC.L OVER-5-NATWID
1706+*DROP DC.L *+NATWID
1707+DROP LEA NATWID(PSP),PSP
1708+ RTS
1709+*
1710+* ======>> 39 <<
1711+* ( n1 n2 --- n2 n1 )
1712+* Swap the top two words on stack.
1713+ EVEN
1714+ DC.B 0
1715+ DC.B $84
1716+ DC.B 'SWA' ; 'SWAP'
1717+ DC.B 'P'|$80
1718+ DC.L DROP-5-NATWID
1719+*SWAP DC.L *+NATWID
1720+SWAP MOVEM.L (PSP),D0/D1
1721+ EXG D0,D1
1722+ MOVEM.L D0/D1,(PSP)
1723+ RTS
1724+* MOVE.L (PSP),D0
1725+* MOVE.L NATWID(PSP),(PSP)
1726+* MOVE.L D0,NATWID(POS)
1727+* RTS
1728+*
1729+* ======>> 40 <<
1730+* ( n1 --- n1 n1 )
1731+* Push a copy of the top word on stack.
1732+ EVEN
1733+ DC.B $83
1734+ DC.B 'DU' ; 'DUP'
1735+ DC.B 'P'|$80
1736+ DC.L SWAP-5-NATWID
1737+*DUP DC.L *+NATWID
1738+DUP MOVE.L (PSP),-(PSP)
1739+ RTS
1740+*
1741+* ######>> screen 31 <<
1742+* ======>> 41 <<
1743+* ( n adr --- )
1744+* Add the second word on stack to the word at the adr on top of stack.
1745+ EVEN
1746+ DC.B 0
1747+ DC.B $82
1748+ DC.B '+' ; '+!'
1749+ DC.B '!'|$80
1750+ DC.L DUP-4-NATWID
1751+*PSTORE DC.L *+NATWID
1752+PSTORE MOVEM.L (PSP)+,D0/A0
1753+ EXG D0,A0
1754+ ADD.L D0,(A0)
1755+ RTS
1756+*
1757+* ======>> 42 <<
1758+* ( adr b --- )
1759+* Exclusive or byte at adr with low byte of top word.
1760+ EVEN
1761+ DC.B 0
1762+ DC.B $86
1763+ DC.B 'TOGGL' ; 'TOGGLE'
1764+ DC.B 'E'|$80
1765+ DC.L PSTORE-3-NATWID
1766+*TOGGLE DC.L *+NATWID
1767+TOGGLE MOVEM.L (PSP)+,D0/A0
1768+ EOR.B D0,(A0)
1769+ RTS
1770+* Using the model code would be less likely to introduce bugs,
1771+* but that would sort-of defeat my purposes here.
1772+* Anyway, I can imitate known good bif-6809 code
1773+* and it's fewer bytes and much faster code this way.
1774+* TOGGLE
1775+* DC.L DOCOL,OVER,CAT,XOR,SWAP,CSTORE
1776+* DC.L SEMIS
1777+*
1778+* ######>> screen 32 <<
1779+* ======>> 43 <<
1780+* ( adr --- n )
1781+* Replace address on stack with the word at the address.
1782+ EVEN
1783+ DC.B $81 ; @
1784+ DC.B '@'|$80
1785+ DC.L TOGGLE-7-NATWID
1786+*AT DC.L *+NATWID
1787+AT MOVE.L (PSP),A0
1788+ MOVE.L (A0),(PSP)
1789+ RTS
1790+*
1791+* ======>> 44 <<
1792+* ( adr --- b )
1793+* Replace address on top of stack with the byte at the address.
1794+* High byte of result is clear.
1795+* Unfortunate naming. 8 bits doth not a character code point make.
1796+ EVEN
1797+ DC.B 0
1798+ DC.B $82
1799+ DC.B 'C' ; 'C@'
1800+ DC.B '@'|$80
1801+ DC.L AT-2-NATWID
1802+**CAT DC.L *+NATWID
1803+*CAT MOVE.L (PSP),A0 ; Memory indirect is 68020 and after, but not CPU32.
1804+* CLR.L D0 ; Reduce bus activity and un-aligned access.
1805+* MOVE.B (A0),D0
1806+* MOVE.L D0,(PSP)
1807+* RTS
1808+CAT MOVE.L (PSP),A0
1809+ CLR.L (PSP)
1810+ MOVE.B (A0),NATWID-1(PSP)
1811+ RTS
1812+* But optimization is not my primary purpose here,
1813+* so I'm not going to count bytes and cycles and compare.
1814+*
1815+* ( adr --- h )
1816+* Yeah, we're gonna need this.
1817+* Replace address on top of stack with the 16-bit half-word at the address.
1818+* High half-word of result is clear.
1819+ EVEN
1820+ DC.B 0
1821+ DC.B $82
1822+ DC.B 'H' ; 'H@'
1823+ DC.B '@'|$80
1824+ DC.L CAT-3-NATWID
1825+**HAT DC.L *+NATWID
1826+*HAT MOVE.L (PSP),A0 ; Memory indirect is 68020 and after, but not CPU32.
1827+* CLR.L D0 ; Reduce bus activity.
1828+* MOVE.W (A0),D0
1829+* MOVE.L D0,(PSP)
1830+* RTS
1831+HAT MOVE.L (PSP),A0
1832+ CLR.L (PSP)
1833+ MOVE.W (A0),NATWID/2(PSP)
1834+ RTS
1835+*
1836+* ======>> 45 <<
1837+* ( n adr --- )
1838+* Store second word on stack at address on top of stack.
1839+ EVEN
1840+ DC.B $81 ; !
1841+ DC.B '!'|$80
1842+ DC.L HAT-3-NATWID
1843+**STORE DC.L *+NATWID
1844+*STORE MOVEM.L (PSP)+,D0/A0
1845+* EXG D0,A0
1846+* MOVE.L D0,(A0)
1847+* RTS
1848+STORE MOVE.L (PSP)+,A0
1849+ MOVE.L (PSP)+,(A0)
1850+ RTS
1851+*
1852+* ======>> 46 <<
1853+* ( b adr --- )
1854+* Store low byte of second word on stack at address on top of stack.
1855+* High byte is ignored.
1856+* Unfortunate naming. 8 bits doth not a character code point make.
1857+ EVEN
1858+ DC.B 0
1859+ DC.B $82
1860+ DC.B 'C' ; 'C!'
1861+ DC.B '!'|$80
1862+ DC.L STORE-2-NATWID
1863+**CSTORE DC.L *+NATWID
1864+*CSTORE MOVEM.L (PSP)+,D0/A0
1865+* EXG D0,A0
1866+* MOVE.B D0,(A0)
1867+* RTS
1868+CSTORE MOVE.L (PSP)+,A0
1869+ MOVE.L (PSP)+,D0
1870+ MOVE.B D0,(A0)
1871+ RTS
1872+*
1873+* ( b adr --- )
1874+* Yeah, we're gonna need this.
1875+* Store low 16-bit half-word of second word on stack at address on top of stack.
1876+* High half-word is ignored.
1877+ EVEN
1878+ DC.B 0
1879+ DC.B $82
1880+ DC.B 'H' ; 'H!'
1881+ DC.B '!'|$80
1882+ DC.L CSTORE-3-NATWID
1883+**HSTORE DC.L *+NATWID
1884+*HSTORE MOVEM.L (PSP)+,D0/A0
1885+* EXG D0,A0
1886+* MOVE.W D0,(A0)
1887+* RTS
1888+HSTORE MOVE.L (PSP)+,A0
1889+ MOVE.L (PSP)+,D0
1890+ MOVE.B D0,(A0)
1891+ RTS
1892+*
1893+ PAGE
1894+*
1895+* ######>> screen 33 <<
1896+* ======>> 47 <<
1897+* ( --- ) P
1898+* { : name sundry-activities ; } typical input
1899+* ( Termination of recursive definition, or eating our own dogfood --
1900+* lots of forward references here.)
1901+* If executing (not compiling),
1902+* record the data stack mark in CSP,
1903+* Set the CONTEXT vocabulary to CURRENT,
1904+* CREATE a header,
1905+* set state to compile,
1906+* and compile the call to the trailing native CPU machine code DOCOL.
1907+*
1908+* This would not be hard to flatten to native code,
1909+* especially in the 6809 or 68000.
1910+* But that's not the purpose of a model.
1911+*
1912+ EVEN
1913+ DC.B $C1 ; : immediate
1914+ DC.B ':'|$80
1915+ DC.L HSTORE-3-NATWID
1916+*COLON DC.L DOCOL
1917+COLON BSR.S DOCOL
1918+ DC.L QEXEC,SCSP,CURENT,AT,CONTXT,STORE
1919+ DC.L CREATE,RBRAK
1920+ DC.L PSCODE
1921+*COLON BSR.W QEXEC
1922+* BSR.W SCSP
1923+* MOVE.L XCURR-UORIG(UP),XCONT-UORIG(UP)
1924+* BSR.W CREATE
1925+* BSR.W RBRAK
1926+* BSR.W PSCODE
1927+
1928+* Here is the IP pusher for allowing
1929+* nested words in the virtual machine:
1930+* ( ;S is the equivalent un-nester )
1931+
1932+* ( *** oldIP )
1933+* Characteristic of a colon (:) definition.
1934+* Begins execution of a high-level definition,
1935+* i. e., nests the definition and begins processing icodes.
1936+* Mechanically, it pushes the IP
1937+* and loads the Parameter Field Address of the definition which
1938+* called it into the IP.
1939+*DOCOL MOVE.L (RP),A0
1940+* MOVE.L IP,(RP)
1941+* MOVE.L W,IP
1942+* JMP (A0) ; Return to NEXT.
1943+DOCOL MOVEM.L (RP)+,A0/A1 ; new i-code list address and return to NEXT
1944+ MOVE.L IP,-(RP) ; nest IP
1945+ MOVE.L A0,IP ; address of list saved by call here
1946+ JMP (A1) ; Return to caller, usually or often NEXT.
1947+*
1948+* ======>> 48 <<
1949+* ( --- ) P
1950+* { : name sundry-activities ; } typical input
1951+* ERROR check data stack against mark in CSP,
1952+* compile ;S,
1953+* unSMUDGE LATEST definition,
1954+* and set state to interpretation.
1955+ EVEN
1956+ DC.B $C1 ; ; imnediate code
1957+ DC.B ';'|$80
1958+ DC.L COLON-2-NATWID
1959+*SEMI DC.L DOCOL
1960+SEMI BSR.S DOCOL
1961+ DC.L QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
1962+ DC.L SEMIS
1963+*
1964+* ######>> screen 34 <<
1965+* ======>> 49 <<
1966+* ( n --- )
1967+* { value CONSTANT name } typical input
1968+* CREATE a header,
1969+* unSMUDGE it,
1970+* compile the constant value,
1971+* and compile the call to the trailing native CPU machine code DOCON.
1972+ EVEN
1973+ DC.B 0
1974+ DC.B $88
1975+ DC.B 'CONSTAN' ; 'CONSTANT'
1976+ DC.B 'T'|$80
1977+ DC.L SEMI-2-NATWID
1978+*CON DC.L DOCOL
1979+CON BSR.S DOCOL
1980+ DC.L CREATE,SMUDGE,COMMA,PSCODE
1981+* ( --- n )
1982+* Characteristic of a CONSTANT.
1983+* A CONSTANT simply loads its value from its parameter field
1984+* and pushes it on the stack.
1985+DOCON MOVE.L (RP)+,A0 ; Get fake return address pushed by call here.
1986+ MOVE.L (A0),-(PSP) ; Push the first natural width word of the parameter field.
1987+ RTS ; Return to caller, usually or often NExT
1988+*
1989+* Tempting to do a space-saving DOHCON:
1990+* DOHCON MOVE.L (RP)+,A0 ; Get fake return address pushed by call here.
1991+* MOVE.W (A0),-(PSP) ; Push the first half-width word of the parameter field.
1992+* MOVEQ.W #0,-(PSP) ; zero extend the half-width value on stack
1993+* RTS ; Return to caller, usually or often NExT
1994+* But, as you can see, it'll be a bit slower,
1995+* and it just may not be worth it for the number of times it would be used.
1996+* And there's a bettwer way lurking around the corner.
1997+*
1998+* ======>> 50 <<
1999+* ( init --- )
2000+* { init VARIABLE name } typical input
2001+* Use CONSTANT to CREATE a header and compile the initial value, init,
2002+* then overwrite the characteristic to point to DOVAR.
2003+ EVEN
2004+ DC.B 0
2005+ DC.B $88
2006+ DC.B 'VARIABL' ; 'VARIABLE'
2007+ DC.B 'E'|$80
2008+ DC.L CON-9-NATWID
2009+*VAR DC.L DOCOL
2010+VAR BSR.S DOCOL
2011+ DC.L CON,PSCODE
2012+* ( --- vadr )
2013+* Characteristic of a VARIABLE.
2014+* A VARIABLE pushes its PFA address on the stack.
2015+* The parameter field of a VARIABLE is the actual allocation of the variable,
2016+* so that pushing its address allows its contents to be @ed (fetched).
2017+* Ordinary arrays and strings that do not subscript themselves
2018+* may be allocated by defining a variable
2019+* and immediately ALLOTting the remaining needed space.
2020+* VARIABLES are global to all users,
2021+* and thus should be hidden in resource monitors, but aren't.
2022+DOVAR MOVE.L (RP)+,-(PSP) ; Get and push fake return address pushed by call here,
2023+ RTS ; as address of first natural width word of the parameters.
2024+*
2025+* ======>> 51 <<
2026+* ( ub --- )
2027+* { uboffset USER name } typical input
2028+* CREATE a header and compile the unsigned byte offset in the per-USER table,
2029+* then overwrite the header with a call to DOUSER.
2030+* The USER is entirely responsible for maintaining allocation!
2031+* (We really need a word that controls allocation of these.)
2032+ EVEN
2033+ DC.B 0
2034+ DC.B $84
2035+ DC.B 'USE' ; 'USER'
2036+ DC.B 'R'|$80
2037+ DC.L VAR-9-NATWID
2038+*USER DC.L DOCOL
2039+USER BSR.S DOCOL
2040+ DC.L CON,PSCODE
2041+* ( --- vadr )
2042+* Characteristic of a per-USER variable.
2043+* USER variables are similiar to VARIABLEs,
2044+* but are allocated (by hand!) in the per-user table.
2045+* A USER variable's parameter field contains its offset in the per-user table.
2046+DOUSER MOVE.L (RP)+,A0 ; Get fake return address pushed by call here.
2047+ MOVE.L (A0),D0 ; Offset into the table.
2048+ LEA (UP,D0.L),A0
2049+ MOVE.L A0,-(PSP)
2050+ RTS
2051+* Hey, the per-user table can actually be larger than 256 bytes!
2052+*
2053+ PAGE
2054+*
2055+* ######>> screen 35 <<
2056+*
2057+* Some (theoretically) useful constants:
2058+* ======>> 52 <<
2059+* ( --- 0 )
2060+ EVEN
2061+ DC.B $81 ; 0
2062+ DC.B '0'|$80
2063+ DC.L USER-5-NATWID
2064+*ZERO DC.L DOCON
2065+ZERO BSR.S DOCON
2066+ DC.L 0000
2067+*
2068+* ======>> 53 <<
2069+* ( --- 1 )
2070+ EVEN
2071+ DC.B $81 ; 1
2072+ DC.B '1'|$80
2073+ DC.L ZERO-2-NATWID
2074+*ONE BSR.S DOCON
2075+ONE DC.L DOCON
2076+ONEV DC.L 1
2077+*
2078+* ======>> 54 <<
2079+* ( --- 2 )
2080+ EVEN
2081+ DC.B $81 ; 2
2082+ DC.B '2'|$80
2083+ DC.L ONE-2-NATWID
2084+*TWO DC.L DOCON
2085+TWO BSR.S DOCON
2086+TWOV DC.L 2
2087+*
2088+* ======>> 55 <<
2089+* ( --- 3 )
2090+ EVEN
2091+ DC.B $81 ; 3
2092+ DC.B '3'|$80
2093+ DC.L TWO-2-NATWID
2094+*THREE DC.L DOCON
2095+THREE BSR.W DOCON
2096+ DC.L 3
2097+*
2098+*mOVE NATWC into BSR.S range, in front of THREE? Maybe not.
2099+* Useful constant, not in model, needed for abstraction:
2100+* The standard name is CELL, however.
2101+* ( --- NATWID )
2102+* The byte width of objects on stack.
2103+ EVEN
2104+ DC.B 0
2105+ DC.B $86
2106+ DC.B 'NATWI' ; 'NATWID'
2107+ DC.B 'D'|$80
2108+ DC.L THREE-2-NATWID
2109+*NATWC DC.L DOCON
2110+NATWC BSR.W DOCON
2111+NATWCV DC.L NATWID
2112+*
2113+* Not in model, wanted for abstraction:
2114+* Note that this is not defined as an instance of an INCREMENTER here!
2115+* Coded to increment by the exact constant returned by NATWID
2116+* ( n --- n+NATWID )
2117+ EVEN
2118+ DC.B 0
2119+ DC.B $84
2120+ DC.B 'NAT' ; 'NAT+'
2121+ DC.B '+'|$80
2122+ DC.L NATWC-7-NATWID
2123+*NATP DC.L *+NATWID
2124+NATP MOVE.L (PSP),D0
2125+ ADD.L NATWCV(PC),D0 ; late binding?
2126+ MOVE.L D0,(PSP)
2127+ RTS
2128+*
2129+* Useful constant, not in model, needed for abstraction:
2130+* ( --- NATWID/2 )
2131+* Half the byte width of objects on stack.
2132+ EVEN
2133+ DC.B 0
2134+ DC.B $8A
2135+ DC.B 'HALFNATWI' ; 'HALFNATWID'
2136+ DC.B 'D'|$80
2137+ DC.L NATP-5-NATWID
2138+*HNATWC DC.L DOCON
2139+HNATWC BSR.W DOCON
2140+HNATWCV DC.L NATWID/2
2141+*
2142+ PAGE
2143+*
2144+* ======>> 56 <<
2145+* ( --- SP )
2146+* ASCII SPACE character
2147+ EVEN
2148+ DC.B 0
2149+ DC.B $82
2150+ DC.B 'B' ; 'BL'
2151+ DC.B 'L'|$80
2152+ DC.L HNATWC-11-NATWID
2153+*BL DC.L DOCON ; ascii blank
2154+BL BSR.W DOCON ; ascii blank
2155+ DC.L $20
2156+*
2157+* ======>> 57 <<
2158+* This really shouldn't be a CONSTANT.
2159+* ( --- adr )
2160+* The base of the disk buffer space.
2161+ EVEN
2162+ DC.B $85
2163+ DC.B 'FIRS' ; 'FIRST'
2164+ DC.B 'T'|$80
2165+ DC.L BL-3-NATWID
2166+*FIRST DC.L DOCON
2167+FIRST BSR.W DOCON
2168+ DC.L BUFBAS
2169+* FDB MEMEND-528 ; (132 * NBLK)
2170+*
2171+* ======>> 58 <<
2172+* This really shouldn't be a CONSTANT.
2173+* ( --- adr )
2174+* The limit of the disk buffer space.
2175+ EVEN
2176+ DC.B $85
2177+ DC.B 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
2178+ DC.B 'T'|$80
2179+ DC.L FIRST-6-NATWID
2180+*LIMIT DC.L DOCON
2181+LIMIT BSR.W DOCON
2182+ DC.L BUFBAS+BUFSZ
2183+* In 6800 model, was
2184+* FDB MEMEND
2185+*
2186+* ======>> 59 <<
2187+* ( --- sectorsize )
2188+* The size, in bytes, of a buffer control region.
2189+ EVEN
2190+ DC.B $85
2191+ DC.B 'B/CT' ; 'B/CTL' : (bytes/control region)
2192+ DC.B 'L'|$80
2193+ DC.L LIMIT-6-NATWID
2194+*BCTL DC.L DOCON
2195+BCTL BSR.W DOCON
2196+ DC.L SECTRL
2197+*
2198+* ( --- sectorsize )
2199+* The size, in bytes, of a buffer.
2200+ EVEN
2201+ DC.B $85
2202+ DC.B 'B/BU' ; 'B/BUF' : (bytes/buffer)
2203+ DC.B 'F'|$80
2204+ DC.L BCTL-6-NATWID
2205+*BBUF DC.L DOCON
2206+BBUF BSR.W DOCON
2207+ DC.L SECTSZ
2208+* Hardcoded in 6800 model:
2209+* FDB 128
2210+*
2211+* ======>> 60 <<
2212+* ( --- blocksperscreen )
2213+* The size, in blocks, of a screen.
2214+* Should this be the same as NBLK, the number of block buffers maintained?
2215+* Only if you want to have a full screen in buffers at a time,
2216+* which might induce some bugs -- erk.
2217+ EVEN
2218+ DC.B $85
2219+ DC.B 'B/SC' ; 'B/SCR' : (blocks/screen)
2220+ DC.B 'R'|$80
2221+ DC.L BBUF-6-NATWID
2222+*BSCR DC.L DOCON
2223+BSCR BSR.W DOCON
2224+ DC.L SCRSZ/SECTSZ
2225+* Hardcoded in 6800 model as:
2226+* FDB 8
2227+* blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
2228+*
2229+* ======>> 61 <<
2230+* ( n --- adr )
2231+* Calculate the address of entry (#n/NATWID) in the boot-up parameter table.
2232+* (Adds the base of the boot-up table to n.)
2233+ EVEN
2234+ DC.B $87
2235+ DC.B '+ORIGI' ; '+ORIGIN'
2236+ DC.B 'N'|$80
2237+ DC.L BSCR-6-NATWID
2238+*PORIG DC.L DOCOL
2239+PORIG BSR.W DOCOL
2240+ DC.L LIT,ORIG,PLUS
2241+ DC.L SEMIS
2242+*
2243+* ######>> screen 36 <<
2244+* ======>> 62 <<
2245+* ( n --- adr )
2246+* This is the per-task variable recording the initial parameter stack pointer.
2247+ EVEN
2248+ DC.B 0
2249+ DC.B $82
2250+ DC.B 'S' ; 'S0'
2251+ DC.B '0'|$80
2252+ DC.L PORIG-8-NATWID
2253+*SZERO DC.L DOUSER
2254+SZERO BSR.W DOUSER
2255+ DC.L XSPZER-UORIG
2256+*
2257+* ======>> 63 <<
2258+* ( n --- adr )
2259+* This is the per-task variable recording the initial return stack pointer.
2260+ EVEN
2261+ DC.B 0
2262+ DC.B $82
2263+ DC.B 'R' ; 'R0'
2264+ DC.B '0'|$80
2265+ DC.L SZERO-3-NATWID
2266+*RZERO DC.L DOUSER
2267+RZERO BSR.W DOUSER
2268+ DC.L XRZERO-UORIG
2269+*
2270+* ======>> 64 <<
2271+* ( --- vadr )
2272+* Terminal Input Buffer address.
2273+* Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
2274+ EVEN
2275+ DC.B $83
2276+ DC.B 'TI' ; 'TIB'
2277+ DC.B 'B'|$80
2278+ DC.L RZERO-3-NATWID
2279+*TIB DC.L DOUSER
2280+TIB BSR.W DOUSER
2281+ DC.L XTIB-UORIG
2282+*
2283+* ======>> 65 <<
2284+* ( --- maxnamewidth )
2285+* This is the maximum width to which symbol names will be recorded.
2286+ EVEN
2287+ DC.B $85
2288+ DC.B 'WIDT' ; 'WIDTH'
2289+ DC.B 'H'|$80
2290+ DC.L TIB-4-NATWID
2291+*WIDTH DC.L DOUSER
2292+WIDTH BSR.W DOUSER
2293+ DC.L XWIDTH-UORIG
2294+*
2295+* ======>> 66 <<
2296+* ( --- vadr )
2297+* Availability of error messages on disk.
2298+* Contains 1 if messages available,
2299+* 0 if not,
2300+* -1 if a disk error has occurred.
2301+ EVEN
2302+ DC.B $87
2303+ DC.B 'WARNIN' ; 'WARNING'
2304+ DC.B 'G'|$80
2305+ DC.L WIDTH-6-NATWID
2306+*WARN DC.L DOUSER
2307+WARN BSR.W DOUSER
2308+ DC.L XWARN-UORIG
2309+*
2310+* ======>> 67 <<
2311+* ( --- vadr )
2312+* Boundary for FORGET.
2313+ EVEN
2314+ DC.B $85
2315+ DC.B 'FENC' ; 'FENCE'
2316+ DC.B 'E'|$80
2317+ DC.L WARN-8-NATWID
2318+*FENCE DC.L DOUSER
2319+FENCE BSR.W DOUSER
2320+ DC.L XFENCE-UORIG
2321+*
2322+* ======>> 68 <<
2323+* ( --- vadr )
2324+* Dictionary pointer, fetched by HERE.
2325+ EVEN
2326+ DC.B 0
2327+ DC.B $82
2328+ DC.B 'D' ; 'DP' : points to first free byte at end of dictionary
2329+ DC.B 'P'|$80
2330+ DC.L FENCE-6-NATWID
2331+*DICTPT DC.L DOUSER
2332+DICTPT BSR.W DOUSER
2333+ DC.L XDICTP-UORIG
2334+*
2335+* ======>> 68.5 <<
2336+* ( --- vadr ) ******* Need to check what this is!
2337+* Used in maintaining vocabularies.
2338+* I think it points to the current "parent" vocabulary, but I'm not sure.
2339+* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
2340+* According to the fig glossary, it is the pointer to the link field (parent link?)
2341+* of the most recently created vocabulary.
2342+* The glossary indicates that FORGET would use this to
2343+* "allow control for FORGETting thru multiple vocabularys",
2344+* which I am now guessing does not mean what I at one time thought it should mean.
2345+ EVEN
2346+ DC.B 0
2347+ DC.B $88
2348+ DC.B 'VOC-LIN' ; 'VOC-LINK'
2349+ DC.B 'N'|$80
2350+ DC.L DICTPT-3-NATWID
2351+*VOCLIN DC.L DOUSER
2352+VOCLIN BSR.W DOUSER
2353+ DC.L XVOCL-UORIG
2354+*
2355+* ======>> 69 <<
2356+* ( --- vadr )
2357+* Disk block being interpreted.
2358+* Zero refers to terminal.
2359+* ******** Should be made a 64 bit user variable! ********
2360+* But the base system needs to have full 64 bit support, div and mul, etc.
2361+* before we can do that.
2362+ EVEN
2363+ DC.B $83
2364+ DC.B 'BL' ; 'BLK'
2365+ DC.B 'K'|$80
2366+ DC.L VOCLIN-9-NATWID
2367+*BLK DC.L DOUSER
2368+BLK BSR.W DOUSER
2369+ DC.L XBLK-UORIG
2370+*
2371+* ======>> 70 <<
2372+* ( --- vadr )
2373+* Input buffer offset/cursor.
2374+ EVEN
2375+ DC.B 0
2376+ DC.B $82
2377+ DC.B 'I' ; 'IN' : scan pointer for input line buffer
2378+ DC.B 'N'|$80
2379+ DC.L BLK-4-NATWID
2380+*IN DC.L DOUSER
2381+IN BSR.W DOUSER
2382+ DC.L XIN-UORIG
2383+*
2384+* ======>> 71 <<
2385+* ( --- vadr )
2386+* Output buffer offset/cursor.
2387+ EVEN
2388+ DC.B $83
2389+ DC.B 'OU' ; 'OUT'
2390+ DC.B 'T'|$80
2391+ DC.L IN-3-NATWID
2392+*OUT DC.L DOUSER
2393+OUT BSR.W DOUSER
2394+ DC.L XOUT-UORIG
2395+*
2396+* ======>> 72 <<
2397+* ( --- vadr )
2398+* Screen currently being edited, once we have an editor running.
2399+ EVEN
2400+ DC.B $83
2401+ DC.B 'SC' ; 'SCR'
2402+ DC.B 'R'|$80
2403+ DC.L OUT-4-NATWID
2404+*SCR DC.L DOUSER
2405+SCR BSR.W DOUSER
2406+ DC.L XSCR-UORIG
2407+* ######>> screen 37 <<
2408+*
2409+* ======>> 73 <<
2410+* ( --- vadr )
2411+* Sector offset for LOADing screens,
2412+* set by DRIVE to make a new drive the default.
2413+* This should also be 64 bit, if we had full 64-bit math.
2414+ EVEN
2415+ DC.B 0
2416+ DC.B $86
2417+ DC.B 'OFFSE' ; 'OFFSET'
2418+ DC.B 'T'|$80
2419+ DC.L SCR-4-NATWID
2420+*OFSET DC.L DOUSER
2421+OFSET BSR.W DOUSER
2422+ DC.L XOFSET-UORIG
2423+*
2424+* ======>> 74 <<
2425+* ( --- vadr )
2426+* Current context of interpretation (vocabulary root).
2427+ EVEN
2428+ DC.B $87
2429+ DC.B 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
2430+ DC.B 'T'|$80
2431+ DC.L OFSET-7-NATWID
2432+*CONTXT DC.L DOUSER
2433+CONTXT BSR.W DOUSER
2434+ DC.L XCONT-UORIG
2435+*
2436+* ======>> 75 <<
2437+* ( --- vadr )
2438+* Current context of definition (vocabulary root).
2439+ EVEN
2440+ DC.B $87
2441+ DC.B 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
2442+ DC.B 'T'|$80
2443+ DC.L CONTXT-8-NATWID
2444+*CURENT DC.L DOUSER
2445+CURENT BSR.W DOUSER
2446+ DC.L XCURR-UORIG
2447+*
2448+* ======>> 76 <<
2449+* ( --- vadr )
2450+* Compiler/interpreter state.
2451+ EVEN
2452+ DC.B $85
2453+ DC.B 'STAT' ; 'STATE' : 1 if compiling, 0 if not
2454+ DC.B 'E'|$80
2455+ DC.L CURENT-8-NATWID
2456+*STATE DC.L DOUSER
2457+STATE BSR.W DOUSER
2458+ DC.L XSTATE-UORIG
2459+*
2460+* ======>> 77 <<
2461+* ( --- vadr )
2462+* Numeric conversion base.
2463+ EVEN
2464+ DC.B 0
2465+ DC.B $84
2466+ DC.B 'BAS' ; 'BASE' : number base for all input & output
2467+ DC.B 'E'|$80
2468+ DC.L STATE-6-NATWID
2469+*BASE DC.L DOUSER
2470+BASE BSR.W DOUSER
2471+ DC.L XBASE-UORIG
2472+*
2473+* ======>> 78 <<
2474+* ( --- vadr )
2475+* Decimal point location for output.
2476+ EVEN
2477+ DC.B $83
2478+ DC.B 'DP' ; 'DPL'
2479+ DC.B 'L'|$80
2480+ DC.L BASE-5-NATWID
2481+*DPL DC.L DOUSER
2482+DPL BSR.W DOUSER
2483+ DC.L XDPL-UORIG
2484+*
2485+* ======>> 79 <<
2486+* ( --- vadr )
2487+* Field width for I/O formatting.
2488+ EVEN
2489+ DC.B $83
2490+ DC.B 'FL' ; 'FLD'
2491+ DC.B 'D'|$80
2492+ DC.L DPL-4-NATWID
2493+*FLD DC.L DOUSER
2494+FLD BSR.W DOUSER
2495+ DC.L XFLD-UORIG
2496+*
2497+* ======>> 80 <<
2498+* ( --- vadr )
2499+* Compiler stack mark for stack check.
2500+ EVEN
2501+ DC.B $83
2502+ DC.B 'CS' ; 'CSP'
2503+ DC.B 'P'|$80
2504+ DC.L FLD-4-NATWID
2505+*CSP DC.L DOUSER
2506+CSP BSR.W DOUSER
2507+ DC.L XCSP-UORIG
2508+*
2509+* ======>> 81 <<
2510+* ( --- vadr )
2511+* Editing cursor location.
2512+ EVEN
2513+ DC.B 0
2514+ DC.B $82
2515+ DC.B 'R' ; 'R#'
2516+ DC.B '#'|$80
2517+ DC.L CSP-4-NATWID
2518+*RNUM DC.L DOUSER
2519+RNUM BSR.W DOUSER
2520+ DC.L XRNUM-UORIG
2521+*
2522+* ======>> 82 <<
2523+* ( --- vadr )
2524+* Pointer to last HELD character in PAD.
2525+ EVEN
2526+ DC.B $83
2527+ DC.B 'HL' ; 'HLD'
2528+ DC.B 'D'|$80
2529+ DC.L RNUM-3-NATWID
2530+*HLD DC.L DOCON
2531+HLD BSR.W DOCON
2532+ DC.L XHLD
2533+*
2534+* ======>> 82.5 <<== SPECIAL
2535+* ( --- vadr )
2536+* Line width of active terminal.
2537+ EVEN
2538+ DC.B $87
2539+ DC.B 'COLUMN' ; 'COLUMNS' : line width of terminal
2540+ DC.B 'S'|$80
2541+ DC.L HLD-4-NATWID
2542+*COLUMS DC.L DOUSER
2543+COLUMS BSR.W DOUSER
2544+ DC.L XCOLUM-UORIG
2545+*
2546+ PAGE
2547+*
2548+* ######>> screen 38 <<
2549+**
2550+** An INCREMENTER probably should not be defined without a defined CONSTANT increment?
2551+** Ergo, defined in pairs --
2552+**
2553+** Make an INCREMENTER compiling word (not in model):
2554+** ( n --- )
2555+** { n INCREMENTER name } typical input
2556+** CREATE a header and compile the increment constant,
2557+** then overwrite the header with a call to DOINC.
2558+* DC.B $8B
2559+* DC.B 'INCREMENTE' ; 'INCREMENTER'
2560+* DC.B 'R'|$80
2561+* DC.L COLUMS-8-NATWID
2562+* INCR BSR.W DOCOL
2563+* CON,PSCODE
2564+** ( n --- ninc )
2565+** Characteristic of an INCREMENTER.
2566+** This is probably too naive:
2567+* DOINC MOVE.L (RP)+,A0
2568+* MOVE.L (A0),D0 ; Get the increment,
2569+* ADD.L D0,(PSP) ; and add it.
2570+* RTS
2571+* Compiling word should check that it is compiling a CONSTANT.
2572+* On the other hand, there are reasons not to do this:
2573+*
2574+* ======>> 83 <<
2575+* ( n --- n+1 )
2576+ EVEN
2577+ DC.B 0
2578+ DC.B $82
2579+ DC.B '1' ; '1+'
2580+ DC.B '+'|$80
2581+ DC.L COLUMS-8-NATWID
2582+* Using the model keeps things semantically connected for other processors:
2583+*ONEP DC.L DOCOL,ONE,PLUS
2584+ONEP BSR.W DOCOL ; ... or I shall convince myself of such for now.
2585+ DC.L ONE,PLUS
2586+ DC.L SEMIS
2587+** Greedy alternative:
2588+* ONEPG MOVE.L (PSP),D0
2589+* ADD.L ONEV(PC),D0
2590+* MOVE.L D0,(PSP)
2591+* RTS
2592+* Naive alternative:
2593+* ONEPI BSR.W DOINC
2594+* DC.L 1
2595+* Naive alternative:
2596+* ONEP1 ADDQ.L #1,(PSP) ; It's hard to imagine 1+ being other than 1.
2597+* RTS
2598+*
2599+* ======>> 84 <<
2600+* ( n --- n+2 )
2601+ EVEN
2602+ DC.B 0
2603+ DC.B $82
2604+ DC.B '2' ; '2+'
2605+ DC.B '+'|$80
2606+ DC.L ONEP-3-NATWID
2607+* Using the model keeps things semantically connected for other processors:
2608+*TWOP DC.L DOCOL
2609+TWOP BSR.W DOCOL
2610+ DC.L TWO,PLUS
2611+ DC.L SEMIS
2612+** Greedy alternative:
2613+* TWOPG MOVE.L (PSP),D0
2614+* ADD.L TWOV(PC),D0
2615+* MOVE.L D0,(PSP)
2616+* RTS
2617+* Naive alternative:
2618+* TWOPI BSR.W DOINC
2619+* DC.L 2
2620+* Naive alternative:
2621+* TWOP2 ADDQ.L #2,(PSP) ; It's hard to imagine 2+ being other than 2.
2622+* RTS
2623+*
2624+* ======>> 85 <<
2625+* ( --- adr )
2626+* Get the DICTPT allocation, like a USER constant.
2627+* Should check the stack and heap for collision.
2628+ EVEN
2629+ DC.B 0
2630+ DC.B $84
2631+ DC.B 'HER' ; 'HERE'
2632+ DC.B 'E'|$80
2633+ DC.L TWOP-3-NATWID
2634+*HERE DC.L DOCOL
2635+HERE BSR.W DOCOL
2636+ DC.L DICTPT,AT
2637+ DC.L SEMIS
2638+*
2639+* ======>> 86 <<
2640+* ( n --- )
2641+* Increase/decrease heap (add n to DP),
2642+* Should ERROR check stack/heap.
2643+ EVEN
2644+ DC.B $85
2645+ DC.B 'ALLO' ; 'ALLOT'
2646+ DC.B 'T'|$80
2647+ DC.L HERE-5-NATWID
2648+*ALLOT DC.L DOCOL
2649+ALLOT BSR.W DOCOL
2650+ DC.L DICTPT,PSTORE
2651+ DC.L SEMIS
2652+*
2653+* ======>> 87 <<
2654+* ( n --- )
2655+* Store word n at DP++,
2656+* Should ERROR check stack/heap.
2657+ EVEN
2658+ DC.B $81 ; , (COMMA)
2659+ DC.B ','|$80
2660+ DC.L ALLOT-6-NATWID
2661+*COMMA DC.L DOCOL
2662+COMMA BSR.W DOCOL
2663+ DC.L HERE,STORE,NATWC,ALLOT ; race condition
2664+ DC.L SEMIS
2665+*
2666+* ======>> 88 <<
2667+* ( b --- )
2668+* Store byte b at DP+,
2669+* Should ERROR check stack/heap.
2670+* Unfortunate naming.
2671+ EVEN
2672+ DC.B 0
2673+ DC.B $82
2674+ DC.B 'C' ; 'C,'
2675+ DC.B ','|$80
2676+ DC.L COMMA-2-NATWID
2677+*CCOMM DC.L DOCOL
2678+CCOMM BSR.W DOCOL
2679+ DC.L HERE,CSTORE,ONE,ALLOT ; race condition
2680+ DC.L SEMIS
2681+*
2682+* ( n --- )
2683+* Bump the DICTPT if necessary to odd or even alignment, according to n,
2684+* by compiling in an extra NUL byte.
2685+* Odd n for odd alignment, even n for even.
2686+ EVEN
2687+ DC.B $8B
2688+ DC.B 'ALIGN-COMM' ; 'ALIGN-COMMA'
2689+ DC.B 'A'|$80
2690+ DC.L CCOMM-3-NATWID
2691+*ALCOM DC.L DOCOL
2692+ALCOM BSR.W DOCOL
2693+ DC.L HERE,ZERO,ALGNB,ZBRAN
2694+ DC.L ALCOMX-*-NATWID
2695+ DC.L ZERO,CCOMM
2696+ALCOMX DC.L DROP
2697+ DC.L SEMIS
2698+*
2699+* Not in model, but needed for 32-bit.
2700+* ( h --- )
2701+* Store half cell h at DP+.
2702+* Should ERROR check stack/heap.
2703+ EVEN
2704+ DC.B 0
2705+ DC.B $82
2706+ DC.B 'H' ; 'H,'
2707+ DC.B ','|$80
2708+ DC.L ALCOM-12-NATWID
2709+*HCOMM DC.L DOCOL
2710+HCOMM BSR.W DOCOL
2711+ DC.L HERE,HSTORE,HNATWC,ALLOT ; race condition
2712+ DC.L SEMIS
2713+*
2714+* ======>> 89 <<
2715+* ( n1 n2 --- n1-n2 )
2716+* Subtract top two words.
2717+ EVEN
2718+ DC.B $81 ; -
2719+ DC.B '-'|$80
2720+ DC.L HCOMM-3-NATWID
2721+*SUB DC.L *+NATWID
2722+SUB MOVE.L (PSP)+,D0 ; Subtraction is not commutative.
2723+ SUB.L D0,(PSP) ; left side operand is the deeper one on the stack.
2724+ RTS
2725+* SUB DC.L DOCOL,MINUS,PLUS
2726+* DC.L SEMIS ; Costs extra bytes and lots of cycles compared to native code.
2727+*
2728+* ( d1 d2 --- d1-d2 )
2729+* Subtract top two integers.
2730+* Yes, we do want this in the model.
2731+ EVEN
2732+ DC.B 0
2733+ DC.B $82
2734+ DC.B 'D' ; D-
2735+ DC.B '-'|$80
2736+ DC.L SUB-2-NATWID
2737+*DSUB DC.L *+NATWID
2738+DSUB MOVEM.L (PSP)+,D0/D1/D2/D3 ; ADDX memory operand requires too much setup for just two long words.
2739+ SUB.L D1,D3 ; Right order for subtraction.
2740+ SUBX.L D0,D2
2741+ MOVEM.L D2/D3,-(PSP)
2742+ RTS
2743+*
2744+* ======>> 90 <<
2745+* ( n1 n2 --- n1==n2 )
2746+* Return flag true if n1 and n2 are equal, otherwise false.
2747+ EVEN
2748+ DC.B $81 ; =
2749+ DC.B '='|$80
2750+ DC.L DSUB-3-NATWID
2751+*EQUAL DC.L DOCOL
2752+EQUAL BSR.W DOCOL
2753+ DC.L SUB,ZEQU
2754+ DC.L SEMIS
2755+*
2756+* ======>> 91 <<
2757+* ( n1 n2 --- n1<n2 )
2758+* Return flag true if n1 is less than n2, otherwise false.
2759+* Signed compare.
2760+ EVEN
2761+ DC.B $81 ; <
2762+ DC.B '<'|$80
2763+ DC.L EQUAL-2-NATWID
2764+*LESS DC.L *+NATWID
2765+LESS CLR.L D2 ; Guess false.
2766+ MOVE.L (PSP)+,D0
2767+ MOVE.L (PSP),D1
2768+ SUB.L D0,D1
2769+ BGE.S LESSST
2770+TRUE MOVEQ #1,D2 ; MOVEQ is a little faster than ADDQ.L
2771+LESSST MOVE.L D2,(PSP)
2772+ RTS
2773+*
2774+*
2775+* ======>> 92 <<
2776+* ( n1 n2 --- n1>n2 )
2777+* Return flag true if n1 is greater than n2, false otherwise.
2778+ EVEN
2779+ DC.B $81 ; >
2780+ DC.B '>'|$80
2781+ DC.L LESS-2-NATWID
2782+*GREAT DC.L DOCOL
2783+GREAT BSR.W DOCOL
2784+ DC.L SWAP,LESS
2785+ DC.L SEMIS
2786+*
2787+* ======>> 93 <<
2788+* ( n1 n2 n3 --- n2 n3 n1 )
2789+* Rotate the top three words on stack,
2790+* bringing the third word to the top.
2791+ EVEN
2792+ DC.B $83
2793+ DC.B 'RO' ; 'ROT'
2794+ DC.B 'T'|$80
2795+ DC.L GREAT-2-NATWID
2796+*ROT DC.L *+NATWID
2797+ROT MOVEM.L (PSP),D0/D1/D2
2798+ MOVEM.L D0/D1,NATWID(PSP)
2799+ MOVE.L D2,(PSP)
2800+ RTS
2801+*
2802+* ======>> 94 <<
2803+* ( --- )
2804+* EMIT a SPACE.
2805+ EVEN
2806+ DC.B $85
2807+ DC.B 'SPAC' ; 'SPACE'
2808+ DC.B 'E'|$80
2809+ DC.L ROT-4-NATWID
2810+*SPACE DC.L DOCOL
2811+SPACE BSR.W DOCOL
2812+ DC.L BL,EMIT
2813+ DC.L SEMIS
2814+*
2815+* ======>> 95 <<
2816+* ( n0 n1 --- min(n0,n1) )
2817+* Leave the minimum of the top two integers.
2818+* Being too greedy here, but, whatever.
2819+ EVEN
2820+ DC.B $83
2821+ DC.B 'MI' ; 'MIN'
2822+ DC.B 'N'|$80
2823+ DC.L SPACE-6-NATWID
2824+*MIN DC.L *+NATWID
2825+MIN MOVE.L (PSP)+,D0
2826+ CMP.L (PSP),D0
2827+ BGE.S MINX
2828+ MOVE.L D0,(PSP)
2829+MINX RTS
2830+* MIN BSR.W DOCOL
2831+* DC.L OVER,OVER,GREAT,ZBRAN
2832+* DC.L MIN2-*-NATWID
2833+* DC.L SWAP
2834+* MIN2 DC.L DROP
2835+* DC.L SEMIS
2836+*
2837+* ======>> 96 <<
2838+* ( n0 n1 --- max(n0,n1) )
2839+* Leave the maximum of the top two integers.
2840+* Really should leave this as in the model, to reduce testing.
2841+ EVEN
2842+ DC.B $83
2843+ DC.B 'MA' ; 'MAX'
2844+ DC.B 'X'|$80
2845+ DC.L MIN-4-NATWID
2846+MAX MOVE.L (PSP)+,D0
2847+ CMP.L (PSP),D0
2848+ BLE.S MAXX
2849+ MOVE.L D0,(PSP)
2850+MAXX RTS
2851+* MAX BSR.W DOCOL
2852+* DC.L OVER,OVER,LESS,ZBRAN
2853+* DC.L MAX2-*-NATWID
2854+* DC.L SWAP
2855+* MAX2 DC.L DROP
2856+* DC.L SEMIS
2857+*
2858+* ======>> 97 <<
2859+* ( 0 --- 0 )
2860+* ( n --- n n )
2861+* DUP if non-zero.
2862+ EVEN
2863+ DC.B 0
2864+ DC.B $84
2865+ DC.B '-DU' ; '-DUP'
2866+ DC.B 'P'|$80
2867+ DC.L MAX-4-NATWID
2868+*DDUP DC.L *+NATWID ; Just being greedy for speed.
2869+DDUP MOVE.L (PSP),D0
2870+ BEQ.S DDUPX
2871+ MOVE.L D0,-(PSP)
2872+DDUPX RTS
2873+* DDUP BSR.W DOCOL
2874+* DC.L DUP,ZBRAN
2875+* DC.L DDUP2-*-NATWID
2876+* DC.L DUP
2877+* DDUP2 DC.L SEMIS
2878+*
2879+* ######>> screen 39 <<
2880+* ======>> 98.1 <<
2881+* Supplemental, intended to be used in refactoring TRAVERSE,
2882+* But really would not work there without more code:
2883+* ( n<0 --- -1 )
2884+* ( n>=~ --- 1 )
2885+* Change top integer to its sign.
2886+ EVEN
2887+ DC.B 0
2888+ DC.B $86
2889+ DC.B 'SIGNU' ; 'SIGNUM'
2890+ DC.B 'M'|$80
2891+ DC.L DDUP-5-NATWID
2892+*SIGNUM DC.L *+NATWID
2893+SIGNUM:
2894+SIGNUE CLR.L D0
2895+ TST.L (PSP)
2896+ SMI D0
2897+ EXT.W D0
2898+ EXT.L D0
2899+ MOVE.L D0,(PSP)
2900+ RTS
2901+*
2902+* ======>> 98 <<
2903+* ( adr1 direction --- adr2 )
2904+* TRAVERSE the symbol name.
2905+* If direction is 1, find the end.
2906+* If direction is -1, find the beginning.
2907+ EVEN
2908+ DC.B 0
2909+ DC.B $88
2910+ DC.B 'TRAVERS' ; 'TRAVERSE'
2911+ DC.B 'E'|$80
2912+ DC.L SIGNUM-7-NATWID
2913+TRAV MOVEQ #1,D1 ; Convert negative to -1, zero or positive to 1.
2914+ TST.L (PSP)+
2915+ BPL.S TRAVG
2916+ NEG.L D1
2917+*0 TRAVG MOVEQ #$7F,D0
2918+*0 TRAVLP LEA (A0,D1.L),A0 ; Don't look at the one we start at.
2919+*0 CMP.B (A0),D0 ; This follows the FORTH code, but, we could just look at sign bit.
2920+*0 BCC.S TRAVLP ; no scan limit, really.
2921+TRAVG MOVE #512,D0 ; Limiting scan to name length will not keep a botched symbol table from bombing.
2922+ MOVE.L (PSP),A0
2923+TRAVLP LEA (A0,D1.L),A0 ; Don't look at (A0) first (pointing to length or last).
2924+ TST.B (A0) ; Now look
2925+ BMI.S TRAVDN
2926+ DBF D0,TRAVLP ; At any rate, prevent a lockup.
2927+TRAVDN MOVE.L A0,(PSP)
2928+ RTS
2929+* Need this to be directly callable without IP (and tested) for next step.
2930+*TRAV DC.L DOCOL
2931+*TRAV BSR.W DOCOL
2932+** DC.L TRON ; DBUG *****
2933+* DC.L SWAP
2934+*TRAV2 DC.L OVER,PLUS,LIT16
2935+* DC.W $7F
2936+* DC.L OVER,CAT,LESS,ZBRAN
2937+* DC.L TRAV2-*-NATWID
2938+* DC.L SWAP,DROP
2939+** DC.L TROFF ; DBG *****
2940+* DC.L SEMIS
2941+*
2942+* ======>> 99 <<
2943+* ( --- symptr )
2944+* Fetch CURRENT as a per-USER constant.
2945+ EVEN
2946+ DC.B 0
2947+ DC.B $86
2948+ DC.B 'LATES' ; 'LATEST'
2949+ DC.B 'T'|$80
2950+ DC.L TRAV-9-NATWID
2951+*LATEST DC.L DOCOL
2952+LATEST BSR.W DOCOL
2953+ DC.L CURENT,AT,AT
2954+ DC.L SEMIS
2955+** LATEST DC.L *+NATWID
2956+* Getting too greedy:
2957+*LATEST MOVE.L XCURR-UORIG(UP),D0
2958+* MOVE.L (UP,D0.L),A0
2959+* MOVE.L (A0),A0
2960+* MOVE.L A0,-(PSP)
2961+* RTS
2962+* Too greedy, still too many semantic holes in the model to fall through.
2963+* Also, if the address at the CFA is made relative,
2964+* this is part of the code that would be affected --
2965+* especially if it is in native CPU code.
2966+*
2967+* ======>> 100 <<
2968+*
2969+* When the characteristic code is near, use/look for BSR.S or BSR.W .
2970+*
2971+* A BSR.W is 16-bit op-code and 16-bit address == 32 bits, so
2972+* PFA (parameter field address) is 4 bytes after the definition label (CFA)
2973+* in the most common near case:
2974+*
2975+* 6100 XXXX
2976+*
2977+* A BSR.S has the 8-bit offset internal to the 16-bit op-code, so
2978+* PFA is 2 bytes after the CFA in the not-uncommon very close case:
2979+*
2980+* 61XX, XX not equal 00
2981+*
2982+* Synthesizing a BSR.L on a 68000 requires a 32-bit load (6 bytes)
2983+* and a PC-relative JMP (4 bytes), which works out to 10 bytes.
2984+* PFA is 10 bytes after the definition lable in the far case on a 68000:
2985+*
2986+* 207C XXXX XXXX 4EBB 88FA
2987+*
2988+* (On 68020 and up, -- 61FF is far (32-bit) branch:
2989+*
2990+* 61FF XXXX XXXX
2991+*
2992+* XXXX offset is from the address of the byte following the BRanch or MOVE opcode.
2993+*
2994+* Use TARGL as dummy target, to avoid semantics of 0 offset.
2995+* Since the 68000 does not have BSR.L (not until the 68020), long offset branches will have to be synthesized:
2996+DOASMF MOVE.L #TARGL-(*+2),A0 ; 6 bytes, overwrite offset in long word following opcode
2997+DOASMJ JSR DOASMF+2(PC,A0.L) ; 4 bytes
2998+* Offset for PC relative indexed assumes that the object referenced is a constant table in code.
2999+TARGL:
3000+** 207C00000008 DOASMF MOVE.L #TARGL-(*+2),A0 ; 6 bytes, overwrite offset in long word following opcode
3001+** 4EBB88FA DOASMJ JSR DOASMF+2(PC,A0.L) ; 4 bytes
3002+** TARGL:
3003+DOASMW BSR.W TARGL ; overwrite offset following 16-bit op-code.
3004+** 6100FFFE DOASMW BSR.W TARGL ; overwrite offset following 16-bit op-code.
3005+DOASMS BSR.S TARGL ; overwrite offset in 2nd byte of op-code.
3006+** 61FA DOASMS BSR.S TARGL ; overwrite offset in 2nd byte of op-code.
3007+ OPT P=68020
3008+DOASML BSR.L TARGL ; overwrite offset following 16-bit op-code.
3009+ OPT P=68000
3010+** 61FFFFFFFFF8 DOASML BSR.L TARGL ; overwrite offset following 16-bit op-code.
3011+*
3012+* ( adr --- byte-count )
3013+* Test an address to see if it contains a branch.
3014+* Return byte count of op-code(s) and offset(s) from CFA if it's a branch,
3015+* zero if not.
3016+
3017+ DC.L LATEST-7-NATWID
3018+TCFAB MOVE.L (PSP),A0
3019+ CMP.B #$61,(A0) ; BSR?
3020+ BNE.S TCFABL
3021+ CMP.B #$00,1(A0) ; BSR.W?
3022+
3023+TCFABL
3024+
3025+
3026+* Wanted to do these as INCREMENTERs,
3027+* but I need to stick with the model as much as possible,
3028+* (mostly, LOL) adding code only to make the model more clear.
3029+* ( pfa --- lfa )
3030+
3031+*Have to fix this to look back for BSR.S, BSR.W, and the load and jump PC indexed
3032+
3033+* Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
3034+ EVEN
3035+ DC.B $83
3036+ DC.B 'LF' ; 'LFA'
3037+ DC.B 'A'|$80
3038+ DC.L LATEST-7-NATWID
3039+*LFA DC.L DOCOL
3040+LFA BSR.W DOCOL
3041+ DC.L LIT16
3042+* DC.W 4 ; on 6800
3043+ DC.W 2*NATWID
3044+ DC.L SUB
3045+ DC.L SEMIS
3046+*
3047+* ======>> 101 <<
3048+* ( pfa --- cfa )
3049+* Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
3050+ EVEN
3051+ DC.B $83
3052+ DC.B 'CF' ; 'CFA'
3053+ DC.B 'A'|$80
3054+ DC.L LFA-4-NATWID
3055+* CFA DC.L DOCOL,TWO,SUB ; on 6800
3056+*CFA DC.L DOCOL
3057+CFA BSR.W DOCOL
3058+ DC.L NATWC,SUB
3059+ DC.L SEMIS
3060+*
3061+* ======>> 102 <<
3062+* ( pfa --- nfa )
3063+* Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
3064+ EVEN
3065+ DC.B $83
3066+ DC.B 'NF' ; 'NFA'
3067+ DC.B 'A'|$80
3068+ DC.L CFA-4-NATWID
3069+*NFA DC.L DOCOL
3070+NFA BSR.W DOCOL
3071+ DC.L LIT16
3072+* DC.W 5 ; on 6800
3073+ DC.W NATWID*2+1
3074+ DC.L SUB,ONE,MINUS,TRAV
3075+ DC.L SEMIS
3076+*
3077+* ======>> 103 <<
3078+* ( nfa --- pfa )
3079+* Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
3080+ EVEN
3081+ DC.B $83
3082+ DC.B 'PF' ; 'PFA'
3083+ DC.B 'A'|$80
3084+ DC.L NFA-4-NATWID
3085+*PFA DC.L DOCOL
3086+PFA BSR.W DOCOL
3087+ DC.L ONE,TRAV,LIT16
3088+* DC.W 5 ; on 6800
3089+ DC.W NATWID*2+1
3090+ DC.L PLUS
3091+ DC.L SEMIS
3092+*
3093+* ######>> screen 40 <<
3094+* ======>> 104 <<
3095+* ( --- )
3096+* Save the parameter stack pointer in CSP for compiler checks.
3097+ EVEN
3098+ DC.B 0
3099+ DC.B $84
3100+ DC.B '!CS' ; '!CSP'
3101+ DC.B 'P'|$80
3102+ DC.L PFA-4-NATWID
3103+*SCSP DC.L DOCOL
3104+SCSP BSR.W DOCOL
3105+ DC.L SPAT,CSP,STORE
3106+ DC.L SEMIS
3107+*
3108+ PAGE
3109+*
3110+* ======>> 105 <<
3111+* ( 0 n --- ) ( *** )
3112+* ( true n --- IN BLK ) ( anything *** nothing )
3113+* If flag is false, do nothing.
3114+* If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
3115+* Leaves cursor position (IN)
3116+* and currently loading block number (BLK) on stack, for analysis.
3117+*
3118+* This one is too important to be high-level Forth codes.
3119+* When we have an error, we want to disturb as little as possible.
3120+* But fixing that cascades through ERROR and MESSAGE
3121+* into the disk block system.
3122+* And we aren't ready for that yet.
3123+ EVEN
3124+ DC.B 0
3125+ DC.B $86
3126+ DC.B '?ERRO' ; '?ERROR'
3127+ DC.B 'R'|$80
3128+ DC.L SCSP-5-NATWID
3129+* QERR TST.L NATWID(PSP)
3130+* BNE.S QERROR
3131+* LEA NATWID(PSP),PSP
3132+* RTS
3133+** this will require the VM and the actual machine to be in sync,
3134+** which is not guaranteed for ERRORs:
3135+* QERROR BRA.W ERROR
3136+*QERR DC.L DOCOL
3137+QERR BSR.W DOCOL
3138+ DC.L SWAP,ZBRAN
3139+ DC.L QERR2-*-NATWID
3140+ DC.L ERROR,BRAN
3141+ DC.L QERR3-*-NATWID
3142+QERR2 DC.L DROP
3143+QERR3 DC.L SEMIS
3144+*
3145+* ======>> 106 <<
3146+* STATE is compiling:
3147+* ( --- ) ( *** )
3148+* STATE is not compiling:
3149+* ( --- IN BLK ) ( anything *** nothing )
3150+* ERROR if not compiling.
3151+ EVEN
3152+ DC.B $85
3153+ DC.B '?COM' ; '?COMP'
3154+ DC.B 'P'|$80
3155+ DC.L QERR-7-NATWID
3156+*QCOMP DC.L DOCOL
3157+QCOMP BSR.W DOCOL
3158+ DC.L STATE,AT,ZEQU,LIT16
3159+ DC.W $11
3160+ DC.L QERR
3161+ DC.L SEMIS
3162+*
3163+* ======>> 107 <<
3164+* STATE is executing:
3165+* ( --- ) ( *** )
3166+* STATE is not executing:
3167+* ( --- IN BLK ) ( anything *** nothing )
3168+* ERROR if not executing.
3169+ EVEN
3170+ DC.B $85
3171+ DC.B '?EXE' ; '?EXEC'
3172+ DC.B 'C'|$80
3173+ DC.L QCOMP-6-NATWID
3174+*QEXEC DC.L DOCOL
3175+QEXEC BSR.W DOCOL
3176+ DC.L STATE,AT,LIT16
3177+ DC.W $12
3178+ DC.L QERR
3179+ DC.L SEMIS
3180+*
3181+* ======>> 108 <<
3182+* ( n1 n1 --- ) ( *** )
3183+* ( n1 n2 --- IN BLK ) ( anything *** nothing )
3184+* ERROR if top two are unequal.
3185+* MESSAGE says compiled conditionals do not match.
3186+ EVEN
3187+ DC.B 0
3188+ DC.B $86
3189+ DC.B '?PAIR' ; '?PAIRS'
3190+ DC.B 'S'|$80
3191+ DC.L QEXEC-6-NATWID
3192+QPAIRS DC.L DOCOL,SUB,LIT16
3193+ DC.W $13
3194+ DC.L QERR
3195+ DC.L SEMIS
3196+*
3197+* ======>> 109 <<
3198+* CSP and parameter stack are balanced (equal):
3199+* ( --- ) ( *** )
3200+* CSP and parameter stack are not balanced (unequal):
3201+* ( --- IN BLK ) ( anything *** nothing )
3202+* ERROR if return/control stack is not at same level as last !CSP.
3203+* Usually indicates that a definition has been left incomplete.
3204+ EVEN
3205+ DC.B 0
3206+ DC.B $84
3207+ DC.B '?CS' ; '?CSP'
3208+ DC.B 'P'|$80
3209+ DC.L QPAIRS-7-NATWID
3210+QCSP DC.L DOCOL,SPAT,CSP,AT,SUB,LIT16
3211+ DC.W $14
3212+ DC.L QERR
3213+ DC.L SEMIS
3214+*
3215+* ======>> 110 <<
3216+* Active BLK input:
3217+* ( --- ) ( *** )
3218+* No active BLK input:
3219+* ( --- IN BLK ) ( anything *** nothing )
3220+* ERROR if not loading, i. e., if BLK is zero.
3221+ EVEN
3222+ DC.B 0
3223+ DC.B $88
3224+ DC.B '?LOADIN' ; '?LOADING'
3225+ DC.B 'G'|$80
3226+ DC.L QCSP-5-NATWID
3227+QLOAD DC.L DOCOL,BLK,AT,ZEQU,LIT16
3228+ DC.W $16
3229+ DC.L QERR
3230+ DC.L SEMIS
3231+*
3232+* ######>> screen 41 <<
3233+* ======>> 111 <<
3234+* ( --- )
3235+* Compile an in-line literal value from the instruction stream.
3236+ EVEN
3237+ DC.B $87
3238+ DC.B 'COMPIL' ; 'COMPILE'
3239+ DC.B 'E'|$80
3240+ DC.L QLOAD-9-NATWID
3241+* COMPIL DC.L DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
3242+* COMPIL DC.L DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
3243+COMPIL DC.L DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
3244+ DC.L SEMIS
3245+*
3246+* ======>> 112 <<
3247+* ( --- ) P
3248+* Clear the compile state bit(s) (shift to interpret).
3249+ EVEN
3250+ DC.B $C1 ; [ immediate
3251+ DC.B '['|$80
3252+ DC.L COMPIL-8-NATWID
3253+LBRAK DC.L DOCOL,ZERO,STATE,STORE
3254+ DC.L SEMIS
3255+*
3256+* ======>> 113 <<
3257+*
3258+STCOMP EQU $C0
3259+* ( --- )
3260+* Set the compile state bit(s) (shift to compile).
3261+ EVEN
3262+ DC.B $81 ; ]
3263+ DC.B ']'|$80
3264+ DC.L LBRAK-2-NATWID
3265+RBRAK DC.L DOCOL,LIT16
3266+ DC.W STCOMP
3267+ DC.L STATE,STORE
3268+ DC.L SEMIS
3269+*
3270+* ======>> 114 <<
3271+* ( --- )
3272+* Toggle SMUDGE bit of LATEST definition header,
3273+* to hide it until defined or reveal it after definition.
3274+ EVEN
3275+ DC.B 0
3276+ DC.B $86
3277+ DC.B 'SMUDG' ; 'SMUDGE'
3278+ DC.B 'E'|$80
3279+ DC.L RBRAK-2-NATWID
3280+SMUDGE DC.L DOCOL,LATEST,LIT16
3281+ DC.W FSMUDG
3282+ DC.L TOGGLE
3283+ DC.L SEMIS
3284+*
3285+* ======>> 115 <<
3286+* ( --- )
3287+* Set the conversion base to sixteen (b00010000).
3288+ EVEN
3289+ DC.B $83
3290+ DC.B 'HE' ; 'HEX'
3291+ DC.B 'X'|$80
3292+ DC.L SMUDGE-7-NATWID
3293+HEX DC.L DOCOL
3294+ DC.L LIT16
3295+ DC.W 16 ; decimal sixteen
3296+ DC.L BASE,STORE
3297+ DC.L SEMIS
3298+*
3299+* ======>> 116 <<
3300+* ( --- )
3301+* Set the conversion base to ten (b00001010).
3302+ EVEN
3303+ DC.B $87
3304+ DC.B 'DECIMA' ; 'DECIMAL'
3305+ DC.B 'L'|$80
3306+ DC.L HEX-4-NATWID
3307+DEC DC.L DOCOL
3308+ DC.L LIT16
3309+ DC.W 10 ; decimal ten
3310+ DC.L BASE,STORE
3311+ DC.L SEMIS
3312+*
3313+* ######>> screen 42 <<
3314+* ======>> 117 <<
3315+* ( --- ) ( IP *** )
3316+* Pop the saved IP and use it to
3317+* compile the latest symbol as a reference to a ;CODE definition;
3318+* overwrite the code field of the symbol found by LATEST
3319+* with the address of the low-level characteristic code
3320+* provided in the defining definition.
3321+* Look closely at where things return, consider the operation of R> and >R .
3322+*
3323+* The machine-level code which follows (;CODE) in the instruction stream
3324+* is not executed by the defining symbol,
3325+* but becomes the characteristic of the defined symbol.
3326+* This is the usual way to generate the characteristics of VARIABLEs,
3327+* CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
3328+*
3329+* Finally, note that, if code shifts from low level back to high
3330+* (native CPU machine code calling into a list of FORTH codes),
3331+* the low level code can't just call a high-level definition.
3332+* Leaf definitions can directly call other leaf definitions,
3333+* but not non-leafs.
3334+* It will need an anonymous list, probably embedded in the low-level code,
3335+* and Y and X will have to be set appropriately before entering the list.
3336+
3337+*********
3338+********* This will have to fix up the initial branch according to the offset to the characteristic:
3339+* BSR.S (2 bytes)
3340+* BSR.W (4 bytes)
3341+* MOVE.L #difference,IX; JMP (PC,IX.L) or something (6 bytes, for those that don't have BSR.L)
3342+*********
3343+*
3344+* BSR.S offset and BSR.W offsets are both from the address of the word following the op-code lead word,
3345+* which is kind of awkward.
3346+
3347+ EVEN
3348+ DC.B $87
3349+ DC.B '(;CODE' ; '(;CODE)'
3350+ DC.B ')'|$80
3351+ DC.L DEC-8-NATWID
3352+* PSCODE DC.L DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
3353+PSCODE DC.L DOCOL,FROMR ; A5/IP is post-inc, needs no adjustment.
3354+ DC.L LATEST,PFA,CFA,STORE
3355+ DC.L SEMIS
3356+*
3357+* ======>> 118 <<
3358+* ( --- ) P
3359+* ?CSP to see if there are loose ends in the defining definition
3360+* before shifting to the assembler,
3361+* compile (;CODE) in the defining definition's instruction stream,
3362+* shift to interpreting,
3363+* make the ASSEMBLER vocabulary current,
3364+* and !CSP to mark the stack
3365+* in preparation for assembling low-level code.
3366+* Note that ;CODE, unlike DOES>, is IMMEDIATE,
3367+* and compiles (;CODE),
3368+* which will do the actual work of changing
3369+* the LATEST definition's characteristic when the defining word runs.
3370+* Assembly is done by the interpreter, rather than the compiler.
3371+* I could have avoided the anomalous three-byte code fields by
3372+*
3373+* Note that the ASSEMBLER is not part of the model (at this time).
3374+* That means that, until the assembler is ready,
3375+* if you want to define low-level words,
3376+* you have to poke (comma) in hand-assembled stuff.
3377+*
3378+ EVEN
3379+ DC.B $C5 immediate
3380+ DC.B ';COD' ; ';CODE'
3381+ DC.B 'E'|$80
3382+ DC.L PSCODE-8-NATWID
3383+SEMIC DC.L DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
3384+ DC.L NOOP ; note: will be replaced by "ASSEMBLER" later
3385+ DC.L SEMIS
3386+* note: I think I'd rather keep ?STACK here, so I'm adding a NOOP to be patched later.
3387+*
3388+* ######>> screen 43 <<
3389+* ======>> 119 <<
3390+* ( --- ) C
3391+* Make the word currently being defined
3392+* build a header for DOES> definitions.
3393+* Actually just compiles a CONSTANT zero
3394+* which can be overwritten later by DOES>.
3395+* Since the fig models were established, this technique has been deprecated.
3396+*
3397+* Note that <BUILDS is not IMMEDIATE,
3398+* and therefore executes during a definition's run-time,
3399+* rather than its compile-time.
3400+* It is not intended to be used directly,
3401+* but rather so that one definition word can build another.
3402+* Also, note that nothing particularly special happens
3403+* in the defining definition until DOES> executes.
3404+* The name <BUILDS is intended to be a reminder of what is about to occur.
3405+*
3406+* <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
3407+ EVEN
3408+ DC.B $87
3409+ DC.B '<BUILD' ; '<BUILDS'
3410+ DC.B 'S'|$80
3411+ DC.L SEMIC-6-NATWID
3412+BUILDS DC.L DOCOL,ZERO,CON
3413+ DC.L SEMIS
3414+*
3415+* ======>> 120 <<
3416+* ( --- ) ( IP *** ) C
3417+* Define run-time behavior of definitions compiled/defined
3418+* by a high-level defining definition --
3419+* the FORTH equivalent of a compiler-compiler.
3420+* DOES> assumes that the LATEST symbol table entry
3421+* has at least one word of parameter field,
3422+* which <BUILDS provides.
3423+* Note that DOES> is also not IMMEDIATE.
3424+*
3425+* When the defining word containing DOES> executes the DOES> icode,
3426+* it overwrites the LATEST symbol's CFA with jsr <XDOES,
3427+* overwrites the first word of that symbol's parameter field with its own IP,
3428+* and pops the previous IP from the return stack.
3429+* The icodes which follow DOES> in the stream
3430+* do not execute at the defining word's run-time.
3431+*
3432+* Examining XDOES in the virtual machine shows
3433+* that the defined word will execute those icodes
3434+* which follow DOES> at its own run-time.
3435+*
3436+* The advantage of this kind of behaviour,
3437+* which you will also note in ;CODE,
3438+* is that the defined word can contain
3439+* both operations and data to be operated on.
3440+* This is how FORTH data objects define their own behavior.
3441+*
3442+* Finally, note that the effective parameter field for DOES> definitions
3443+* starts two NATWID words after the CFA, instead of just one
3444+* (eight bytes instead of four in a thirty-two-bit addressing Forth).
3445+*
3446+* VOCABULARYs will use this. See definition of word FORTH.
3447+ EVEN
3448+ DC.B $85
3449+ DC.B 'DOES' ; 'DOES>'
3450+ DC.B '>'|$80
3451+ DC.L BUILDS-8-NATWID
3452+* DOES DC.L DOCOL,FROMR,TWOP,LATEST,PFA,STORE
3453+DOES DC.L DOCOL,FROMR ; A5/IP is post-inc, needs no adjustment.
3454+ DC.L LATEST,PFA,STORE
3455+ DC.L PSCODE
3456+*
3457+* ( --- PFA+NATWID ) ( *** IP )
3458+* Characteristic of a DOES> defined word.
3459+* The characteristics of DOES> definitions are written in high-level
3460+* Forth codes rather than native CPU machine level code.
3461+* The first parameter word points to the high-level characteristic.
3462+* This routine's job is to push the IP,
3463+* load the high level characteristic pointer in IP,
3464+* and leave the address following the characteristic pointer on the stack
3465+* so the parameter field can be accessed.
3466+DODOES MOVE.L (RP),A0
3467+ MOVE.L IP,(RP) ; Save/nest the current IP on the return stack.
3468+ MOVE.L (W),IP ; First parameter is new IP.
3469+ LEA NATWID(W),A1 ; Address of second parameter.
3470+ MOVE.L A1,-(PSP) ; Note that PEA would push on Forth RP
3471+ JMP (A0) ; return to NEXT.
3472+*
3473+* ######>> screen 44 <<
3474+* ======>> 121 <<
3475+* ( strptr --- strptr+1 count )
3476+* Convert counted string to string and count.
3477+* (Fetch the byte at strptr, post-increment.)
3478+ EVEN
3479+ DC.B $85
3480+ DC.B 'COUN' ; 'COUNT'
3481+ DC.B 'T'|$80
3482+ DC.L DOES-6-NATWID
3483+COUNT DC.L DOCOL,DUP,ONEP,SWAP,CAT
3484+ DC.L SEMIS
3485+*
3486+* ======>> 122 <<
3487+* ( strptr count --- )
3488+* EMIT count characters at strptr.
3489+ EVEN
3490+ DC.B 0
3491+ DC.B $84
3492+ DC.B 'TYP' ; 'TYPE'
3493+ DC.B 'E'|$80
3494+ DC.L COUNT-6-NATWID
3495+TYPE DC.L DOCOL,DDUP,ZBRAN
3496+ DC.L TYPE3-*-NATWID
3497+ DC.L OVER,PLUS,SWAP,XDO
3498+TYPE2 DC.L I,CAT,EMIT,XLOOP
3499+ DC.L TYPE2-*-NATWID
3500+ DC.L BRAN
3501+ DC.L TYPE4-*-NATWID
3502+TYPE3 DC.L DROP
3503+TYPE4 DC.L SEMIS
3504+*
3505+* ======>> 123 <<
3506+* ( strptr count1 --- strptr count2 )
3507+* Supress trailing blanks (subtract count of trailing blanks from strptr).
3508+ EVEN
3509+ DC.B $89
3510+ DC.B '-TRAILIN' ; '-TRAILING'
3511+ DC.B 'G'|$80
3512+ DC.L TYPE-5-NATWID
3513+DTRAIL DC.L DOCOL,DUP,ZERO,XDO
3514+DTRAL2 DC.L OVER,OVER,PLUS,ONE,SUB,CAT,BL
3515+ DC.L SUB,ZBRAN
3516+ DC.L DTRAL3-*-NATWID
3517+ DC.L LEAVE,BRAN
3518+ DC.L DTRAL4-*-NATWID
3519+DTRAL3 DC.L ONE,SUB
3520+DTRAL4 DC.L XLOOP
3521+ DC.L DTRAL2-*-NATWID
3522+ DC.L SEMIS
3523+*
3524+* ======>> 124 <<
3525+* ( --- )
3526+* TYPE counted string out of instruction stream (updating IP).
3527+ EVEN
3528+ DC.B 0
3529+ DC.B $84
3530+ DC.B '(."' ; '(.")'
3531+ DC.B ')'|$80
3532+ DC.L DTRAIL-10-NATWID
3533+* PDOTQ DC.L DOCOL,R,TWOP,COUNT,DUP,ONEP
3534+* PDOTQ DC.L DOCOL,R,NATP,COUNT,DUP,ONEP
3535+PDOTQ DC.L DOCOL,R ; A5/IP is post-inc.
3536+ DC.L COUNT,DUP,ONEP ; There's a count byte, too.
3537+ DC.L ZERO,ALGNB,PLUS ; Align the count.
3538+ DC.L FROMR,PLUS,TOR ; IP ready to continue after the string.
3539+ DC.L TYPE
3540+ DC.L BREAK ; DBG *****
3541+ DC.L SEMIS
3542+*
3543+* ======>> 125 <<
3544+* ( --- ) P
3545+* { ." something-to-be-printed " } typical input
3546+* Use WORD to parse to trailing quote;
3547+* if compiling, compile XDOTQ and string parsed,
3548+* otherwise, TYPE string.
3549+ EVEN
3550+ DC.B 0
3551+ DC.B $C2 immediate
3552+ DC.B '.' ; '."'
3553+ DC.B '"'|$80
3554+ DC.L PDOTQ-5-NATWID
3555+DOTQ DC.L DOCOL
3556+ DC.L LIT16
3557+ DC.W $22 ascii quote
3558+ DC.L STATE,AT,ZBRAN
3559+ DC.L DOTQ1-*-NATWID
3560+ DC.L COMPIL,PDOTQ,WORD
3561+ DC.L HERE,CAT,ONEP,DUP,ALLOT
3562+ DC.L ALGNB,ZBRAN ; Rely on PDOTQ to adjust the IP for the odd length.
3563+ DC.L DOTQ0-*-NATWID
3564+ DC.L ZERO,CCOMM ; Align and fill with NUL
3565+DOTQ0 DC.L BRAN
3566+ DC.L DOTQ2-*-NATWID
3567+DOTQ1 DC.L WORD,HERE,COUNT,TYPE
3568+DOTQ2 DC.L SEMIS
3569+*
3570+* ######>> screen 45 <<
3571+* ======>> 126 <<== MACHINE DEPENDENT
3572+* ( --- ) ( *** )
3573+* ( --- IN BLK ) ( anything *** nothing )
3574+* ERROR if parameter stack out of bounds.
3575+*
3576+* But checking whether the stack is in bounds or not
3577+* really should not use the stack.
3578+* And there really should be a ?RSTACK, as well.
3579+ EVEN
3580+ DC.B 0
3581+ DC.B $86
3582+ DC.B '?STAC' ; '?STACK'
3583+ DC.B 'K'|$80
3584+ DC.L DOTQ-3-NATWID
3585+QSTACK DC.L DOCOL,LIT16
3586+* DC.W $12
3587+ DC.W SINIT-ORIG
3588+* But why use that instead of XSPZER (S0)?
3589+* Multi-user or multi-tasking would not want that.
3590+* CMP.L XSPZER-UORIG(UP),PSP ; something like this
3591+* DC.L PORIG,AT,TWO,SUB,SPAT,LESS,ONE
3592+ DC.L PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
3593+ DC.L QERR
3594+* prints 'empty stack'
3595+*
3596+QSTAC2 DC.L SPAT
3597+* Here, we compare with a value at least 128
3598+* higher than dict. ptr. (DICTPT)
3599+* DC.L HERE,LIT16
3600+* DC.W $80 ; This is a rough check anyway, leave it as is.
3601+* But shouldn't it be the terminal width?
3602+ DC.L HERE,COLUMS,AT
3603+ DC.L PLUS,LESS,ZBRAN
3604+ DC.L QSTAC3-*-NATWID
3605+ DC.L TWO ; NOT the NATWID constant!
3606+ DC.L QERR
3607+* prints 'full stack'
3608+*
3609+QSTAC3 DC.L SEMIS
3610+*
3611+* ======>> 127 << this word's function
3612+* is done by ?STACK in this version
3613+* EVEN
3614+* DC.B $85
3615+* DC.B 4,?FREE
3616+* DC.B 'E'|$80
3617+* DC.L QSTACK-7-NATWID
3618+*QFREE DC.L DOCOL,SPAT,HERE,LIT16
3619+* DC.W $80
3620+* DC.L PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
3621+*
3622+ PAGE
3623+*
3624+* ######>> screen 46 <<
3625+* ======>> 128 <<
3626+* ( buffer n --- )
3627+* ***** Check that this is how it works here:
3628+* Get up to n-1 characters from the keyboard,
3629+* storing at buffer and echoing, with backspace editing,
3630+* quitting when a CR is read.
3631+* Terminate it with a NUL.
3632+ EVEN
3633+ DC.B 0
3634+ DC.B $86
3635+ DC.B 'EXPEC' ; 'EXPECT'
3636+ DC.B 'T'|$80
3637+ DC.L QSTACK-7-NATWID
3638+EXPECT DC.L DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
3639+* EXPEC2 DC.L KEY,DUP,LIT16
3640+EXPEC2 DC.L KEY
3641+ DC.L DUP,LIT16
3642+ DC.W BACKSP-ORIG ; again, this should be in the per-task table
3643+ DC.L PORIG,AT,EQUAL,ZBRAN ; check for backspacing
3644+ DC.L EXPEC3-*-NATWID
3645+ DC.L DROP,LIT16
3646+ DC.W 8 ; ( backspace character to emit )
3647+ DC.L OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
3648+ DC.L TOR,SUB,BRAN
3649+ DC.L EXPEC6-*-NATWID
3650+EXPEC3 DC.L DUP,LIT16
3651+ DC.W $D ; ( carriage return )
3652+ DC.L EQUAL,ZBRAN
3653+ DC.L EXPEC4-*-NATWID
3654+* DC.L BREAK ; dbg
3655+ DC.L LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
3656+ DC.L EXPEC5-*-NATWID
3657+EXPEC4 DC.L DUP
3658+* DC.L BREAK ; dbg
3659+EXPEC5 DC.L I,CSTORE,ZERO,I,ONEP,CSTORE,ZERO,I,TWOP,CSTORE ; save two NULs to make sure address is even
3660+EXPEC6 DC.L EMIT,XLOOP
3661+ DC.L EXPEC2-*-NATWID
3662+ DC.L DROP
3663+ DC.L SEMIS
3664+*
3665+* ======>> 129 <<
3666+* ( --- )
3667+* EXPECT terminal width characters to TIB.
3668+ EVEN
3669+ DC.B $85
3670+ DC.B 'QUER' ; 'QUERY'
3671+ DC.B 'Y'|$80
3672+ DC.L EXPECT-7-NATWID
3673+QUERY DC.L DOCOL,TIB,AT,COLUMS,AT
3674+* DC.L TRON ; dbg *****
3675+ DC.L EXPECT,ZERO,IN,STORE
3676+* DC.L TROFF ; dbg *****
3677+ DC.L SEMIS
3678+*
3679+* ======>> 130 <<
3680+* ( --- ) P
3681+* End interpretation of a line or screen, and/or prepare for a new block.
3682+* Note that the name of this definition is an empty string,
3683+* so it matches on the terminating NUL in the terminal or block buffer.
3684+ EVEN
3685+ DC.B $C1 ; immediate < carriage return >
3686+ DC.B $00|$80 ; NUL character (end of buffered text)
3687+ DC.L QUERY-6-NATWID
3688+NULL DC.L DOCOL,BLK,AT,ZBRAN
3689+ DC.L NULL2-*-NATWID
3690+ DC.L ONE,BLK,PSTORE
3691+ DC.L ZERO,IN,STORE,BLK,AT,BSCR,MOD
3692+ DC.L ZEQU
3693+* check for end of screen
3694+ DC.L ZBRAN
3695+ DC.L NULL1-*-NATWID
3696+ DC.L QEXEC,FROMR,DROP
3697+NULL1 DC.L BRAN
3698+ DC.L NULL3-*-NATWID
3699+NULL2 DC.L FROMR,DROP
3700+NULL3 DC.L SEMIS
3701+*
3702+ PAGE
3703+*
3704+* ######>> screen 47 <<
3705+* ======>> 133 <<
3706+* ( adr n b --- )
3707+* Fill n bytes at adr with b.
3708+* This relies on CMOVE having a certain lack of parameter checking,
3709+* where overlapping regions are not properly inverted in copy.
3710+* And this really should be done in low-level.
3711+* None of the advantages of doing things in high-level apply to fill.
3712+ EVEN
3713+ DC.B 0
3714+ DC.B $84
3715+ DC.B 'FIL' ; 'FILL'
3716+ DC.B 'L'|$80
3717+ DC.L NULL-2-NATWID
3718+FILL DC.L DOCOL
3719+* DC.L BREAK ; DBG
3720+ DC.L SWAP,TOR,OVER,CSTORE,DUP,ONEP
3721+ DC.L FROMR,ONE,SUB,CMOVE
3722+ DC.L SEMIS
3723+*
3724+* ======>> 134 <<
3725+* ( adr n --- )
3726+* Fill n bytes with 0.
3727+ EVEN
3728+ DC.B $85
3729+ DC.B 'ERAS' ; 'ERASE'
3730+ DC.B 'E'|$80
3731+ DC.L FILL-5-NATWID
3732+ERASE DC.L DOCOL,ZERO,FILL
3733+ DC.L SEMIS
3734+*
3735+* ======>> 135 <<
3736+* ( adr n --- )
3737+* Fill n bytes with ASCII SPACE.
3738+ EVEN
3739+ DC.B 0
3740+ DC.B $86
3741+ DC.B 'BLANK' ; 'BLANKS'
3742+ DC.B 'S'|$80
3743+ DC.L ERASE-6-NATWID
3744+BLANKS DC.L DOCOL,BL,FILL
3745+ DC.L SEMIS
3746+*
3747+* ======>> 136 <<
3748+* ( c --- )
3749+* Format a character at the left of the HLD output buffer.
3750+ EVEN
3751+ DC.B 0
3752+ DC.B $84
3753+ DC.B 'HOL' ; 'HOLD'
3754+ DC.B 'D'|$80
3755+ DC.L BLANKS-7-NATWID
3756+HOLD DC.L DOCOL,LIT
3757+ DC.L -1 ; $FFFF in 16-bit model, but -1 is -1. DPL flag.
3758+ DC.L HLD,PSTORE,HLD,AT,CSTORE
3759+ DC.L SEMIS
3760+*
3761+* ======>> 137 <<
3762+* ( --- adr )
3763+* Give the address of the output PAD buffer.
3764+* PAD points to the end of a 68 byte buffer for numeric conversion.
3765+* 68 bytes is enough to convert a 64-bit integer to binary.
3766+ EVEN
3767+ DC.B $83
3768+ DC.B 'PA' ; 'PAD'
3769+ DC.B 'D'|$80
3770+ DC.L HOLD-5-NATWID
3771+PAD DC.L DOCOL,HERE,LIT16
3772+ DC.W $44
3773+ DC.L PLUS
3774+ DC.L SEMIS
3775+*
3776+* ######>> screen 48 <<
3777+* ======>> 138 <<
3778+* ( c --- )
3779+* Scan a string terminated by the character c or ASCII NUL out of input;
3780+* store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
3781+* Leading c are passed over, per ENCLOSE.
3782+* Scans from BLK, or from TIB if BLK is zero.
3783+* May overwrite the numeric conversion pad,
3784+* if really long (length > 31) symbols are scanned.
3785+* Does not ALLOCate the symbol.
3786+ EVEN
3787+ DC.B 0
3788+ DC.B $84
3789+ DC.B 'WOR' ; 'WORD'
3790+ DC.B 'D'|$80
3791+ DC.L PAD-4-NATWID
3792+WORD DC.L DOCOL,BLK,AT,ZBRAN
3793+ DC.L WORD2-*-NATWID
3794+ DC.L BLK,AT,BLOCK,BRAN
3795+ DC.L WORD3-*-NATWID
3796+WORD2 DC.L TIB,AT
3797+WORD3 DC.L IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT16
3798+ DC.W MAXNML+2
3799+ DC.L BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
3800+ DC.L CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
3801+ DC.L SEMIS
3802+*
3803+* ######>> screen 49 <<
3804+* ======>> 139 <<
3805+* ( d1 string --- d2 adr )
3806+* Convert the text at string into a number, accumulating the result into d1,
3807+* leaving adr pointing to the first character not converted.
3808+* If DPL is non-negative at entry,
3809+* accumulates the number of characters converted into DPL.
3810+ EVEN
3811+ DC.B 0
3812+ DC.B $88
3813+ DC.B '(NUMBER' ; '(NUMBER)'
3814+ DC.B ')'|$80
3815+ DC.L WORD-5-NATWID
3816+PNUMB DC.L DOCOL
3817+* DC.L BREAK ; DBG *****
3818+PNUMB2 DC.L ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
3819+ DC.L PNUMB4-*-NATWID
3820+ DC.L SWAP,BASE,AT,USTAR,DROP,ROT,BASE
3821+ DC.L AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
3822+ DC.L PNUMB3-*-NATWID
3823+ DC.L ONE,DPL,PSTORE
3824+PNUMB3 DC.L FROMR,BRAN
3825+ DC.L PNUMB2-*-NATWID
3826+PNUMB4 DC.L FROMR
3827+* DC.L BREAK ; DBG *****
3828+ DC.L SEMIS
3829+*
3830+* ======>> 140 <<
3831+* ( ctstr --- d )
3832+* Convert text at ctstr to a double integer,
3833+* taking the 0 ERROR if the conversion is not valid.
3834+* If a decimal point is present,
3835+* accumulate the count of digits to the decimal point's right into DPL
3836+* (negative DPL at exit indicates single precision).
3837+* ctstr is a counted string
3838+* -- the first byte at ctstr is the length of the string,
3839+* but NUMBER ignores the count and expects a NUL terminator instead.
3840+ EVEN
3841+ DC.B 0
3842+ DC.B $86
3843+ DC.B 'NUMBE' ; 'NUMBER'
3844+ DC.B 'R'|$80
3845+ DC.L PNUMB-9-NATWID
3846+NUMB DC.L DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT16
3847+ DC.W "-" minus sign
3848+ DC.L EQUAL,DUP,TOR,PLUS,LIT
3849+ DC.L -1 ; $FFFF in 16-bit model, but -1 is -1. DPL flag.
3850+NUMB1 DC.L DPL,STORE,PNUMB,DUP,CAT,BL,SUB
3851+ DC.L ZBRAN
3852+ DC.L NUMB2-*-NATWID
3853+ DC.L DUP,CAT,LIT16
3854+ DC.W "."
3855+ DC.L SUB,ZERO,QERR,ZERO,BRAN
3856+ DC.L NUMB1-*-NATWID
3857+NUMB2 DC.L DROP,FROMR,ZBRAN
3858+ DC.L NUMB3-*-NATWID
3859+ DC.L DMINUS
3860+NUMB3 DC.L SEMIS
3861+*
3862+* ======>> 141 <<
3863+* ( --- locptr length true ) { -FIND name } typical input
3864+* ( --- false )
3865+* Parse a word, then FIND,
3866+* first in the definition vocabulary,
3867+* then in the CONTEXT (interpretation) vocabulary, if necessary.
3868+* Returns what (FIND) returns, flag and optional location and length.
3869+ EVEN
3870+ DC.B $85
3871+ DC.B '-FIN' ; '-FIND'
3872+ DC.B 'D'|$80
3873+ DC.L NUMB-7-NATWID
3874+DFIND DC.L DOCOL,BL,WORD,HERE,CONTXT,AT,AT
3875+ DC.L PFIND,DUP,ZEQU,ZBRAN
3876+ DC.L DFIND2-*-NATWID
3877+ DC.L DROP,HERE,LATEST,PFIND
3878+DFIND2 DC.L SEMIS
3879+*
3880+ PAGE
3881+* ######>> screen 50 <<
3882+* ======>> 142 <<
3883+* ( anything --- nothing ) ( anything *** nothing )
3884+* An indirection for ABORT, for ERROR,
3885+* which may be modified carefully.
3886+ EVEN
3887+ DC.B $87
3888+ DC.B '(ABORT' ; '(ABORT)'
3889+ DC.B ')'|$80
3890+ DC.L DFIND-6-NATWID
3891+PABORT DC.L DOCOL,ABORT
3892+ DC.L SEMIS
3893+*
3894+* ======>> 143 <<
3895+* ERROR ( anything line --- IN BLK ) ( anything *** nothing )
3896+* ( anything --- nothing )
3897+* ( anything *** nothing ) WARNING < 0
3898+* Prints out the last symbol scanned and MESSAGE number line. If
3899+* WARNING is less than zero, ABORTs through (ABORT), otherwise,
3900+* clears the parameter stack, pushes the INput cursor and
3901+* interpretaion BLK, and QUITs.
3902+ EVEN
3903+ DC.B $85
3904+ DC.B 'ERRO' ; 'ERROR'
3905+ DC.B 'R'|$80
3906+ DC.L PABORT-8-NATWID
3907+* This really should not be high level, according to best practices.
3908+* But fixing that cascades through MESSAGE,
3909+* requiring re-architecting the disk block system.
3910+* First, we need to get this transliteration running.
3911+ERROR DC.L DOCOL,WARN,AT,ZLESS
3912+ DC.L ZBRAN
3913+ DC.L ERROR2-*-NATWID
3914+* note: WARNING is
3915+* -1 to abort,
3916+* 0 to print error #
3917+* and 1 to print error message from disc
3918+ DC.L PABORT
3919+ERROR2 DC.L HERE,COUNT,TYPE,PDOTQ
3920+ DC.B 4,7 ; ( bell )
3921+ DC.B " ? "
3922+ DC.B 0 ; hand-align
3923+ DC.L MESS,SPSTOR,IN,AT,BLK,AT,QUIT
3924+ DC.L SEMIS
3925+*
3926+* ======>> 144 <<
3927+* ( n adr --- )
3928+* Mask byte at adr with n.
3929+* Not in FIG, don't need it for 8 bit characters after all.
3930+* EVEN
3931+* DC.B $85
3932+* DC.B 'CMAS' ; 'CMASK'
3933+* DC.B 'K'|$80
3934+* DC.L ERROR-6-NATWID
3935+* CMASK DC.L *+NATWID
3936+* MOVE.L (PSP)+,A0 ; adr
3937+* MOVE.L (PSP)+,D0 ; prepare for mask
3938+* AND.B D0,(A0)
3939+* RTS
3940+*
3941+* ( adr --- adr )
3942+* Mask high bit of tail of name in PAD buffer.
3943+* Not in FIG, need it for characters with high bit set.
3944+ EVEN
3945+ DC.B 0
3946+ DC.B $86
3947+ DC.B 'IDFLA' ; 'IDFLAT'
3948+ DC.B 'T'|$80
3949+ DC.L ERROR-6-NATWID
3950+IDFLAT DC.L *+NATWID
3951+ MOVE.L (PSP),A0
3952+ MOVE.B (A0),D1 ; get the count
3953+ AND.W #CTMASK,D1
3954+ AND.B #$7F,(A0,D1.W) ; point to the tail and clear the EndOfName flag bit.
3955+ RTS
3956+*
3957+* ( symptr --- )
3958+* Print definition's name from its NFA.
3959+ EVEN
3960+ DC.B $83
3961+ DC.B 'ID' ; 'ID.'
3962+ DC.B '.'|$80
3963+ DC.L IDFLAT-7-NATWID
3964+IDDOT DC.L DOCOL,PAD
3965+* DC.L BREAK ; DBG *****
3966+ DC.L LIT16
3967+ DC.W MAXNML ; Why did I hard code this?
3968+* DC.L WIDTH,ONEP ; Because WIDTH is a (USER) variable.
3969+ DC.L LIT16
3970+ DC.W '_' ( underline )
3971+ DC.L FILL,DUP,PFA,LFA,OVER,SUB,PAD
3972+* DC.L SWAP,CMOVE,PAD,COUNT,LIT16
3973+* DC.W NMLMSK
3974+ DC.L SWAP,CMOVE,PAD
3975+ DC.L IDFLAT
3976+ DC.L COUNT,LIT16
3977+ DC.W NMLMSK
3978+ DC.L AND,TYPE,SPACE
3979+ DC.L SEMIS
3980+*
3981+* ######>> screen 51 <<
3982+* ======>> 145 <<
3983+* ( --- ) { CREATE name } input
3984+* Parse a name (length < MAXNML characters) and create a header,
3985+* reporting first duplicate found in either the defining vocabulary
3986+* or the context (interpreting) vocabulary.
3987+* Install the header in the defining vocabulary
3988+* with CFA dangerously pointing to the parameter field.
3989+* Leave the name SMUDGEd.
3990+ EVEN
3991+ DC.B 0
3992+ DC.B $86
3993+ DC.B 'CREAT' ; 'CREATE'
3994+ DC.B 'E'|$80
3995+ DC.L IDDOT-4-NATWID
3996+CREATE DC.L DOCOL,DFIND,ZBRAN
3997+ DC.L CREAT2-*-NATWID
3998+ DC.L DROP,PDOTQ
3999+ DC.B 8
4000+ DC.B 7 ; ( bel )
4001+ DC.B "redef: "
4002+ DC.B 0 ; hand align
4003+ DC.L NFA,IDDOT,LIT16
4004+ DC.W 4
4005+ DC.L MESS,SPACE
4006+*CREAT2 DC.L HERE,DUP,CAT,WIDTH,AT,MIN ; clip to WIDTH
4007+CREAT2 DC.L BREAK,HERE,CAT,WIDTH,AT,MIN ; clip to WIDTH, hold off copying HERE ; DBG *****
4008+* Make sure it ends up aligned by moving the name.
4009+* Note that we don't need to copy beyond WIDTH.
4010+ DC.L DUP,HERE,PLUS,ONEP ; tentative LFA
4011+ DC.L ONE,AND,ZBRAN ; Will LFA, as is, be even?
4012+ DC.L CREATN-*-NATWID ; will be even
4013+
4014+ DC.L HERE,OVER,HERE,ONEP,SWAP,ONEP ; source, destination, length including count
4015+ DC.L CMOVD ; Use descending copy so it doesn't just fill.
4016+
4017+ DC.L ZERO,CCOMM ; insert a NUL byte, update HERE.
4018+
4019+* Now build header.
4020+CREATN DC.L HERE,SWAP,ONEP,ALLOT,DUP,LIT16
4021+ DC.W ($80|FSMUDG) ; Bracket the name.
4022+ DC.L TOGGLE
4023+ DC.L HERE,ONE,SUB,LIT16
4024+ DC.W $80
4025+ DC.L TOGGLE
4026+ DC.L LATEST,COMMA,CURENT,AT,STORE
4027+* DC.L HERE,TWOP,COMMA
4028+ DC.L HERE,NATP,COMMA
4029+ DC.L SEMIS
4030+*
4031+* ######>> screen 52 <<
4032+* ======>> 146 <<
4033+* ( --- ) P
4034+* { [COMPILE] name } typical use
4035+* -DFIND next WORD and COMPILE it, literally;
4036+* used to compile immediate definitions into words.
4037+ EVEN
4038+ DC.B $C9 immediate
4039+ DC.B '[COMPILE' ; '[COMPILE]'
4040+ DC.B ']'|$80
4041+ DC.L CREATE-7-NATWID
4042+BCOMP DC.L DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
4043+ DC.L SEMIS
4044+*
4045+* ======>> 147 <<
4046+* ( n --- ) if compiling. P
4047+* ( n --- n ) if interpreting.
4048+* Compile n as a literal, if compiling.
4049+ EVEN
4050+ DC.B $C7 immediate
4051+ DC.B 'LITERA' ; 'LITERAL'
4052+ DC.B 'L'|$80
4053+ DC.L BCOMP-10-NATWID
4054+LITER DC.L DOCOL,STATE,AT,ZBRAN
4055+ DC.L LITER2-*-NATWID
4056+ DC.L COMPIL,LIT,COMMA
4057+LITER2 DC.L SEMIS
4058+*
4059+* ======>> 148 <<
4060+* ( d --- ) if compiling. P
4061+* ( d --- d ) if interpreting.
4062+* Compile d as a double literal, if compiling.
4063+ EVEN
4064+ DC.B 0
4065+ DC.B $C8 immediate
4066+ DC.B 'DLITERA' ; 'DLITERAL'
4067+ DC.B 'L'|$80
4068+ DC.L LITER-8-NATWID
4069+DLITER DC.L DOCOL,STATE,AT,ZBRAN
4070+ DC.L DLITE2-*-NATWID
4071+ DC.L SWAP,LITER,LITER ; Just two literals in the right order.
4072+DLITE2 DC.L SEMIS
4073+*
4074+* ######>> screen 53 <<
4075+* ======>> 149 <<
4076+* ( --- )
4077+* Interpret or compile, according to STATE.
4078+* Searches words parsed in dictionary first, via -FIND,
4079+* then checks for valid NUMBER.
4080+* Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
4081+* ERROR checks the stack via ?STACK before returning to its caller.
4082+ EVEN
4083+ DC.B $89
4084+ DC.B 'INTERPRE' ; 'INTERPRET'
4085+ DC.B 'T'|$80
4086+* DC.L LITER-8-NATWID
4087+ DC.L DLITER-9-NATWID
4088+INTERP DC.L DOCOL
4089+INTER2 DC.L DFIND,ZBRAN
4090+ DC.L INTER5-*-NATWID
4091+ DC.L STATE,AT,LESS
4092+ DC.L ZBRAN
4093+ DC.L INTER3-*-NATWID
4094+ DC.L CFA,COMMA,BRAN
4095+ DC.L INTER4-*-NATWID
4096+INTER3 DC.L CFA,EXEC
4097+INTER4 DC.L BRAN
4098+ DC.L INTER7-*-NATWID
4099+INTER5 DC.L HERE,NUMB,DPL,AT,ONEP,ZBRAN
4100+ DC.L INTER6-*-NATWID
4101+ DC.L DLITER,BRAN
4102+ DC.L INTER7-*-NATWID
4103+INTER6 DC.L DROP,LITER
4104+INTER7 DC.L QSTACK,BRAN
4105+*INTER7 DC.L BREAK,QSTACK,BRAN ; DBG
4106+ DC.L INTER2-*-NATWID
4107+* DC.L SEMIS never executed
4108+
4109+*
4110+* ######>> screen 54 <<
4111+* ======>> 150 <<
4112+* ( --- )
4113+* Toggle precedence bit of LATEST definition header.
4114+* During compiling, most symbols scanned are compiled.
4115+* IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
4116+* but may be compiled via ' (TICK).
4117+ EVEN
4118+ DC.B $89
4119+ DC.B 'IMMEDIAT' ; 'IMMEDIATE'
4120+ DC.B 'E'|$80
4121+ DC.L INTERP-10-NATWID
4122+IMMED DC.L DOCOL,LATEST,LIT16
4123+ DC.W FIMMED
4124+ DC.L TOGGLE
4125+ DC.L SEMIS
4126+*
4127+* ======>> 151 <<
4128+* ( --- ) { VOCABULARY name } input
4129+* Create a vocabulary entry with a flag for terminating vocabulary searches.
4130+* Store the current search context in it for linking.
4131+* At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
4132+ EVEN
4133+ DC.B 0
4134+ DC.B $8A
4135+ DC.B 'VOCABULAR' ; 'VOCABULARY'
4136+ DC.B 'Y'|$80
4137+ DC.L IMMED-10-NATWID
4138+VOCAB DC.L DOCOL,BUILDS,LIT,VOCFLG,COMMA,CURENT,AT,CFA
4139+ DC.L COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
4140+* DOVOC DC.L TWOP,CONTXT,STORE
4141+DOVOC DC.L NATP,CONTXT,STORE
4142+ DC.L SEMIS
4143+*
4144+* ======>> 152 <<
4145+*
4146+* Note: FORTH does not go here in the rom-able dictionary,
4147+* since FORTH is a type of variable.
4148+*
4149+* (Should make a proper architecture for this at some point.)
4150+*
4151+*
4152+* ======>> 153 <<
4153+* ( --- )
4154+* Makes the current interpretation CONTEXT vocabulary
4155+* also the CURRENT defining vocabulary.
4156+ EVEN
4157+ DC.B $8B
4158+ DC.B 'DEFINITION' ; 'DEFINITIONS'
4159+ DC.B 'S'|$80
4160+ DC.L VOCAB-11-NATWID
4161+DEFIN DC.L DOCOL,CONTXT,AT,CURENT,STORE
4162+ DC.L SEMIS
4163+*
4164+* ======>> 154 <<
4165+* ( --- )
4166+* Parse out a comment and toss it away.
4167+* Leaves the leading characters in WORDPAD, which may or may not be useful.
4168+ EVEN
4169+ DC.B $C1 immediate (
4170+ DC.B '('|$80
4171+ DC.L DEFIN-12-NATWID
4172+PAREN DC.L DOCOL,LIT16
4173+ DC.W ")"
4174+ DC.L WORD
4175+ DC.L SEMIS
4176+*
4177+* ######>> screen 55 <<
4178+* ======>> 155 <<
4179+* ( anything *** nothing )
4180+* Clear return stack.
4181+* Then INTERPRET and, if not compiling, prompt with OK,
4182+* in infinite loop.
4183+ EVEN
4184+ DC.B 0
4185+ DC.B $84
4186+ DC.B 'QUI' ; 'QUIT'
4187+ DC.B 'T'|$80
4188+ DC.L PAREN-2-NATWID
4189+QUIT DC.L DOCOL,ZERO,BLK,STORE
4190+ DC.L BREAK ; DBG ****
4191+ DC.L LBRAK
4192+*
4193+* Here is the outer interpretter
4194+* which gets a line of input, does it, prints " OK"
4195+* then repeats :
4196+QUIT2 DC.L RPSTOR,CR,QUERY
4197+ DC.L BREAK ; DBG *****
4198+ DC.L INTERP,STATE,AT,ZEQU
4199+ DC.L ZBRAN
4200+ DC.L QUIT3-*-NATWID
4201+ DC.L PDOTQ
4202+ DC.B 3
4203+ DC.B ' OK' ; ' OK'
4204+QUIT3 DC.L BRAN
4205+ DC.L QUIT2-*-NATWID
4206+* DC.L SEMIS ( never executed )
4207+*
4208+* ======>> 156 <<
4209+* ( anything --- nothing ) ( anything *** nothing )
4210+* Clear parameter stack,
4211+* set STATE to interpret and BASE to DECIMAL,
4212+* return to input from terminal,
4213+* restore DRIVE OFFSET to 0,
4214+* print out "Forth-68",
4215+* set interpret and define vocabularies to FORTH,
4216+* and finally, QUIT.
4217+* Used to force the system to a known state
4218+* and return control to the initial INTERPRETer.
4219+ EVEN
4220+ DC.B $85
4221+ DC.B 'ABOR' ; 'ABORT'
4222+ DC.B 'T'|$80
4223+ DC.L QUIT-5-NATWID
4224+*ABORT DC.L DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
4225+ABORT DC.L DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,BREAK,PDOTQ
4226+ DC.B 15
4227+ DC.B "fig-Forth-68000"
4228+* DC.B 0 ; hand align
4229+ DC.L FORTH,DEFIN
4230+* DC.L CR,TROFF,VLIST ; (whole line is) DBG ****
4231+ DC.L QUIT
4232+* DC.L SEMIS never executed
4233+ PAGE
4234+*
4235+* ######>> screen 56 <<
4236+* bootstrap code... moves rom contents to ram :
4237+* ======>> 157 <<
4238+ EVEN
4239+ DC.B 0
4240+ DC.B $84
4241+ DC.B 'COL' ; 'COLD'
4242+ DC.B 'D'|$80
4243+ DC.L ABORT-6-NATWID
4244+COLD DC.L *+NATWID
4245+* Ultimately, we want position indepence,
4246+* so I'm using PCR where it seems reasonable.
4247+* Time for some testing.
4248+CENT MOVE.L RINIT(PC),RP ; Get a useable initial return stack,
4249+ MOVE.L SINIT(PC),PSP ; a useable initial parameter stack,
4250+* MOVE.L #IUP,UP ; and a useable initial task base (not in init table).
4251+ MOVE.L #UORIG,UP ; and a useable initial task base (not in init table).
4252+*
4253+ LEA ERAM(PC),A2 ; end of stuff to move, A2 as loop terminator
4254+ MOVE.L #RBEG,A1 ; bottom of (open-ended) destination
4255+ LEA RAM(PC),A0 ; bottom of stuff to move
4256+COLD2 MOVE.B (A0)+,(A1)+ ; move TASK & FORTH to ram
4257+ CMP.L A2,A0
4258+ BNE.S COLD2
4259+* The above leaves USE and PREV uninitialized.
4260+ MOVE.L BUFINT(PC),A2
4261+ MOVE.L A2,XUSE-UORIG(UP)
4262+ MOVE.L A2,XPREV-UORIG(UP)
4263+* ... or we could go top to bottom.
4264+* Definitely no need to use the return stack pointer like in the 6800 model,
4265+* nor to fiddle with it, since it is already pointing to a place that should be safe.
4266+ MOVE.L COLINT(PC),XCOLUM-UORIG(UP)
4267+ MOVE.L DELINT(PC),XDELAY-UORIG(UP)
4268+ MOVE.L VOCINT(PC),XVOCL-UORIG(UP)
4269+ MOVE.L DPINIT(PC),XDICTP-UORIG(UP)
4270+ MOVE.L FENCIN(PC),XFENCE-UORIG(UP)
4271+*
4272+WENT MOVE.L RINIT(PC),RP ; Get a useable initial return stack,
4273+ MOVE.L SINIT(PC),PSP ; a useable initial parameter stack,
4274+* MOVE.L #IUP,UP ; and a useable initial task base (not in init table).
4275+ MOVE.L #UORIG,UP ; and a useable initial task base (not in init table).
4276+*
4277+ LEA SINIT(PC),A2 ; for loop termination
4278+ LEA XFENCE-UORIG(UP),A1 ; top of destination
4279+ LEA FENCIN(PC),A0 ; top of stuff to move
4280+WARM2 MOVE.L -(A0),-(A1) ; All entries are 32 bit.
4281+ CMP.L A2,A0
4282+ BNE.S WARM2
4283+*
4284+ LEA ABORT+NATWID(PC),IP ; IP never points to DOCOL!
4285+*
4286+ NOP ; Here is a place to jump to special user
4287+ NOP ; initializations such as I/0 interrups
4288+ NOP
4289+*
4290+
4291+
4292+* For systems with TRACE:
4293+ CLR.L (RP) ; The hole above the return stack
4294+ CLR.L (PSP) ; The hole above the parameter stack
4295+ LEA N(PC),A0
4296+ CLR.W TRLIM-N(A0) ; clear trace limit (all bytes)
4297+ CLR.W TRACEM-N(A0) ; and mode (all bytes)
4298+* DBG:
4299+* ADDQ.W #1,TRACEM-N(A0) ; DBG *******************
4300+ CLR.L BRKPT-N(A0) ; clear breakpoint address
4301+ BRA.W RPSTOR+NATWID ; start the virtual machine running !
4302+* RPSTOR's NEXT will pick up the IP set above, and start ABORT.
4303+* RP! sets up the return stack pointer, then IP references abort.
4304+
4305+* Comment out the branch above and use something like this to jump direct to test code:
4306+* LEA TESTMIN(PC),IP
4307+* RTS
4308+
4309+*
4310+* Here is the stuff that gets copied to ram :
4311+* (not * at address $140:)
4312+* at an appropriate address:
4313+*
4314+* RAM DC.L $3000,$3000,0,0
4315+* RAM DC.L BUFBAS,BUFBAS,0,0 ; ... except the direct page has moved.
4316+* These initialization values for USE and PREV were here to help pack the code.
4317+* They don't belong here unless we move the USER table
4318+* back below the writable dictionary,
4319+* *and* move these USER variables to the end of the direct page --
4320+* *or* let these definitions exist in the USER table.
4321+RAM EQU * ; Does RAM need to have the BUFfer BASe address before RFORTH?
4322+
4323+* ======>> (152) <<
4324+* ( --- ) P
4325+* Makes FORTH the current interpretation vocabulary.
4326+* In order to make this ROMmable,
4327+* this entry is set up as the tail-end of its VOCABULARY,
4328+* and copied to RAM in the start-up code.
4329+* We want a more elegant solution to this, too. Greedy, maybe.
4330+ EVEN
4331+ DC.B $C5 immediate
4332+ DC.B 'FORT' ; 'FORTH'
4333+ DC.B 'H'|$80
4334+ DC.L NOOP-5-NATWID ; Note that this does not link to COLD!
4335+RFORTH DC.L DODOES,DOVOC,VOCFLG,TASK-5-NATWID
4336+ DC.L 0
4337+ DC.B "Copyright 1979 Forth Interest Group, David Lion,"
4338+ DC.B $0D
4339+ DC.B "Parts Copyright 2019 Joel Matthew Rees"
4340+ DC.B $0D
4341+*
4342+ EVEN
4343+ DC.B 0
4344+ DC.B $84
4345+ DC.B 'TAS' ; 'TASK'
4346+ DC.B 'K'|$80
4347+ DC.L FORTH-6-NATWID
4348+RTASK DC.L DOCOL,SEMIS
4349+ERAM EQU *
4350+ERAMSZ EQU *-RAM ; So we can get a look at it.
4351+*
4352+ PAGE
4353+* ######>> screen 57 <<
4354+* ======>> 158 <<
4355+* ( n0 --- d0 )
4356+* Sign extend n0 to a double integer.
4357+ EVEN
4358+ DC.B 0
4359+ DC.B $84
4360+ DC.B 'S->' ; 'S->D'
4361+ DC.B 'D'|$80
4362+ DC.L COLD-5-NATWID ; Note that this does not link to FORTH (RFORTH)!
4363+STOD DC.L DOCOL,DUP,ZLESS,MINUS
4364+ DC.L SEMIS
4365+
4366+
4367+*
4368+* ======>> 159 <<
4369+* ( multiplier multiplicand --- product )
4370+* Signed word multiply.
4371+ EVEN
4372+ DC.B $81 ; *
4373+ DC.B '*'|$80
4374+ DC.L STOD-5-NATWID
4375+STAR DC.L DOCOL
4376+ DC.L USTAR,DROP,SEMIS ; Drop high word.
4377+* STAR DC.L *+NATWID
4378+* BSR.W USTAR+NATWID
4379+* LEA NATWID(PSP),PSP ; Drop high word. Seems like magic, doesn't it?
4380+* RTS
4381+*
4382+* ======>> 160 <<
4383+* ( dividend divisor --- remainder quotient )
4384+* M/ in word-only form, i. e., signed division of 2nd word by top word,
4385+* yielding signed word quotient and remainder.
4386+* Except *BUG* it isn't signed.
4387+ EVEN
4388+ DC.B 0
4389+ DC.B $84
4390+ DC.B '/MO' ; '/MOD'
4391+ DC.B 'D'|$80
4392+ DC.L STAR-2-NATWID
4393+SLMOD DC.L DOCOL,TOR,STOD,FROMR,USLASH
4394+ DC.L SEMIS
4395+*
4396+* ======>> 161 <<
4397+* ( dividend divisor --- quotient )
4398+* Signed word divide without remainder.
4399+* Except *BUG* it isn't signed.
4400+ EVEN
4401+ DC.B $81 ; /
4402+ DC.B '/'|$80
4403+ DC.L SLMOD-5-NATWID
4404+SLASH DC.L DOCOL,SLMOD,SWAP,DROP
4405+ DC.L SEMIS
4406+*
4407+* ======>> 162 <<
4408+* ( dividend divisor --- remainder )
4409+* Remainder function, result takes sign of dividend.
4410+ EVEN
4411+ DC.B $83
4412+ DC.B 'MO' ; 'MOD'
4413+ DC.B 'D'|$80
4414+ DC.L SLASH-2-NATWID
4415+MOD DC.L DOCOL,SLMOD,DROP
4416+ DC.L SEMIS
4417+*
4418+* ======>> 163 <<
4419+* ( multiplier multiplicand divisor --- remainder quotient )
4420+* Signed precise division of product:
4421+* multiply 2nd and 3rd words on stack
4422+* and divide the 31-bit product by the top word,
4423+* leaving both quotient and remainder.
4424+* Remainder takes sign of product.
4425+* Guaranteed not to lose significant bits in 16 bit integer math.
4426+ EVEN
4427+ DC.B $85
4428+ DC.B '*/MO' ; '*/MOD'
4429+ DC.B 'D'|$80
4430+ DC.L MOD-4-NATWID
4431+SSMOD DC.L DOCOL,TOR,USTAR,FROMR,USLASH
4432+ DC.L SEMIS
4433+*
4434+* ======>> 164 <<
4435+* ( multiplier multiplicand divisor --- quotient )
4436+* */MOD without remainder.
4437+ EVEN
4438+ DC.B 0
4439+ DC.B $82
4440+ DC.B '*' ; '*/'
4441+ DC.B '/'|$80
4442+ DC.L SSMOD-6-NATWID
4443+SSLASH DC.L DOCOL,SSMOD,SWAP,DROP
4444+ DC.L SEMIS
4445+*
4446+* ======>> 165 <<
4447+* ( ud1 u1 --- u2 ud2 )
4448+* U/ with an (unsigned) double quotient.
4449+* Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
4450+* if you are prepared to deal with the extra 16 bits of result.
4451+ EVEN
4452+ DC.B $85
4453+ DC.B 'M/MO' ; 'M/MOD'
4454+ DC.B 'D'|$80
4455+ DC.L SSLASH-3-NATWID
4456+MSMOD DC.L DOCOL,TOR,ZERO,R,USLASH
4457+ DC.L FROMR,SWAP,TOR,USLASH,FROMR
4458+ DC.L SEMIS
4459+*
4460+* ======>> 166 <<
4461+* ( n>=0 --- n )
4462+* ( n<0 --- -n )
4463+* Convert the top of stack to its absolute value.
4464+ EVEN
4465+ DC.B $83
4466+ DC.B 'AB' ; 'ABS'
4467+ DC.B 'S'|$80
4468+ DC.L MSMOD-6-NATWID
4469+ABS DC.L DOCOL,DUP,ZLESS,ZBRAN
4470+ DC.L ABS2-*-NATWID
4471+ DC.L MINUS
4472+ABS2 DC.L SEMIS
4473+*
4474+* ======>> 167 <<
4475+* ( d>=0 --- d )
4476+* ( d<0 --- -d )
4477+* Convert the top double to its absolute value.
4478+ EVEN
4479+ DC.B 0
4480+ DC.B $84
4481+ DC.B 'DAB' ; 'DABS'
4482+ DC.B 'S'|$80
4483+ DC.L ABS-4-NATWID
4484+DABS DC.L DOCOL,DUP,ZLESS,ZBRAN
4485+ DC.L DABS2-*-NATWID
4486+ DC.L DMINUS
4487+DABS2 DC.L SEMIS
4488+*
4489+ PAGE
4490+* ######>> screen 58 <<
4491+* Disc primitives :
4492+* ======>> 168 <<
4493+* ( --- vadr )
4494+* Least Recently Used buffer.
4495+* Really should be with FIRST and LIMIT in the per-task table.
4496+ EVEN
4497+ DC.B $83
4498+ DC.B 'US' ; 'USE'
4499+ DC.B 'E'|$80
4500+ DC.L DABS-5-NATWID
4501+USE DC.L DOCON
4502+ DC.L XUSE ; The address of XUSE is the constant.
4503+* ======>> 169 <<
4504+* ( --- vadr )
4505+* Most Recently Used buffer.
4506+* Really should be with FIRST and LIMIT in the per-task table.
4507+ EVEN
4508+ DC.B 0
4509+ DC.B $84
4510+ DC.B 'PRE' ; 'PREV'
4511+ DC.B 'V'|$80
4512+ DC.L USE-4-NATWID
4513+PREV DC.L DOCON
4514+ DC.L XPREV ; The address of XPREV is the constant.
4515+* ======>> 170 <<
4516+* ( buffer1 --- buffer2 f )
4517+* Bump to next buffer,
4518+* flag false if result is PREVious buffer,
4519+* otherwise flag true.
4520+* Used in the LRU allocation routines.
4521+ EVEN
4522+ DC.B 0
4523+ DC.B $84
4524+ DC.B '+BU' ; '+BUF'
4525+ DC.B 'F'|$80
4526+ DC.L PREV-5-NATWID
4527+* PBUF DC.L DOCOL,LIT16
4528+* DC.W $84 ; This was a hard-wiring bug.
4529+PBUF DC.L DOCOL,BBUF,BCTL,PLUS ; Size of the buffer record.
4530+* DC.L PLUS,DUP,LIMIT,EQUAL,ZBRAN
4531+ DC.L PLUS,DUP,LIMIT,LESS,ZEQU,OVER,FIRST,LESS,OR,ZBRAN
4532+ DC.L PBUF2-*-NATWID ; Use defensive programming.
4533+ DC.L DROP,FIRST
4534+PBUF2 DC.L DUP,PREV,AT,SUB
4535+ DC.L SEMIS
4536+*
4537+* ======>> 171 <<
4538+*
4539+UPDATB EQU $80000000 ; $8000 in the 6800 model -- puts limits on sector count.
4540+*
4541+* ( --- f )
4542+* Flag to mark a buffer dirty, in need of being written out.
4543+* This flag limits the max number of sectors in a disk to ((256^NATWID)/2)-1.
4544+* It also hard-codes an implicit test which is used elsewhere.
4545+ EVEN
4546+ DC.B 0
4547+ DC.B $8A
4548+ DC.B 'UPDATE-BI' ; 'UPDATE-BIT'
4549+ DC.B 'T'|$80
4550+ DC.L PBUF-5-NATWID
4551+UPDBIT DC.L DOCON
4552+ DC.L UPDATB
4553+*
4554+* ( --- )
4555+* Mark PREVious buffer dirty, in need of being written out.
4556+ EVEN
4557+ DC.B 0
4558+ DC.B $86
4559+ DC.B 'UPDAT' ; 'UPDATE'
4560+ DC.B 'E'|$80
4561+ DC.L UPDBIT-11-NATWID
4562+* UPDATE DC.L DOCOL,PREV,AT,AT,LIT,UPDATB,OR,PREV,AT,STORE
4563+UPDATE DC.L DOCOL,PREV,AT,AT,UPDBIT,OR,PREV,AT,STORE
4564+ DC.L SEMIS
4565+*
4566+* ======>> 172 <<
4567+*
4568+* Going to leave the 0 sector bug in place, I guess. Maybe.
4569+* ( adr --- )
4570+** Mark the buffer addressed as empty.
4571+** Have to add code to avoid block 0 appearing to be in a buffer from COLD.
4572+** Usually, there is no sector 0 (?), but the RAM buffers are too simple.
4573+** Note that without this block number being made illegal,
4574+** about 8 binaryMegabytes (256 bytes/block) of disk can be addressed total.
4575+** With this block number made illegal, the max is 1 block less,
4576+** still about 8 biMeg.
4577+* EVEN
4578+* DC.B $8B
4579+* DC.B 'KILL-BUFFE' ; 'KILL-BUFFER'
4580+* DC.B 'R'|$80
4581+* DC.L UPDATE-7-NATWID
4582+*KILBUF DC.L *+NATWID ; DOCOL,UPDBIT,ONE,SUB,SWAP,STORE
4583+* MOVE.L (PSP)+,A0
4584+* MOVE.L UPDBIT+NATWID(PC),D0
4585+* SUBQ.L #1,D0
4586+* MOVE.L D0,(A0)
4587+* RTS
4588+*
4589+* ( --- )
4590+* Mark all buffers empty.
4591+* EVEN
4592+* DC.B 0
4593+* DC.B $8C
4594+* DC.B 'KILL-BUFFER' ; 'KILL-BUFFERS'
4595+* DC.B 'S'|$80
4596+* DC.L KILBUF-12-NATWID
4597+*KLBFS DC.L DOCOL,FIRST,LIT16
4598+* DC.W 4 ; Want to make sure it's only four.
4599+* DC.L ZERO,XDO ; It would be "cleaner" to let +BUF control the loop.
4600+* DC.L DUP,KILBUF,PBUF,DROP,XLOOP
4601+* DC.L DROP,SEMIS
4602+** KLBFS DC.L *+NATWID
4603+** LDD #4
4604+** PSHU D
4605+** LDD FIRST+NATWID,PCR
4606+** INC <TRACEM
4607+** LBSR DBGREG
4608+** PSHU D ; DUP
4609+** KLBFSL PSHU D
4610+** BSR KILBUF+NATWID
4611+** LDD ,U
4612+** LBSR DBGREG
4613+** ADDD BBUF+NATWID,PCR
4614+** ADDD BCTL+NATWID,PCR
4615+** STD ,U
4616+** LBSR DBGREG
4617+** DEC NATWID+1,U
4618+** BNE KLBFSL
4619+** LBSR DBGREG
4620+** LEAU NATWID*2,U
4621+** DEC <TRACEM
4622+** LBRA NEXT
4623+*
4624+* ( --- )
4625+* Erase and mark all buffers empty.
4626+* Standard method of discarding changes.
4627+ EVEN
4628+ DC.B $8D
4629+ DC.B 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
4630+ DC.B 'S'|$80
4631+* DC.L KLBFS-13-NATWID
4632+ DC.L UPDATE-7-NATWID
4633+MTBUF DC.L DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
4634+* DC.L FIRST,DUP,KILBUF,PBUF,DROP,DUP,KILBUF
4635+* DC.L PBUF,DROP,DUP,KILBUF,PBUF,DROP,KILBUF
4636+* DC.L KLBFS
4637+ DC.L SEMIS
4638+*
4639+* ======>> 173 <<
4640+* ( --- )
4641+* Clear the current offset to the block numbers in the drive interface.
4642+* The drives need to be re-architected.
4643+* Would be cool to have RAM and ROM drives supported
4644+* in addition to regular physical persistent store.
4645+ EVEN
4646+ DC.B $83
4647+ DC.B 'DR' ; 'DR0'
4648+ DC.B '0'|$80
4649+ DC.L MTBUF-14-NATWID
4650+DRZERO DC.L DOCOL,ZERO,OFSET,STORE
4651+ DC.L SEMIS
4652+*
4653+* ======>> 174 <<== system dependant word
4654+* ( --- )
4655+* Set the current offset in the drive interface to reference the second drive.
4656+* The hard-coded number in there needs to be in a table.
4657+ EVEN
4658+ DC.B $83
4659+ DC.B 'DR' ; 'DR1'
4660+ DC.B '1'|$80
4661+ DC.L DRZERO-4-NATWID
4662+*DRONE DC.L DOCOL,LIT,$07D0,OFSET,STORE
4663+; **** hard-codes the size of the disc !!!!
4664+DRONE DC.L DOCOL,LIT,RAMDSZ,OFSET,STORE
4665+ DC.L SEMIS
4666+*
4667+* ######>> screen 59 <<
4668+* ======>> 175 <<
4669+* ( n --- buffer )
4670+* Get a free buffer,
4671+* assign it to block n,
4672+* return buffer address.
4673+* Will free a buffer by writing it, if necessary.
4674+* Does not actually read the block.
4675+* A bug in the fig LRU algorithm, which I have not fixed,
4676+* gives the PREVious buffer if USE gets set to PREVious.
4677+* (The bug is that USE sometimes gets set to PREVious.)
4678+* This bug sometimes causes sector moves to become sector fills.
4679+ EVEN
4680+ DC.B 0
4681+ DC.B $86
4682+ DC.B 'BUFFE' ; 'BUFFER'
4683+ DC.B 'R'|$80
4684+ DC.L DRONE-4-NATWID
4685+BUFFER DC.L DOCOL,USE,AT,DUP,TOR
4686+BUFFR2 DC.L PBUF,ZBRAN
4687+ DC.L BUFFR2-*-NATWID
4688+ DC.L USE,STORE,R,AT,ZLESS
4689+ DC.L ZBRAN
4690+ DC.L BUFFR3-*-NATWID
4691+* DC.L R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
4692+ DC.L R,NATP,R,AT,UPDBIT,LNOT,AND,ZERO,RW
4693+* BUFFR3 DC.L R,STORE,R,PREV,STORE,FROMR,TWOP
4694+BUFFR3 DC.L R,STORE,R,PREV,STORE,FROMR,NATP
4695+ DC.L SEMIS
4696+*
4697+* ######>> screen 60 <<
4698+* ======>> 176 <<
4699+* ( n --- buffer )
4700+* Get BUFFER containing block n, relative to OFFSET.
4701+* If block n is not in a buffer, bring it in.
4702+* Returns buffer address.
4703+ EVEN
4704+ DC.B $85
4705+ DC.B 'BLOC' ; 'BLOCK'
4706+ DC.B 'K'|$80
4707+ DC.L BUFFER-7-NATWID
4708+BLOCK DC.L DOCOL,OFSET,AT,PLUS,TOR
4709+ DC.L PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
4710+ DC.L BLOCK5-*-NATWID
4711+BLOCK3 DC.L PBUF,ZEQU,ZBRAN
4712+ DC.L BLOCK4-*-NATWID
4713+* DC.L DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
4714+ DC.L DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
4715+BLOCK4 DC.L DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
4716+ DC.L BLOCK3-*-NATWID
4717+ DC.L DUP,PREV,STORE
4718+* BLOCK5 DC.L FROMR,DROP,TWOP
4719+BLOCK5 DC.L FROMR,DROP,NATP
4720+ DC.L SEMIS
4721+*
4722+* ######>> screen 61 <<
4723+* ======>> 177 <<
4724+* ( line screen --- buffer C/L)
4725+* Bring in the sector containing the specified line of the specified screen.
4726+* Returns the buffer address and the width of the screen.
4727+* Screen number is relative to OFFSET.
4728+* The line number may be beyond screen 4,
4729+* (LINE) will get the appropriate screen.
4730+ EVEN
4731+ DC.B 0
4732+ DC.B $86
4733+ DC.B '(LINE' ; '(LINE)'
4734+ DC.B ')'|$80
4735+ DC.L BLOCK-6-NATWID
4736+PLINE DC.L DOCOL,TOR,LIT16
4737+ DC.W $40
4738+ DC.L BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT16
4739+ DC.W $40
4740+ DC.L SEMIS
4741+*
4742+* ======>> 178 <<
4743+* ( line screen --- )
4744+* Print the line of the screen as found by (LINE), suppress trailing BLANKS.
4745+ EVEN
4746+ DC.B $85
4747+ DC.B '.LIN' ; '.LINE'
4748+ DC.B 'E'|$80
4749+ DC.L PLINE-7-NATWID
4750+DLINE DC.L DOCOL,PLINE,DTRAIL,TYPE
4751+ DC.L SEMIS
4752+*
4753+* ======>> 179 <<
4754+* ( n --- )
4755+* If WARNING is 0, print "MESSAGE #n";
4756+* otherwise, print line n relative to screen 4,
4757+* the line number may be negative.
4758+* Uses .LINE, but counter-adjusts to be relative to the real drive 0.
4759+* BUG: -DUP will cause this to reach farther into the stack than the error number
4760+* when WARNING is set and err# is zero (can't find entry in dictionary).
4761+ EVEN
4762+ DC.B $87
4763+ DC.B 'MESSAG' ; 'MESSAGE'
4764+ DC.B 'E'|$80
4765+ DC.L DLINE-6-NATWID
4766+MESS DC.L DOCOL,WARN,AT,ZBRAN
4767+ DC.L MESS3-*-NATWID
4768+ DC.L DDUP,ZBRAN ; -DUP here is a bug from the original 6800 model, at least.
4769+ DC.L MESS3-*-NATWID
4770+ DC.L LIT16
4771+ DC.W 4
4772+ DC.L OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
4773+ DC.L MESS4-*-NATWID
4774+MESS3 DC.L PDOTQ
4775+ DC.B 6
4776+ DC.B 'err # ' ; 'err # '
4777+ DC.B 0 ; hand align
4778+ DC.L DOT
4779+MESS4 DC.L SEMIS
4780+*
4781+* ======>> 180 <<
4782+* ( n --- )
4783+* Begin interpretation of screen (block) n.
4784+* See also ARROW, SEMIS, and NULL.
4785+ EVEN
4786+ DC.B 0
4787+ DC.B $84
4788+ DC.B 'LOA' ; 'LOAD' : input:scr #
4789+ DC.B 'D'|$80
4790+ DC.L MESS-8-NATWID
4791+LOAD DC.L DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
4792+ DC.L BSCR,STAR,BLK,STORE
4793+ DC.L INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
4794+ DC.L SEMIS
4795+*
4796+* ======>> 181 <<
4797+* ( --- ) P
4798+* Continue interpreting source code on the next screen.
4799+ EVEN
4800+ DC.B $C3
4801+ DC.B '--' ; '-->'
4802+ DC.B '>'|$80
4803+ DC.L LOAD-5-NATWID
4804+ARROW DC.L DOCOL,QLOAD,ZERO,IN,STORE,BSCR
4805+ DC.L BLK,AT,OVER,MOD,SUB,BLK,PSTORE
4806+ DC.L SEMIS
4807+*
4808+ PAGE
4809+*
4810+* ######>> screen 63 <<
4811+* The next clot of subroutines are machine dependent.
4812+* PEMIT, PKEY, PQTER, and PCR (_P_arenthetic versions) are called by
4813+* EMIT, KEY, QTERM, and CR, words 13 through 16 in the dictionary.
4814+* This is all native CPU code.
4815+*
4816+* ATARI BIOS call parameters on _A7_ == SP. (Not PSP!)
4817+* Defining for Atari ST BIOS:
4818+* Atari BIOS messes with D0-D2/A0-A2.
4819+* We do not know D0/D1/A0/A1 are safe to overwrite in our runtime.
4820+*
4821+* ======>> 185 << code for CR
4822+* ( --- ) No stack effect.
4823+* Output a CR/LF combo to the CONSOLE device
4824+* using the Atari ST BIOS.
4825+* Move this here to keep it in reach of short branch.
4826+PCR MOVEM.L D1,-(SP) Don't destroy D1.
4827+ MOVE.W #$0D,D1
4828+ BSR.S PEMIT
4829+ MOVE.W #$0A,D1
4830+ BSR.S PEMIT ; Don't rob PEMIT's return.
4831+ MOVEM.L (SP)+,D1 ; Restore D1
4832+ RTS
4833+*
4834+* ( --- ) No parameter stack effect.
4835+* Assume volatile registers saved,
4836+* Use Atari terminal emulation to turn the text cursor on.
4837+PCURON MOVEM.L D1,-(SP) Don't destroy D1.
4838+ MOVE.W #$1B,D1
4839+ BSR.S PEMIT
4840+ MOVE.W #'e',D1
4841+ BSR.S PEMIT ; Don't rob PEMIT's return.
4842+ MOVEM.L (SP)+,D1 ; Restore D1
4843+ RTS
4844+*
4845+* ( --- ) No parameter stack effect.
4846+* Assume volatile registers saved,
4847+* Use Atari terminal emulation to turn the text cursor off.
4848+PCROFF MOVEM.L D1,-(SP) Don't destroy D1.
4849+ MOVE.W #$1B,D1
4850+ BSR.S PEMIT
4851+ MOVE.W #'f',D1
4852+ BSR.S PEMIT ; Don't rob PEMIT's return.
4853+ MOVEM.L (SP)+,D1 ; Restore D1
4854+ RTS
4855+*
4856+* ======>> 182 << code for EMIT
4857+* ( --- ) No parameter stack effect.
4858+* Put one byte from D1 out on the CONSOLE device
4859+* using Atari ST BIOS.
4860+PEMIT MOVEM.L D0/D1/D2/A0/A1/A2,-(PSP) ; Save volatile registers, D0 lowest.
4861+ LEA -6(SP),SP ; allocate BIOS parameter space
4862+PEMITW MOVE.W #2,2(SP) ; console device
4863+ MOVE.W #8,(SP) ; bcostat
4864+ TRAP #13 ; BIOS call
4865+ TST.L D0 ; not really necessary?
4866+ BEQ.S PEMITW ; wait for CONSOLE out ready
4867+ MOVE.W NATWID+NATWID/2(PSP),4(SP) ; low word of PSP top is character to output
4868+ MOVE.W #2,2(SP) ; console device
4869+ MOVE.W #3,(SP) ; bconout
4870+ TRAP #13 ; BIOS call
4871+ LEA 6(SP),SP ; deallocate BIOS workspace
4872+ MOVEM.L (PSP)+,D0/D1/D2/A0/A1/A2 ; Restore volatile registers and parameter stack.
4873+ RTS
4874+*
4875+* ======>> 183 << code for KEY
4876+* ( --- ) No parameter stack effect.
4877+* Wait for one keypress from the CONSOLE device
4878+* and return the character code for the key pressed in D1
4879+* using Atari ST BIOS.
4880+PKEY MOVEM.L D0/D2/A0/A1/A2,-(PSP) ; Save volatile registers.
4881+ BSR.S PCURON ; Show the cursor
4882+PKEYG MOVE.W #2,-(SP) ; console device
4883+ MOVE.W #2,-(SP) ; bconin
4884+ TRAP #13 ; BIOS call
4885+ LEA 4(SP),SP ; clean up stack
4886+PKEYT BSR.S PCROFF
4887+ CMP.B #3,D0 ; CTL-C? (Atari BIOS emulates a nice terminal.)
4888+ BNE.S PKEYX
4889+ OR.L #$FFFFFF00,D0 ; set the N flag
4890+PKEYX MOVE.L D0,D1 ; KEY and QTERM expect it in D1.
4891+ MOVEM.L (PSP)+,D0/D2/A0/A1/A2 ; Restore registers without touching flags.
4892+ RTS
4893+*
4894+* ######>> screen 64 <<
4895+* ======>> 184 << code for ?TERMINAL
4896+* ( --- ) No stack effect.
4897+* Check for break key on the CONSOLE device without waiting
4898+* using Atari ST BIOS.
4899+PQTER MOVEM.L D0/D2/A0/A1/A2,-(PSP) ; Save D2.
4900+ MOVE.W #2,-(SP) ; console device
4901+ MOVE.W #1,-(SP) ; bconstat
4902+ TRAP #13 ; BIOS call
4903+ LEA 4(SP),SP ; clean up stack, don't wait
4904+ TST.L D0 ; Got a key?
4905+ BMI.S PKEYG ; Get the key, but D2 already saved.
4906+ BRA.S PKEYX ; Rob PKEY's tail and restore.
4907+*
4908+* ######>> screen 66 <<
4909+* ======>> 187 <<
4910+* ( ??? )
4911+* Query the disk, I suppose.
4912+* Not sure what the model had in mind for this stub.
4913+ EVEN
4914+ DC.B $85
4915+ DC.B '?DIS' ; '?DISC'
4916+ DC.B 'C'|$80
4917+ DC.L ARROW-4-NATWID
4918+QDISC DC.L *+NATWID
4919+ JMP NEXT
4920+*
4921+* ######>> screen 67 <<
4922+* ======>> 189 <<
4923+* ( ??? )
4924+* Write one block of data to disk.
4925+* Parameters unspecified in model. Stub in model.
4926+ EVEN
4927+ DC.B $8B
4928+ DC.B 'BLOCK-WRIT' ; 'BLOCK-WRITE'
4929+ DC.B 'E'|$80
4930+ DC.L QDISC-6-NATWID
4931+BWRITE DC.L *+NATWID
4932+ JMP NEXT
4933+*
4934+* ######>> screen 68 <<
4935+* ======>> 190 <<
4936+* ( ??? )
4937+* Read one block of data from disk.
4938+* Parameters unspecified in model. Stub in model.
4939+ EVEN
4940+ DC.B 0
4941+ DC.B $8A
4942+ DC.B 'BLOCK-REA' ; 'BLOCK-READ'
4943+ DC.B 'D'|$80
4944+ DC.L BWRITE-12-NATWID
4945+BREAD DC.L *+NATWID
4946+ JMP NEXT
4947+*
4948+*The next 3 words are written to create a substitute for disc
4949+* mass memory,located between MASSLO & MASSHI in ram --
4950+* ($3210 and $3fff in the 6800 model).
4951+* ======>> 190.1 <<
4952+ EVEN
4953+ DC.B 0
4954+ DC.B $82
4955+ DC.B 'L' ; 'LO'
4956+ DC.B 'O'|$80
4957+ DC.L BREAD-11-NATWID
4958+LO DC.L DOCON
4959+ DC.L MEMEND a system dependent equate at front
4960+*
4961+* ======>> 190.2 <<
4962+ EVEN
4963+ DC.B 0
4964+ DC.B $82
4965+ DC.B 'H' ; 'HI'
4966+ DC.B 'I'|$80
4967+ DC.L LO-3-NATWID
4968+HI DC.L DOCON
4969+ DC.L MEMTOP ( $3FFF or $7FFF in this version )
4970+*
4971+* ######>> screen 69 <<
4972+* ======>> 191 <<
4973+* ( buffer sector f --- )
4974+* Read or Write the specified (absolute -- ignores OFFSET) sector
4975+* from or to the specified buffer.
4976+* A zero flag specifies write,
4977+* non-zero specifies read.
4978+* Sector is an unsigned integer,
4979+* buffer is the buffer's address.
4980+* Will need to use the CoCo ROM disk routines.
4981+* For now, provides a virtual disk in RAM.
4982+ EVEN
4983+ DC.B $83
4984+ DC.B 'R/' ; 'R/W'
4985+ DC.B 'W'|$80
4986+ DC.L HI-3-NATWID
4987+RW DC.L DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
4988+ DC.L RW2-*-NATWID
4989+ DC.L PDOTQ
4990+ DC.B 8
4991+ DC.B ' Range ?' ; ' Range ?'
4992+ DC.B 0 ; hand align
4993+ DC.L QUIT
4994+RW2 DC.L FROMR,ZBRAN
4995+ DC.L RW3-*-NATWID
4996+ DC.L SWAP
4997+RW3 DC.L BBUF,CMOVE
4998+ DC.L SEMIS
4999+*
5000+* From BIF-6809:
5001+* RW PSHS Y,U,DP
5002+* LDY $C006 control table
5003+* LDX #DROFFS+7 ; This is BIF's table of drive sizes.
5004+* LDD 2,U
5005+* RWD SUBD ,X++ sectors
5006+* BHS RWD
5007+* BVC RWR table end?
5008+* LDD #6
5009+* PSHU D
5010+* JMP ERROR
5011+* RWR ADDD ,--X back one
5012+* PSHS X
5013+* PSHU D
5014+* LDD #18 sectors/track
5015+* PSHU D
5016+* DOCOL
5017+* FDB SLAMOD
5018+* FDB XMACH
5019+* PULU D
5020+* STB 2,Y track
5021+* PULU D
5022+* INCB
5023+* STB 3,Y sector
5024+* PULS D table entry
5025+* SUBD #DROFFS+7
5026+* ASRB drive #
5027+* STB 1,Y
5028+* LDD 4,U buffer
5029+* STD 4,Y
5030+* LDB #2 coco READ
5031+* LDX ,U 0?
5032+* BNE *+3
5033+* INCB coco WRITE
5034+* STB ,Y op code
5035+* CLRA
5036+* TFR A,DP
5037+* JSR [$C004] ROM handles timeout
5038+* PULS Y,U,DP if IRQ enabled
5039+* LEAU 6,U
5040+* LDX $C006
5041+* LDB 6,X coco status
5042+* BEQ RWE
5043+* LDX <UP
5044+* LDD #0 no disc
5045+* STD UWARN,X
5046+* LDD #8
5047+* PSHU D
5048+* JMP ERROR
5049+* RWE NEXT
5050+*
5051+ PAGE
5052+*
5053+* ######>> screen 72 <<
5054+* ======>> 192 <<
5055+* ( --- ) compiling P
5056+* ( --- adr ) interpreting
5057+* { ' name } input
5058+* Parse a symbol name from input and search the dictionary for it, per -FIND;
5059+* compile the address as a literal if compiling,
5060+* otherwise just push it.
5061+ EVEN
5062+ DC.B $C1 ; immediate
5063+ DC.B "'"|$80 ; ' ( tick )
5064+ DC.L RW-4-NATWID
5065+TICK DC.L DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
5066+ DC.L SEMIS
5067+*
5068+* ======>> 193 <<
5069+* ( --- ) { FORGET name } input
5070+* Parse out name of definition to FORGET to, -DFIND it,
5071+* then lop it and everything that follows out of the dictionary.
5072+* In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
5073+ EVEN
5074+ DC.B 0
5075+ DC.B $86
5076+ DC.B 'FORGE' ; 'FORGET'
5077+ DC.B 'T'|$80
5078+ DC.L TICK-2-NATWID
5079+FORGET DC.L DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT16
5080+ DC.W $18
5081+ DC.L QERR,TICK,DUP,FENCE,AT,LESS,LIT16
5082+ DC.W $15
5083+ DC.L QERR,DUP,ZERO,PORIG,GREAT,LIT16
5084+ DC.W $15
5085+ DC.L QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
5086+ DC.L SEMIS
5087+*
5088+* ######>> screen 73 <<
5089+* ======>> 194 <<
5090+* ( adr --- ) C
5091+* Calculate a back reference from HERE and compile it.
5092+ EVEN
5093+ DC.B 0
5094+ DC.B $84
5095+ DC.B 'BAC' ; 'BACK'
5096+ DC.B 'K'|$80
5097+ DC.L FORGET-7-NATWID
5098+* BACK DC.L DOCOL,HERE,SUB,COMMA
5099+BACK DC.L DOCOL,HERE,NATP,SUB,COMMA
5100+ DC.L SEMIS
5101+*
5102+* ======>> 195 <<
5103+* ( --- ) runtime
5104+* typical use: BEGIN code-loop test UNTIL
5105+* typical use: BEGIN code-loop AGAIN
5106+* typical use: BEGIN code-loop test WHILE code-true REPEAT
5107+* ( --- adr n ) compile time P,C
5108+* Push HERE for BACK reference for general (non-counting) loops,
5109+* with BEGIN construct flag.
5110+* A better flag: $4245 (ASCII for 'BE').
5111+ EVEN
5112+ DC.B $C5
5113+ DC.B 'BEGI' ; 'BEGIN'
5114+ DC.B 'N'|$80
5115+ DC.L BACK-5-NATWID
5116+BEGIN DC.L DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
5117+ DC.L SEMIS
5118+*
5119+* ======>> 196 <<
5120+* ( --- ) runtime
5121+* typical use: test IF code-true ELSE code-false ENDIF
5122+* ENDIF is just a sort of intersection piece,
5123+* marking where execution resumes after both branches.
5124+* ( adr n --- ) compile time
5125+* Check the mark and resolve the IF.
5126+* A better flag: $4846 (ASCII for 'IF').
5127+ EVEN
5128+ DC.B $C5
5129+ DC.B 'ENDI' ; 'ENDIF'
5130+ DC.B 'F'|$80
5131+ DC.L BEGIN-6-NATWID
5132+ENDIF DC.L DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
5133+* DC.L OVER,SUB,SWAP,STORE
5134+ DC.L OVER,NATP,SUB,SWAP,STORE
5135+ DC.L SEMIS
5136+*
5137+* ======>> 197 <<
5138+* ( --- ) runtime
5139+* typical use: test IF code-true ELSE code-false ENDIF
5140+* ( adr n --- )
5141+* Alias for ENDIF .
5142+ EVEN
5143+ DC.B 0
5144+ DC.B $C4
5145+ DC.B 'THE' ; 'THEN'
5146+ DC.B 'N'|$80
5147+ DC.L ENDIF-6-NATWID
5148+THEN DC.L DOCOL,ENDIF
5149+ DC.L SEMIS
5150+*
5151+* ======>> 198 <<
5152+* ( limit index --- ) runtime
5153+* typical use: DO code-loop LOOP
5154+* typical use: DO code-loop increment +LOOP
5155+* Counted loop, index is initial value of index.
5156+* Will loop until index equals (positive going)
5157+* or passes (negative going) limit.
5158+* ( --- adr n ) compile time P,C
5159+* Compile (DO), push HERE for BACK reference,
5160+* and push DO control construct flag.
5161+* A better flag: $444F (ASCII for 'DO').
5162+ EVEN
5163+ DC.B 0
5164+ DC.B $C2
5165+ DC.B 'D' ; 'DO'
5166+ DC.B 'O'|$80
5167+ DC.L THEN-5-NATWID
5168+DO DC.L DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
5169+ DC.L SEMIS
5170+*
5171+* ======>> 199 <<
5172+* ( --- ) runtime
5173+* typical use: DO code-loop LOOP
5174+* Increments the index by one and branches back to beginning of loop.
5175+* Will loop until index equals limit.
5176+* ( adr n --- ) compile time P,C
5177+* Check the mark and compile (LOOP), fill in BACK reference.
5178+* A better flag: $444F (ASCII for 'DO').
5179+ EVEN
5180+ DC.B 0
5181+ DC.B $C4
5182+ DC.B 'LOO' ; 'LOOP'
5183+ DC.B 'P'|$80
5184+ DC.L DO-3-NATWID
5185+LOOP DC.L DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
5186+ DC.L SEMIS
5187+*
5188+* ======>> 200 <<
5189+* ( n --- ) runtime
5190+* typical use: DO code-loop increment +LOOP
5191+* Increments the index by n and branches back to beginning of loop.
5192+* Will loop until index equals (positive going)
5193+* or passes (negative going) limit.
5194+* ( adr n --- ) compile time P,C
5195+* Check the mark and compile (+LOOP), fill in BACK reference.
5196+* A better flag: $444F (ASCII for 'DO').
5197+ EVEN
5198+ DC.B $C5
5199+ DC.B '+LOO' ; '+LOOP'
5200+ DC.B 'P'|$80
5201+ DC.L LOOP-5-NATWID
5202+PLOOP DC.L DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
5203+ DC.L SEMIS
5204+*
5205+* ======>> 201 <<
5206+* ( n --- ) runtime
5207+* typical use: BEGIN code-loop test UNTIL
5208+* Will loop until UNTIL tests true.
5209+* ( adr n --- ) compile time P,C
5210+* Check the mark and compile (0BRANCH), fill in BACK reference.
5211+* A better flag: $4245 (ASCII for 'BE').
5212+ EVEN
5213+ DC.B $C5
5214+ DC.B 'UNTI' ; 'UNTIL' : ( same as END )
5215+ DC.B 'L'|$80
5216+ DC.L PLOOP-6-NATWID
5217+UNTIL DC.L DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
5218+ DC.L SEMIS
5219+*
5220+* ######>> screen 74 <<
5221+* ======>> 202 <<
5222+* ( n --- ) runtime
5223+* typical use: BEGIN code-loop test END
5224+* ( adr n --- )
5225+* Alias for UNTIL .
5226+ EVEN
5227+ DC.B $C3
5228+ DC.B 'EN' ; 'END'
5229+ DC.B 'D'|$80
5230+ DC.L UNTIL-6-NATWID
5231+END DC.L DOCOL,UNTIL
5232+ DC.L SEMIS
5233+*
5234+* ======>> 203 <<
5235+* ( --- ) runtime
5236+* typical use: BEGIN code-loop AGAIN
5237+* Will loop forever
5238+* (or until something uses R> DROP to force the current definition to die,
5239+* or perhaps ABORT or ERROR or some such other drastic means stops things).
5240+* ( adr n --- ) compile time P,C
5241+* Check the mark and compile (0BRANCH), fill in BACK reference.
5242+* A better flag: $4245 (ASCII for 'BE').
5243+ EVEN
5244+ DC.B $C5
5245+ DC.B 'AGAI' ; 'AGAIN'
5246+ DC.B 'N'|$80
5247+ DC.L END-4-NATWID
5248+AGAIN DC.L DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
5249+ DC.L SEMIS
5250+*
5251+* ======>> 204 <<
5252+* ( --- ) runtime
5253+* typical use: BEGIN code-loop test WHILE code-true REPEAT
5254+* Will loop until WHILE tests false, skipping code-true on end.
5255+* REPEAT marks where execution resumes after the WHILE find a false flag.
5256+* ( aadr1 n1 adr2 n2 --- ) compile time P,C
5257+* Check the marks for WHILE and BEGIN,
5258+* compile BRANCH and BACK fill adr1 reference,
5259+* FILL-IN 0BRANCH reference at adr2.
5260+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
5261+ EVEN
5262+ DC.B 0
5263+ DC.B $C6
5264+ DC.B 'REPEA' ; 'REPEAT'
5265+ DC.B 'T'|$80
5266+ DC.L AGAIN-6-NATWID
5267+REPEAT DC.L DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
5268+ DC.L TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
5269+ DC.L SEMIS
5270+*
5271+* ======>> 205 <<
5272+* ( n --- ) runtime
5273+* typical use: test IF code-true ELSE code-false ENDIF
5274+* Will pass execution to the true part on a true flag
5275+* and to the false part on a false flag.
5276+* ( --- adr n ) compile time P,C
5277+* Compile a 0BRANCH and dummy offset
5278+* and push IF reference to fill in and
5279+* IF control construct flag.
5280+* A better flag: $4946 (ASCII for 'IF').
5281+ EVEN
5282+ DC.B 0
5283+ DC.B $C2
5284+ DC.B 'I' ; 'IF'
5285+ DC.B 'F'|$80
5286+ DC.L REPEAT-7-NATWID
5287+IF DC.L DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
5288+ DC.L SEMIS
5289+*
5290+* ======>> 206 <<
5291+* ( --- ) runtime
5292+* typical use: test IF code-true ELSE code-false ENDIF
5293+* ELSE is just a sort of intersection piece,
5294+* marking where execution resumes on a false branch.
5295+* ( adr1 n --- adr2 n ) compile time P,C
5296+* Check the marks,
5297+* compile BRANCH with dummy offset,
5298+* resolve IF reference,
5299+* and leave reference to BRANCH for ELSE.
5300+* A better flag: $4946 (ASCII for 'IF').
5301+ EVEN
5302+ DC.B 0
5303+ DC.B $C4
5304+ DC.B 'ELS' ; 'ELSE'
5305+ DC.B 'E'|$80
5306+ DC.L IF-3-NATWID
5307+ELSE DC.L DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
5308+ DC.L ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
5309+ DC.L SEMIS
5310+*
5311+* ======>> 207 <<
5312+* ( n --- ) runtime
5313+* typical use: BEGIN code-loop test WHILE code-true REPEAT
5314+* Will loop until WHILE tests false, skipping code-true on end.
5315+* ( --- adr n ) compile time P,C
5316+* Compile 0BRANCH with dummy offset (using IF),
5317+* push WHILE reference.
5318+* BEGIN flag will sit underneath this.
5319+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
5320+ EVEN
5321+ DC.B $C5
5322+ DC.B 'WHIL' ; 'WHILE'
5323+ DC.B 'E'|$80
5324+ DC.L ELSE-5-NATWID
5325+WHILE DC.L DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
5326+ DC.L SEMIS
5327+*
5328+ PAGE
5329+*
5330+* ######>> screen 75 <<
5331+* ======>> 208 <<
5332+* ( count --- )
5333+* EMIT count spaces, for non-zero, non-negative counts.
5334+ EVEN
5335+ DC.B 0
5336+ DC.B $86
5337+ DC.B 'SPACE' ; 'SPACES'
5338+ DC.B 'S'|$80
5339+ DC.L WHILE-6-NATWID
5340+SPACES DC.L DOCOL,ZERO,MAX,DDUP,ZBRAN
5341+ DC.L SPACE3-*-NATWID
5342+ DC.L ZERO,XDO
5343+SPACE2 DC.L SPACE,XLOOP
5344+ DC.L SPACE2-*-NATWID
5345+SPACE3 DC.L SEMIS
5346+*
5347+* ======>> 209 <<
5348+* ( --- )
5349+* Initialize HLD for converting a double integer.
5350+* Stores the PAD address in HLD.
5351+ EVEN
5352+ DC.B 0
5353+ DC.B $82
5354+ DC.B '<' ; '<#'
5355+ DC.B '#'|$80
5356+ DC.L SPACES-7-NATWID
5357+BDIGS DC.L DOCOL,PAD,HLD,STORE
5358+ DC.L SEMIS
5359+*
5360+* ======>> 210 <<
5361+* ( d --- string length )
5362+* Terminate numeric conversion,
5363+* drop the number being converted,
5364+* leave the address of the conversion string and the length, ready for TYPE.
5365+ EVEN
5366+ DC.B 0
5367+ DC.B $82
5368+ DC.B '#' ; '#>'
5369+ DC.B '>'|$80
5370+ DC.L BDIGS-3-NATWID
5371+EDIGS DC.L DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
5372+ DC.L SEMIS
5373+*
5374+* ======>> 211 <<
5375+* ( n d --- d )
5376+* Put sign of n (as a flag) at the head of the conversion string.
5377+* Drop the sign flag.
5378+ EVEN
5379+ DC.B 0
5380+ DC.B $84
5381+ DC.B 'SIG' ; 'SIGN'
5382+ DC.B 'N'|$80
5383+ DC.L EDIGS-3-NATWID
5384+SIGN DC.L DOCOL,ROT,ZLESS,ZBRAN
5385+ DC.L SIGN2-*-NATWID
5386+ DC.L LIT16
5387+ DC.W "-"
5388+ DC.L HOLD
5389+SIGN2 DC.L SEMIS
5390+*
5391+* ======>> 212 <<
5392+* ( d --- d/base )
5393+* Generate next most significant digit in the conversion BASE,
5394+* putting the digit at the head of the conversion string.
5395+ EVEN
5396+ DC.B $81 ; #
5397+ DC.B '#'|$80
5398+ DC.L SIGN-5-NATWID
5399+DIG DC.L DOCOL,BASE,AT,MSMOD,ROT,LIT16
5400+ DC.W 9
5401+ DC.L OVER,LESS,ZBRAN
5402+ DC.L DIG2-*-NATWID
5403+ DC.L LIT16
5404+ DC.W 7
5405+ DC.L PLUS
5406+DIG2 DC.L LIT16
5407+ DC.W "0" ; ascii zero
5408+ DC.L PLUS,HOLD
5409+ DC.L SEMIS
5410+*
5411+* ======>> 213 <<
5412+* ( d --- dzero )
5413+* Convert d to a numeric string using # until the result is zero.
5414+* Leave the double result on the stack for #> to drop.
5415+ EVEN
5416+ DC.B 0
5417+ DC.B $82
5418+ DC.B '#' ; '#S'
5419+ DC.B 'S'|$80
5420+ DC.L DIG-2-NATWID
5421+DIGS DC.L DOCOL
5422+DIGS2 DC.L DIG,OVER,OVER,OR,ZEQU,ZBRAN
5423+ DC.L DIGS2-*-NATWID
5424+ DC.L SEMIS
5425+*
5426+* ######>> screen 76 <<
5427+* ======>> 214 <<
5428+* ( n width --- )
5429+* Print n on the output device in the current conversion base,
5430+* with sign,
5431+* right aligned in a field at least width wide.
5432+ EVEN
5433+ DC.B 0
5434+ DC.B $82
5435+ DC.B '.' ; '.R'
5436+ DC.B 'R'|$80
5437+ DC.L DIGS-3-NATWID
5438+DOTR DC.L DOCOL,TOR,STOD,FROMR,DDOTR
5439+ DC.L SEMIS
5440+*
5441+* ======>> 215 <<
5442+* ( d width --- )
5443+* Print d on the output device in the current conversion base,
5444+* with sign,
5445+* right aligned in a field at least width wide.
5446+ EVEN
5447+ DC.B $83
5448+ DC.B 'D.' ; 'D.R'
5449+ DC.B 'R'|$80
5450+ DC.L DOTR-3-NATWID
5451+DDOTR DC.L DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
5452+ DC.L EDIGS,FROMR,OVER,SUB,SPACES,TYPE
5453+ DC.L SEMIS
5454+*
5455+* ======>> 216 <<
5456+* D. ( d --- )
5457+* Print d on the output device in the current conversion base,
5458+* with sign,
5459+* in free format with trailing space.
5460+ EVEN
5461+ DC.B 0
5462+ DC.B $82
5463+ DC.B 'D' ; 'D.'
5464+ DC.B '.'|$80
5465+ DC.L DDOTR-4-NATWID
5466+DDOT DC.L DOCOL,ZERO,DDOTR,SPACE
5467+ DC.L SEMIS
5468+*
5469+* ======>> 217 <<
5470+* ( n --- )
5471+* Print n on the output device in the current conversion base,
5472+* with sign,
5473+* in free format with trailing space.
5474+ EVEN
5475+ DC.B $81 ; .
5476+ DC.B '.'|$80
5477+ DC.L DDOT-3-NATWID
5478+*DOT DC.L DOCOL,STOD,DDOT
5479+DOT DC.L DOCOL,BREAK,STOD,DDOT ; DBG *****
5480+ DC.L SEMIS
5481+*
5482+* ======>> 218 <<
5483+* ( adr --- )
5484+* Print signed word at adr, per DOT.
5485+ EVEN
5486+ DC.B $81 ; ?
5487+ DC.B '?'|$80
5488+ DC.L DOT-2-NATWID
5489+QUEST DC.L DOCOL,AT,DOT
5490+ DC.L SEMIS
5491+*
5492+ PAGE
5493+*
5494+* ######>> screen 77 <<
5495+* ======>> 219 <<
5496+* ( n --- )
5497+* Print out screen n as a field of ASCII,
5498+* with line numbers in decimal.
5499+* Needs a console more than 70 characters wide.
5500+ EVEN
5501+ DC.B 0
5502+ DC.B $84
5503+ DC.B 'LIS' ; 'LIST'
5504+ DC.B 'T'|$80
5505+ DC.L QUEST-2-NATWID
5506+LIST DC.L DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
5507+ DC.B 6
5508+ DC.B "SCR # "
5509+ DC.B 0 ; hand align
5510+ DC.L DOT,LIT16
5511+ DC.W $10
5512+ DC.L ZERO,XDO
5513+LIST2 DC.L CR,I,THREE
5514+ DC.L DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
5515+ DC.L LIST2-*-NATWID
5516+ DC.L CR
5517+ DC.L SEMIS
5518+*
5519+* ======>> 220 <<
5520+* ( start end --- )
5521+* Print comment lines (line 0, and line 1 if C/L < 41) of screens
5522+* from start to end.
5523+* Needs a console more than 70 characters wide.
5524+ EVEN
5525+ DC.B $85
5526+ DC.B 'INDE' ; 'INDEX'
5527+ DC.B 'X'|$80
5528+ DC.L LIST-5-NATWID
5529+INDEX DC.L DOCOL,CR,ONEP,SWAP,XDO
5530+INDEX2 DC.L CR,I,THREE
5531+ DC.L DOTR,SPACE,ZERO,I,DLINE
5532+ DC.L QTERM,ZBRAN
5533+ DC.L INDEX3-*-NATWID
5534+ DC.L LEAVE
5535+INDEX3 DC.L XLOOP
5536+ DC.L INDEX2-*-NATWID
5537+ DC.L SEMIS
5538+*
5539+* ======>> 221 <<
5540+* ( n --- )
5541+* List a printer page full of screens.
5542+* Line and screen number are in current base.
5543+* Needs a console more than 70 characters wide.
5544+ EVEN
5545+ DC.B $85
5546+ DC.B 'TRIA' ; 'TRIAD'
5547+ DC.B 'D'|$80
5548+ DC.L INDEX-6-NATWID
5549+TRIAD DC.L DOCOL,THREE,SLASH,THREE,STAR
5550+ DC.L THREE,OVER,PLUS,SWAP,XDO
5551+TRIAD2 DC.L CR,I
5552+ DC.L LIST,QTERM,ZBRAN
5553+ DC.L TRIAD3-*-NATWID
5554+ DC.L LEAVE
5555+TRIAD3 DC.L XLOOP
5556+ DC.L TRIAD2-*-NATWID
5557+ DC.L CR,LIT16
5558+ DC.W $0F
5559+ DC.L MESS,CR
5560+ DC.L SEMIS
5561+*
5562+* ######>> screen 78 <<
5563+* ======>> 222 <<
5564+* ( --- )
5565+* List the definitions in the current vocabulary.
5566+* Expects to output to full-width screen of printer, not a 32- or 40- column screen
5567+ EVEN
5568+ DC.B $85
5569+ DC.B 'VLIS' ; 'VLIST'
5570+ DC.B 'T'|$80
5571+ DC.L TRIAD-6-NATWID
5572+VLIST DC.L DOCOL
5573+* DC.L TRON ; DBG ******
5574+* DC.L LIT16 ; should not be hard coded.
5575+* DC.W $80
5576+ DC.L COLUMS,AT
5577+ DC.L OUT,STORE,CONTXT,AT,AT
5578+VLIST1 DC.L OUT,AT,COLUMS,AT
5579+* DC.L LIT16 ; Should not be hard coded.
5580+* DC.W 32
5581+ DC.L WIDTH,AT
5582+ DC.L SUB,GREAT,ZBRAN
5583+ DC.L VLIST2-*-NATWID
5584+ DC.L CR,ZERO,OUT,STORE
5585+VLIST2 DC.L DUP,IDDOT
5586+* DC.L BREAK ; dbg *****
5587+ DC.L SPACE,SPACE,PFA,LFA,AT
5588+ DC.L DUP,ZEQU,QTERM,OR,ZBRAN
5589+ DC.L VLIST1-*-NATWID
5590+ DC.L DROP
5591+* DC.L TROFF,BREAK ; DBG ********
5592+ DC.L SEMIS
5593+*
5594+* Need some utility stuff that isn't in the fig FORTH:
5595+* ( c --- )
5596+* Emit dot if c is less than blank, else emit c
5597+ EVEN
5598+ DC.B $85
5599+ DC.B 'BEMI' ; 'BEMIT'
5600+ DC.B 'T'|$80
5601+ DC.L VLIST-6-NATWID
5602+BEMIT DC.L DOCOL
5603+ DC.L DUP,BL,LESS,ZBRAN
5604+ DC.L BEMITO-*-NATWID
5605+ DC.L DROP,LIT16
5606+ DC.W $2e ; '.'
5607+BEMITO DC.L EMIT
5608+ DC.L SEMIS
5609+*
5610+* ( n width --- )
5611+* Output n in hexadecimal with field width.
5612+ EVEN
5613+ DC.B $83
5614+ DC.B 'X.' ; 'X.R'
5615+ DC.B 'R'|$80
5616+ DC.L BEMIT-6-NATWID
5617+XDOTR DC.L DOCOL
5618+ DC.L BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
5619+ DC.L SEMIS
5620+*
5621+BYTPLN EQU 16 ; bytes to dump per line
5622+* ( adr --- )
5623+* Dump a line of 16 bytes in memory, in hex and as characters.
5624+ EVEN
5625+ DC.B $85
5626+ DC.B 'BLIN' ; 'BLINE'
5627+ DC.B 'E'|$80
5628+ DC.L XDOTR-4-NATWID
5629+BLINE DC.L DOCOL
5630+ DC.L DUP,LIT16
5631+ DC.W BYTPLN
5632+ DC.L PLUS,OVER,XDO
5633+BLINEX DC.L I,CAT,THREE,XDOTR,XLOOP
5634+ DC.L BLINEX-*-NATWID
5635+ DC.L SPACE,SPACE
5636+ DC.L DUP,LIT16
5637+ DC.W BYTPLN
5638+ DC.L PLUS,SWAP,XDO
5639+BLINEC DC.L I,CAT,BEMIT,XLOOP
5640+ DC.L BLINEC-*-NATWID
5641+ DC.L SEMIS
5642+*
5643+* ( adr ct --- )
5644+* Dump memory via BLINE from adr to ct (ceiling BYTPLN) bytes.
5645+ EVEN
5646+ DC.B $85
5647+ DC.B 'BDUM' ; 'BDUMP'
5648+ DC.B 'P'|$80
5649+ DC.L BLINE-6-NATWID
5650+BDUMP DC.L DOCOL
5651+ DC.L CR,OVER,PLUS,SWAP,XDO
5652+BDUMPL DC.L I,LIT16
5653+ DC.W 4
5654+ DC.L XDOTR,LIT16
5655+ DC.W $3A
5656+ DC.L EMIT,SPACE
5657+ DC.L I,BLINE,CR,LIT16
5658+ DC.W BYTPLN
5659+ DC.L XPLOOP
5660+ DC.L BDUMPL-*-NATWID
5661+ DC.L SEMIS
5662+*
5663+* ======>> XX <<
5664+* ( --- )
5665+* Place holder for triggering low-level debuggers (not in fig Forth).
5666+ EVEN
5667+ DC.B $85
5668+ DC.B 'BREA' ; 'BREAK'
5669+ DC.B 'K'|$80
5670+ DC.L BDUMP-6-NATWID
5671+BREAK DC.L *+NATWID
5672+BREAKF NOP ; set a low-level break in here
5673+ NOP
5674+ NOP
5675+ RTS
5676+*
5677+*
5678+ EVEN
5679+ DC.B $85
5680+ DC.B 'TROF' ; 'TROFF'
5681+ DC.B 'F'|$80
5682+ DC.L BREAK-6-NATWID
5683+TROFF DC.L *+NATWID
5684+ CLR.W TRACEM-UORIG(UP)
5685+ RTS
5686+*
5687+ EVEN
5688+ DC.B 0
5689+ DC.B $84
5690+ DC.B 'TRO' ; 'TRON'
5691+ DC.B 'N'|$80
5692+ DC.L TROFF-6-NATWID
5693+TRON DC.L *+NATWID
5694+ MOVE.W #1,TRACEM-UORIG(UP)
5695+ RTS
5696+*
5697+*
5698+* NOOP NEXT a useful no-op
5699+*
5700+* ======>> XX <<
5701+* ( --- )
5702+* Mostly for place holding (fig Forth).
5703+ EVEN
5704+ DC.B 0
5705+ DC.B $84
5706+ DC.B 'NOO' ; 'NOOP'
5707+ DC.B 'P'|$80
5708+ DC.L TRON-5-NATWID
5709+NOOP DC.L *+NATWID
5710+ NOP
5711+ NOP
5712+ NOP
5713+ RTS
5714+* NOOP NEXT a useful no-op
5715+ZZZZ DC.L 0,0,0,0,0,0,0,0 end of rom program
5716+
5717+* About 10.3K in the dictionary image proper.
5718+* This is not surprising, given that the 6809 image is about 6.9K.
5719+* (The 6800 image is about 6.3K, if I remember right.)
5720+* Since the image is mostly pointers, and pointers in the 68000 are 32 bits, not 16
5721+* (since we don't want to limit ourselves to a 32K or so dictionary),
5722+* the 68000 image should be something less than double the size of the 6809 or 6800 image.
5723+
5724+ PAGE
5725+*
5726+
5727+
5728+*
5729+* Build test lists here:
5730+*TESTNEXT:
5731+* DC.L LIT,$FEEDBEEF
5732+* DC.L LIT16
5733+* DC.W $FF0F
5734+* DC.L LIT,AND
5735+* DC.L EXEC
5736+* DC.L BRAN
5737+* DC.L TESTNEXT-*-NATWID
5738+*
5739+*TESTMIN:
5740+* DC.L LIT,5
5741+* DC.L SIGNUM
5742+* DC.L LIT,-10
5743+* DC.L SIGNUM
5744+* DC.L MIN
5745+* DC.L LIT,100
5746+* DC.L MIN
5747+* DC.L DROP
5748+*TESTSUB:
5749+* DC.L LIT,$DEEFEED
5750+* DC.L LIT,$FEDDEBB
5751+* DC.L SUB ; DEEFEED - FEDDEBB
5752+* DC.L BRAN
5753+* DC.L TESTNEXT-*-NATWID
5754+*
5755+
5756+* Here you can see some of the advantages and disadvantages of the inner interpreter loop,
5757+* and of indirect threading.
5758+* PTRACE saves and restores D0/D1/D2/A2 so it can use them.
5759+* PEMIT will also save and restore D1/D2/A2 to protect them from the BIOS calls.
5760+D1MKHX:
5761+ AND.L #$0F,D1
5762+ ADD.B #'0',D1
5763+ CMP.B #'9',D1
5764+ BLE.S D1MKHR
5765+ ADD.B #'A'-'9'-1,D1
5766+D1MKHR RTS
5767+*
5768+PD1H1:
5769+ MOVEM.L D1,-(SP)
5770+ BSR.S D1MKHX
5771+ BSR.W PEMIT
5772+ MOVEM.L (SP)+,D1
5773+ RTS
5774+*
5775+PD1H8:
5776+ MOVEM.L D2,-(SP)
5777+ MOVE.W #7,D2
5778+PD1H8L:
5779+ ROL.L #4,D1 ; Grab the top four bits.
5780+ BSR.S PD1H1
5781+ DBF D2,PD1H8L
5782+ MOVEM.L (SP)+,D2
5783+ RTS
5784+*
5785+PTRACE:
5786+ MOVEM.L D0/D1/D2/A2,-(SP)
5787+ MOVE.B #'|',D1
5788+ BSR.W PEMIT
5789+ MOVE.L (PSP),D1
5790+ BSR.S PD1H8
5791+ MOVE.B #'|',D1
5792+ BSR.W PEMIT
5793+ MOVE.L NATWID(PSP),D1
5794+ BSR.S PD1H8
5795+ MOVE.B #':',D1
5796+ BSR.W PEMIT
5797+ MOVE.L W,D1
5798+ BSR.S PD1H8
5799+ MOVE.B #'>',D1
5800+ BSR.W PEMIT
5801+ BSR.S PNAME
5802+ BSR.W PCR
5803+ MOVEM.L (SP)+,D0/D1/D2/A2
5804+ RTS
5805+*
5806+PSTR:
5807+ SUBQ #1,D2 ; for DBF count
5808+PSTRL MOVE.B (A2)+,D1
5809+ AND.L #$7F,D1
5810+ BSR.W PEMIT
5811+ DBF D2,PSTRL
5812+ RTS
5813+*
5814+IXNAME:
5815+ LEA -2*NATWID(W),A2 ; back up to one past the mode byte.
5816+ TST.B -(A2) ; is it a mode byte?
5817+ BPL.S IXNAMX ; If this is not an end/mode byte, stop.
5818+IXNAML TST.B -(A2) ; back up to the length byte
5819+ BPL.s IXNAML
5820+IXNAMX RTS
5821+*
5822+PNAMN0 DC.B $0E ; Not a dictionary entry, unadorned length,
5823+ DC.B '** NOT NAME **' ; and no tail char flag.
5824+ EVEN
5825+PNAME:
5826+ BSR.S IXNAME
5827+ MOVE.B (A2)+,D2 ; Length byte, point to 1st character
5828+ BPL.S PNAMEF
5829+ AND.W #$1F,D2 ; extract length, word for DBF
5830+ BEQ.S PNAMEF ; all names have length, even NUL
5831+PNAMEP BSR.S PSTR
5832+ RTS
5833+PNAMEF LEA PNAMN0(PC),A2
5834+ MOVE.B (A2)+,D2 ; Error message has length (unadorned), too.
5835+ BRA.S PNAMEP
5836+*
5837+ZZZZ2 DC.L 0,0,0,0,0,0,0,0 ; "real" end of "rom" program
5838+* ALIGN 256 ; want to do this, but the ATARI CNOP directive doesn't look standard to me.
5839+*
5840+* substitute for disc mass memory
5841+NBLK EQU 4 ; # of disc buffer blocks for virtual memory
5842+* Should NBLK be SCRSZ/SECTSZ? maybe not.
5843+* each block is SECTSZ+SECTRL bytes in size,
5844+* holding SECTSZ characters
5845+SECTSZ EQU 256
5846+SECTRL EQU 2*NATWID ; Currently held sector number, etc.
5847+BUFSZ EQU (SECTSZ+SECTRL)*NBLK
5848+*
5849+BUFBAS DS.L BUFSZ
5850+* This is a really awkward place to define the disk buffer records.
5851+*
5852+* *BUG* SECTRL was magic-number hard-wired into several definitions.
5853+* It will take a bit of work to ferret them out.
5854+* It is too small, and it should not be hard-wired.
5855+* SECTSZ was also magic-number hard-wired into several definitions,
5856+* will I find them all?
5857+ DC.L 0,0,0,0,0,0,0,0 ; put a little space between
5858+* ALIGN 256 ; Again, I want to, but ...
5859+MEMEND EQU *
5860+*
5861+SCRSZ EQU 1024
5862+*
5863+* FIRST
5864+*
5865+VDISK EQU MEMEND
5866+*
5867+* Screens for drive 0, including error messages.
5868+*
5869+* SCREEN 0
5870+ DC.B "000~000: ( Index to disk SCREENS SCREEN 0 ) " 0
5871+ DC.B "001~002: ( More Index lines ) " 1
5872+ DC.B "003~003: ( FIG Title page, FIG Copyright Notice ) " 2
5873+ DC.B "004~005: ( FIG ERROR MESSAGES ) " 3
5874+ DC.B "006~007: ( Custom Error Messages ) " 4
5875+ DC.B "008~???: ( Modifications, copyright notices ) " 5
5876+ DC.B "XXX~XXX: " 6
5877+ DC.B "XXX~XXX: " 7
5878+ DC.B "XXX~XXX: " 8
5879+ DC.B "XXX~XXX: " 9
5880+ DC.B "XXX~XXX: " 10
5881+ DC.B "XXX~XXX: " 11
5882+ DC.B "XXX~XXX: " 12
5883+ DC.B "XXX~XXX: " 13
5884+ DC.B "XXX~XXX: " 14
5885+ DC.B "XXX~XXX: " 15
5886+* SCREEN 1
5887+ DC.B "XXX~XXX: ( More index SCREEN 1 ) " 0
5888+ DC.B "XXX~XXX: " 1
5889+ DC.B "XXX~XXX: " 2
5890+ DC.B "XXX~XXX: " 3
5891+ DC.B "XXX~XXX: " 4
5892+ DC.B "XXX~XXX: " 5
5893+ DC.B "XXX~XXX: " 6
5894+ DC.B "XXX~XXX: " 7
5895+ DC.B "XXX~XXX: " 8
5896+ DC.B "XXX~XXX: " 9
5897+ DC.B "XXX~XXX: " 10
5898+ DC.B "XXX~XXX: " 11
5899+ DC.B "XXX~XXX: " 12
5900+ DC.B "XXX~XXX: " 13
5901+ DC.B "XXX~XXX: " 14
5902+ DC.B "XXX~XXX: " 15
5903+* SCREEN 2
5904+ DC.B "XXX~XXX: ( More index SCREEN 2 ) " 0
5905+ DC.B "XXX~XXX: " 1
5906+ DC.B "XXX~XXX: " 2
5907+ DC.B "XXX~XXX: " 3
5908+ DC.B "XXX~XXX: " 4
5909+ DC.B "XXX~XXX: " 5
5910+ DC.B "XXX~XXX: " 6
5911+ DC.B "XXX~XXX: " 7
5912+ DC.B "XXX~XXX: " 8
5913+ DC.B "XXX~XXX: " 9
5914+ DC.B "XXX~XXX: " 10
5915+ DC.B "XXX~XXX: " 11
5916+ DC.B "XXX~XXX: " 12
5917+ DC.B "XXX~XXX: " 13
5918+ DC.B "XXX~XXX: " 14
5919+ DC.B "XXX~XXX: " 15
5920+* SCREEN 3
5921+ DC.B "*************** Code from the fig-FORTH MODEL *************** " 0
5922+ DC.B " " 1
5923+ DC.B " Through the courtesy of " 2
5924+ DC.B " " 3
5925+ DC.B " FORTH INTEREST GROUP " 4
5926+ DC.B " P. O. BOX 1105 " 5
5927+ DC.B " SAN CARLOS, CA. 94070 " 6
5928+ DC.B " " 7
5929+ DC.B " " 8
5930+ DC.B " RELEASE 1 " 9
5931+ DC.B " WITH COMPILER SECURITY " 10
5932+ DC.B " AND " 11
5933+ DC.B " VARIABLE LENGTH NAMES " 12
5934+ DC.B " " 13
5935+ DC.B " " 14
5936+ DC.B " Further distribution must include the above notice. " 15
5937+* SCREEN 4
5938+ DC.B "( ERROR MESSAGES ) " 0
5939+ DC.B "DATA STACK UNDERFLOW " 1
5940+ DC.B "DICTIONARY FULL " 2
5941+ DC.B "HAS INCORRECT ADDRESS MODE " 3
5942+ DC.B "ISN'T UNIQUE " 4
5943+ DC.B " " 5
5944+ DC.B "DISC RANGE? " 6
5945+ DC.B "DATA STACK OVERFLOW " 7
5946+ DC.B "DISC ERROR! " 8
5947+ DC.B " " 9
5948+ DC.B " " 10
5949+ DC.B " " 11
5950+ DC.B " " 12
5951+ DC.B " " 13
5952+ DC.B " " 14
5953+ DC.B "FORTH INTEREST GROUP " 15
5954+* SCREEN 5
5955+ DC.B "( ERROR MESSAGES ) " 0
5956+ DC.B "COMPILATION ONLY, USE IN DEFINITION " 1
5957+ DC.B "EXECUTION ONLY " 2
5958+ DC.B "CONDITIONALS NOT PAIRED " 3
5959+ DC.B "DEFINITION NOT FINISHED " 4
5960+ DC.B "IN PROTECTED DICTIONARY " 5
5961+ DC.B "USE ONLY WHEN LOADING " 6
5962+ DC.B "OFF CURRENT EDITING SCREEN " 7
5963+ DC.B "DECLARE VOCABULARY " 8
5964+ DC.B " " 9
5965+ DC.B " " 10
5966+ DC.B " " 11
5967+ DC.B " " 12
5968+ DC.B " " 13
5969+ DC.B " " 14
5970+ DC.B "FORTH INTEREST GROUP " 15
5971+* SCREEN 6
5972+ DC.B "( MORE ERROR MESSAGES SCREEN 6 ) " 0
5973+ DC.B " " 1
5974+ DC.B " " 2
5975+ DC.B " " 3
5976+ DC.B " " 4
5977+ DC.B " " 5
5978+ DC.B " " 6
5979+ DC.B " " 7
5980+ DC.B " " 8
5981+ DC.B " " 9
5982+ DC.B " " 10
5983+ DC.B " " 11
5984+ DC.B " " 12
5985+ DC.B " " 13
5986+ DC.B " " 14
5987+ DC.B " " 15
5988+*
5989+* SCREEN 7
5990+ DC.B " ( MORE ERROR MESSAGES SCREEN 7 ) " 0
5991+ DC.B " " 1
5992+ DC.B " " 2
5993+ DC.B " " 3
5994+ DC.B " " 4
5995+ DC.B " " 5
5996+ DC.B " " 6
5997+ DC.B " " 7
5998+ DC.B " " 8
5999+ DC.B " " 9
6000+ DC.B " " 10
6001+ DC.B " " 11
6002+ DC.B " " 12
6003+ DC.B " " 13
6004+ DC.B " " 14
6005+ DC.B " " 15
6006+*
6007+* SCREEN 8
6008+ DC.B " ( TEXT, LINE WFR-79MAY01 ) " 0
6009+ DC.B " FORTH DEFINITIONS HEX " 1
6010+ DC.B " " 2
6011+ DC.B " 64 CONSTANT C/L " 3
6012+ DC.B " " 4
6013+ DC.B " : TEXT ( ACCEPT FOLLOWING TEXT TO PAD *) " 5
6014+ DC.B " HERE C/L 1+ BLANKS WORD HERE PAD C/L 1+ CMOVE ; " 6
6015+ DC.B " " 7
6016+ DC.B " : LINE ( RELATIVE TO SCR, LEAVE ADDRESS OF LINE *) " 8
6017+ DC.B " DUP FFF0 AND 17 ?ERROR ( KEEP ON THIS SCREEN ) " 9
6018+ DC.B " SCR @ (LINE) DROP ; " 10
6019+ DC.B " " 11
6020+ DC.B " " 12
6021+ DC.B " " 13
6022+ DC.B " " 14
6023+ DC.B " " 15
6024+*
6025+* SCREEN 9
6026+ DC.B " ( More crude editing facilities. -- one byte characters ) " 0
6027+ DC.B " " 1
6028+ DC.B " 0 VARIABLE LNEDBUF 62 ALLOT ( buffer for line editing ) " 2
6029+ DC.B " " 3
6030+ DC.B " ( ns nl -- ) ( overwrite one line of the screen ) " 4
6031+ DC.B " : PUTLINE LNEDBUF 64 BLANKS ( just enough to write to disc ) " 5
6032+ DC.B " CR LNEDBUF 64 EXPECT CR ( just enough to write ) " 6
6033+ DC.B " SL2BB LNEDBUF SWAP 64 CMOVE UPDATE ; " 7
6034+ DC.B " ( Full screen editing requires keyboard control codes. ) " 8
6035+ DC.B " " 9
6036+ DC.B " " 10
6037+ DC.B " " 11
6038+ DC.B " " 12
6039+ DC.B " " 13
6040+ DC.B " " 14
6041+ DC.B " " 15
6042+*
6043+* SCREEN 10
6044+ DC.B " " 0
6045+ DC.B " " 1
6046+ DC.B " " 2
6047+ DC.B " " 3
6048+ DC.B " " 4
6049+ DC.B " " 5
6050+ DC.B " " 6
6051+ DC.B " " 7
6052+ DC.B " " 8
6053+ DC.B " " 9
6054+ DC.B " " 10
6055+ DC.B " " 11
6056+ DC.B " " 12
6057+ DC.B " " 13
6058+ DC.B " " 14
6059+ DC.B " " 15
6060+*
6061+* SCREEN 11
6062+ DC.B " " 0
6063+ DC.B " " 1
6064+ DC.B " " 2
6065+ DC.B " " 3
6066+ DC.B " " 4
6067+ DC.B " " 5
6068+ DC.B " " 6
6069+ DC.B " " 7
6070+ DC.B " " 8
6071+ DC.B " " 9
6072+ DC.B " " 10
6073+ DC.B " " 11
6074+ DC.B " " 12
6075+ DC.B " " 13
6076+ DC.B " " 14
6077+ DC.B " " 15
6078+*
6079+* SCREEN 12
6080+ DC.B " " 0
6081+ DC.B " " 1
6082+ DC.B " " 2
6083+ DC.B " " 3
6084+ DC.B " " 4
6085+ DC.B " " 5
6086+ DC.B " " 6
6087+ DC.B " " 7
6088+ DC.B " " 8
6089+ DC.B " " 9
6090+ DC.B " " 10
6091+ DC.B " " 11
6092+ DC.B " " 12
6093+ DC.B " " 13
6094+ DC.B " " 14
6095+ DC.B " " 15
6096+*
6097+* SCREEN 13
6098+ DC.B " " 0
6099+ DC.B " " 1
6100+ DC.B " " 2
6101+ DC.B " " 3
6102+ DC.B " " 4
6103+ DC.B " " 5
6104+ DC.B " " 6
6105+ DC.B " " 7
6106+ DC.B " " 8
6107+ DC.B " " 9
6108+ DC.B " " 10
6109+ DC.B " " 11
6110+ DC.B " " 12
6111+ DC.B " " 13
6112+ DC.B " " 14
6113+ DC.B " " 15
6114+*
6115+* SCREEN 14
6116+ DC.B " " 0
6117+ DC.B " " 1
6118+ DC.B " " 2
6119+ DC.B " " 3
6120+ DC.B " " 4
6121+ DC.B " " 5
6122+ DC.B " " 6
6123+ DC.B " " 7
6124+ DC.B " " 8
6125+ DC.B " " 9
6126+ DC.B " " 10
6127+ DC.B " " 11
6128+ DC.B " " 12
6129+ DC.B " " 13
6130+ DC.B " " 14
6131+ DC.B " " 15
6132+*
6133+* SCREEN 15
6134+ DC.B " " 0
6135+ DC.B " " 1
6136+ DC.B " " 2
6137+ DC.B " " 3
6138+ DC.B " " 4
6139+ DC.B " " 5
6140+ DC.B " " 6
6141+ DC.B " " 7
6142+ DC.B " " 8
6143+ DC.B " " 9
6144+ DC.B " " 10
6145+ DC.B " " 11
6146+ DC.B " " 12
6147+ DC.B " " 13
6148+ DC.B " " 14
6149+ DC.B " " 15
6150+*
6151+VDR1 EQU *
6152+RAMDSZ EQU VDR1-VDISK
6153+*
6154+ DS RAMDSZ
6155+*
6156+MEMTOP EQU *
6157+*
6158+* LO
6159+*
6160+MASSLO EQU VDISK
6161+MASSHI EQU MEMTOP
6162+*
6163+* HI
6164+*
6165+* "end" of "usable ram" (If disc mass memory emulation is removed, actual end.)
6166+*
6167+ end ORIG
6168+
6169+
6170+
6171+
6172+
Show on old repository browser