1 (fig-forth-auto680):00001 OPT PRT
2 (fig-forth-auto680):00002
3 (fig-forth-auto680):00003 * fig-FORTH FOR 6809
4 (fig-forth-auto680):00004 * ASSEMBLY SOURCE LISTING
5 (fig-forth-auto680):00005
6 (fig-forth-auto680):00006 * RELEASE 0
7 (fig-forth-auto680):00007 * JAN 2019
8 (fig-forth-auto680):00008 * WITH COMPILER SECURITY
9 (fig-forth-auto680):00009 * AND VARIABLE LENGTH NAMES
10 (fig-forth-auto680):00010 *
11 (fig-forth-auto680):00011 * Adapted by Joel Matthew Rees
12 (fig-forth-auto680):00012 * from fig-FORTH for 6800 by Dave Lion, et. al.
13 (fig-forth-auto680):00013
14 (fig-forth-auto680):00014 * This free/libre/open source publication is provided
15 (fig-forth-auto680):00015 * through the courtesy of:
16 (fig-forth-auto680):00016 * FORTH
17 (fig-forth-auto680):00017 * INTEREST
18 (fig-forth-auto680):00018 * GROUP
19 (fig-forth-auto680):00019 * fig
20 (fig-forth-auto680):00020 * and other interested parties.
21 (fig-forth-auto680):00021
22 (fig-forth-auto680):00022 * Ancient address:
23 (fig-forth-auto680):00023 * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
24 (fig-forth-auto680):00024 * URL: http://www.forth.org
25 (fig-forth-auto680):00025 * Further distribution must include this notice.
26 (fig-forth-auto680):00026 PAGE
27 (fig-forth-auto680):00027 NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
28 (fig-forth-auto680):00028 OPT NOG,PAG
29 (fig-forth-auto680):00029 * filename fig-forth-auto6809opt.asm
30 (fig-forth-auto680):00030 * === FORTH-6809 {date} {time}
31 (fig-forth-auto680):00031
32 (fig-forth-auto680):00032
33 (fig-forth-auto680):00033 * Permission is hereby granted, free of charge, to any person obtaining a copy
34 (fig-forth-auto680):00034 * of this software and associated documentation files (the "Software"), to deal
35 (fig-forth-auto680):00035 * in the Software without restriction, including without limitation the rights
36 (fig-forth-auto680):00036 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
37 (fig-forth-auto680):00037 * copies of the Software, and to permit persons to whom the Software is
38 (fig-forth-auto680):00038 * furnished to do so, subject to the following conditions:
39 (fig-forth-auto680):00039 *
40 (fig-forth-auto680):00040 * The above copyright notice and this permission notice shall be included in
41 (fig-forth-auto680):00041 * all copies or substantial portions of the Software.
42 (fig-forth-auto680):00042
43 (fig-forth-auto680):00043 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
44 (fig-forth-auto680):00044 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
45 (fig-forth-auto680):00045 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
46 (fig-forth-auto680):00046 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
47 (fig-forth-auto680):00047 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
48 (fig-forth-auto680):00048 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
49 (fig-forth-auto680):00049 * THE SOFTWARE.
50 (fig-forth-auto680):00050 *
51 (fig-forth-auto680):00051 * "Associated documentation" for this declaration of license
52 (fig-forth-auto680):00052 * shall be interpreted to include only the comments in this file,
53 (fig-forth-auto680):00053 * or, if the code is split into multiple files,
54 (fig-forth-auto680):00054 * all files containing the complete source.
55 (fig-forth-auto680):00055 *
56 (fig-forth-auto680):00056 * This is the MIT model license, as published by the Open Source Consortium,
57 (fig-forth-auto680):00057 * with associated documentation defined.
58 (fig-forth-auto680):00058 * It was chosen to reflect the spirit of the original
59 (fig-forth-auto680):00059 * terms of use, which used archaic legal terminology.
60 (fig-forth-auto680):00060 *
61 (fig-forth-auto680):00061
62 (fig-forth-auto680):00062 * Authors of the 6800 model:
63 (fig-forth-auto680):00063 * === Primary: Dave Lion,
64 (fig-forth-auto680):00064 * === with help from
65 (fig-forth-auto680):00065 * === Bob Smith,
66 (fig-forth-auto680):00066 * === LaFarr Stuart,
67 (fig-forth-auto680):00067 * === The Forth Interest Group
68 (fig-forth-auto680):00068 * === PO Box 1105
69 (fig-forth-auto680):00069 * === San Carlos, CA 94070
70 (fig-forth-auto680):00070 * === and
71 (fig-forth-auto680):00071 * === Unbounded Computing
72 (fig-forth-auto680):00072 * === 1134-K Aster Ave.
73 (fig-forth-auto680):00073 * === Sunnyvale, CA 94086
74 (fig-forth-auto680):00074 *
75 0002 (fig-forth-auto680):00075 NATWID EQU 2 ; bytes per natural integer/pointer
76 (fig-forth-auto680):00076 * The original version was developed on an AMI EVK 300 PROTO
77 (fig-forth-auto680):00077 * system using an ACIA for the I/O.
78 (fig-forth-auto680):00078 * This version is developed targeting the Tandy Color Computer.
79 (fig-forth-auto680):00079
80 (fig-forth-auto680):00080 * All terminal 1/0
81 (fig-forth-auto680):00081 * is done in three subroutines:
82 (fig-forth-auto680):00082 * PEMIT ( word # 182 )
83 (fig-forth-auto680):00083 * PKEY ( 183 )
84 (fig-forth-auto680):00084 * PQTERM ( 184 )
85 (fig-forth-auto680):00085 *
86 (fig-forth-auto680):00086 * The FORTH words for disc related I/O follow the model
87 (fig-forth-auto680):00087 * of the FORTH Interest Group, but have not yet been
88 (fig-forth-auto680):00088 * tested using a real disc.
89 (fig-forth-auto680):00089 *
90 (fig-forth-auto680):00090 * Addresses in the 6800 implementation reflect the fact that,
91 (fig-forth-auto680):00091 * on the development system, it was convenient to
92 (fig-forth-auto680):00092 * write-protect memory at hex 1000, and leave the first
93 (fig-forth-auto680):00093 * 4K bytes write-enabled. As a consequence, code from
94 (fig-forth-auto680):00094 * location $1000 to lable ZZZZ could be put in ROM.
95 (fig-forth-auto680):00095 * Minor deviations from the model were made in the
96 (fig-forth-auto680):00096 * initialization and words ?STACK and FORGET
97 (fig-forth-auto680):00097 * in order to do this.
98 (fig-forth-auto680):00098 * Those deviations will be altered in this
99 (fig-forth-auto680):00099 * implementation for the 6809 -- Color Computer.
100 (fig-forth-auto680):00100 *
101 (fig-forth-auto680):00101
102 (fig-forth-auto680):00102 *
103 7FFF (fig-forth-auto680):00103 MEMT32 EQU $7FFF absolute end of all ram
104 3FFF (fig-forth-auto680):00104 MEMT16 EQU $3FFF
105 7FFF (fig-forth-auto680):00105 MEMTOP EQU MEMT32 ; tentative guess
106 FBCE (fig-forth-auto680):00106 ACIAC EQU $FBCE the ACIA control address and
107 FBCF (fig-forth-auto680):00107 ACIAD EQU ACIAC+1 data address for PROTO
108 (fig-forth-auto680):00108 PAGE
109 (fig-forth-auto680):00109 * MEMORY MAP for this 16K|32K system:
110 (fig-forth-auto680):00110 * ( delineated so that systems with 4k byte write-
111 (fig-forth-auto680):00111 * protected segments can write protect FORTH )
112 (fig-forth-auto680):00112 *
113 (fig-forth-auto680):00113 * addr. contents pointer init by
114 (fig-forth-auto680):00114 * **** ******************************* ******* ******
115 (fig-forth-auto680):00115 * 2nd through 4th per-user tables
116 (fig-forth-auto680):00116 * 4000|7D00
117 0100 (fig-forth-auto680):00117 USERSZ EQU 256 ; (Addressable by DP)
118 0001 (fig-forth-auto680):00118 USER16 EQU 1 ; We can change these for ROMPACK or 64K.
119 0004 (fig-forth-auto680):00119 USER32 EQU 4
120 0004 (fig-forth-auto680):00120 USERCT EQU USER32
121 3F00 (fig-forth-auto680):00121 IUP16 EQU MEMT16+1-USER16*USERSZ
122 7C00 (fig-forth-auto680):00122 IUP32 EQU MEMT32+1-USER32*USERSZ
123 7C00 (fig-forth-auto680):00123 IUP EQU IUP32
124 007C (fig-forth-auto680):00124 IUPDP EQU IUP/256
125 (fig-forth-auto680):00125 * user tables of variables
126 (fig-forth-auto680):00126 * registers & pointers for the virtual machine
127 (fig-forth-auto680):00127 * scratch area used by various words
128 (fig-forth-auto680):00128 * 3F00|7C00 <== UP (DICTPT)
129 (fig-forth-auto680):00129 * 3EFF|7BFF HI
130 (fig-forth-auto680):00130 * substitute for disc mass memory
131 0003 (fig-forth-auto680):00131 RAMSCR EQU 3
132 0400 (fig-forth-auto680):00132 SCRSZ EQU 1024
133 (fig-forth-auto680):00133 * 3300|7000 LO,MEMEND
134 3300 (fig-forth-auto680):00134 RAMD16 EQU IUP16-RAMSCR*SCRSZ
135 7000 (fig-forth-auto680):00135 RAMD32 EQU IUP32-RAMSCR*SCRSZ
136 7000 (fig-forth-auto680):00136 RAMDSK EQU RAMD32
137 3300 (fig-forth-auto680):00137 MEME16 EQU RAMD16
138 7000 (fig-forth-auto680):00138 MEME32 EQU RAMD32
139 7000 (fig-forth-auto680):00139 MEMEND EQU MEME32
140 (fig-forth-auto680):00140 * 32FF|6FFF
141 (fig-forth-auto680):00141 * 4 buffer sectors of VIRTUAL MEMORY
142 0004 (fig-forth-auto680):00142 NBLK EQU 4 ; # of disc buffer blocks for virtual memory
143 (fig-forth-auto680):00143 * Should NBLK be SCRSZ/SECTSZ?
144 (fig-forth-auto680):00144 * each block is SECTSZ+SECTRL bytes in size,
145 (fig-forth-auto680):00145 * holding SECTSZ characters
146 0100 (fig-forth-auto680):00146 SECTSZ EQU 256
147 0008 (fig-forth-auto680):00147 SECTRL EQU 8
148 0420 (fig-forth-auto680):00148 BUFSZ EQU (SECTSZ+SECTRL)*NBLK
149 (fig-forth-auto680):00149 * 2EE0|6BE0 FIRST
150 2EE0 (fig-forth-auto680):00150 BUFB16 EQU MEME16-BUFSZ
151 6BE0 (fig-forth-auto680):00151 BUFB32 EQU MEME32-BUFSZ
152 6BE0 (fig-forth-auto680):00152 BUFBAS EQU BUFB32
153 (fig-forth-auto680):00153 * "end" of "usable ram" -- in 16K
154 (fig-forth-auto680):00154 * 2EE0|6BE0 <== RP RINIT
155 2EE0 (fig-forth-auto680):00155 IRP16 EQU BUFB16
156 6BE0 (fig-forth-auto680):00156 IRP32 EQU BUFB32
157 6BE0 (fig-forth-auto680):00157 IRP EQU IRP32
158 (fig-forth-auto680):00158 * RETURN STACK
159 (fig-forth-auto680):00159 * (64|112 levels nesting)
160 0080 (fig-forth-auto680):00160 RSTK16 EQU 128
161 00E0 (fig-forth-auto680):00161 RSTK32 EQU 224
162 (fig-forth-auto680):00162 * (2E60|6B00)
163 2E60 (fig-forth-auto680):00163 SFTB16 EQU IRP16-RSTK16
164 6B00 (fig-forth-auto680):00164 SFTB32 EQU IRP32-RSTK32
165 6B00 (fig-forth-auto680):00165 SFTBND EQU SFTB32
166 (fig-forth-auto680):00166 * INPUT LINE BUFFER
167 (fig-forth-auto680):00167 * holds up to 256 characters
168 (fig-forth-auto680):00168 * and is scanned upward by IN
169 (fig-forth-auto680):00169 * starting at TIB
170 0100 (fig-forth-auto680):00170 TIBSZ EQU 256
171 (fig-forth-auto680):00171 * 2D60|6A00
172 2D60 (fig-forth-auto680):00172 ITIB16 EQU SFTB16-TIBSZ
173 6A00 (fig-forth-auto680):00173 ITIB32 EQU SFTB32-TIBSZ
174 6A00 (fig-forth-auto680):00174 ITIB EQU ITIB32
175 (fig-forth-auto680):00175 * 2D60|6A00 <== IN TIB
176 2D60 (fig-forth-auto680):00176 ISP16 EQU ITIB16
177 6A00 (fig-forth-auto680):00177 ISP32 EQU ITIB32
178 6A00 (fig-forth-auto680):00178 ISP EQU ISP32
179 (fig-forth-auto680):00179 * 2D60|6A00 <== SP SP0,SINIT
180 (fig-forth-auto680):00180 * DATA STACK
181 (fig-forth-auto680):00181 * | grows downward from 2A60|6A00
182 (fig-forth-auto680):00182 * v
183 (fig-forth-auto680):00183 * - -
184 (fig-forth-auto680):00184 * |
185 (fig-forth-auto680):00185 * I DICTIONARY grows upward
186 (fig-forth-auto680):00186 *
187 (fig-forth-auto680):00187 * ???? end of ram-dictionary. <== DICTPT DPINIT
188 (fig-forth-auto680):00188 * "TASK"
189 (fig-forth-auto680):00189 *
190 (fig-forth-auto680):00190 * ???? "FORTH" ( a word ) <=, <== CONTEXT
191 (fig-forth-auto680):00191 * `==== CURRENT
192 (fig-forth-auto680):00192 * start of ram-dictionary.
193 (fig-forth-auto680):00193 *
194 (fig-forth-auto680):00194 * >>>>>> memory from here up must be in RAM area <<<<<<
195 (fig-forth-auto680):00195 *
196 (fig-forth-auto680):00196 * ????
197 (fig-forth-auto680):00197 * 6k of romable "FORTH" <== IP ABORT
198 (fig-forth-auto680):00198 * <== W
199 (fig-forth-auto680):00199 * the VIRTUAL FORTH MACHINE
200 (fig-forth-auto680):00200 *
201 (fig-forth-auto680):00201 * 1208 initialization tables
202 (fig-forth-auto680):00202 * 1204 <<< WARM START ENTRY >>>
203 (fig-forth-auto680):00203 * 1200 <<< COLD START ENTRY >>>
204 (fig-forth-auto680):00204 * 1200 lowest address used by FORTH
205 (fig-forth-auto680):00205 *
206 1200 (fig-forth-auto680):00206 CODEBG EQU $1200
207 (fig-forth-auto680):00207 * CODEBG EQU $3000
208 (fig-forth-auto680):00208 *
209 (fig-forth-auto680):00209 * >>>>>> memory from here down left alone <<<<<<
210 (fig-forth-auto680):00210 * >>>>>> so we can safely call ROM routines <<<<<<
211 (fig-forth-auto680):00211 *
212 (fig-forth-auto680):00212 * 0000
213 (fig-forth-auto680):00213 PAGE
214 (fig-forth-auto680):00214 ***
215 (fig-forth-auto680):00215 *
216 (fig-forth-auto680):00216 * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
217 (fig-forth-auto680):00217 *
218 (fig-forth-auto680):00218 * IP (hardware Y) points to the current instruction ( pre-increment mode )
219 (fig-forth-auto680):00219 * RP (hardware S) points to last return address pushedin return stack
220 (fig-forth-auto680):00220 * SP (hardware U) points to last byte pushed in data stack
221 (fig-forth-auto680):00221 *
222 (fig-forth-auto680):00222 * Y must be IP when NEXT is entered (if using the inner loop).
223 (fig-forth-auto680):00223 *
224 (fig-forth-auto680):00224 * When A and B hold one 16 bit FORTH data word,
225 (fig-forth-auto680):00225 * A contains the high byte, B, the low byte.
226 (fig-forth-auto680):00226 *
227 (fig-forth-auto680):00227 * UP (hardware DP) is the base of per-task ("user") variables.
228 (fig-forth-auto680):00228 * (Be careful of the stray semantics of "user".)
229 (fig-forth-auto680):00229 *
230 (fig-forth-auto680):00230 * W (hardware X) is the pointer to the "code field" address of native CPU
231 (fig-forth-auto680):00231 * machine code to be executed for the definition of the dictionary word
232 (fig-forth-auto680):00232 * to be executed/currently executing.
233 (fig-forth-auto680):00233 * The following natural integer (word) begins any "parameter section"
234 (fig-forth-auto680):00234 * (body) -- similar to a "this" pointer, but not the same.
235 (fig-forth-auto680):00235 * It may be native CPU machine code, or it may be a global variable,
236 (fig-forth-auto680):00236 * or it may be a list of Forth definition words (addresses).
237 (fig-forth-auto680):00237 *
238 (fig-forth-auto680):00238 * ======
239 (fig-forth-auto680):00239 * This implementation uses the native subroutine architecture
240 (fig-forth-auto680):00240 * rather than a postponed-push call that the 6800 model VM uses
241 (fig-forth-auto680):00241 * to save code and time in leaf routines.
242 (fig-forth-auto680):00242 *
243 (fig-forth-auto680):00243 * This should allow directly calling many of the Forth words
244 (fig-forth-auto680):00244 * from assembly language code.
245 (fig-forth-auto680):00245 * (Be aware of the need for a valid W in some cases.)
246 (fig-forth-auto680):00246 * It won't allow mixing assembly language directly into Forth word lists.
247 (fig-forth-auto680):00247 * ======
248 (fig-forth-auto680):00248 *
249 (fig-forth-auto680):00249 * boolean flags:
250 (fig-forth-auto680):00250 * 0 is false, anything else is true.
251 (fig-forth-auto680):00251 * Most places in this model that set a boolean flag set true as 1.
252 (fig-forth-auto680):00252 * This is in contrast to many models that set a boolean flag as -1.
253 (fig-forth-auto680):00253 *
254 (fig-forth-auto680):00254 ***
255 (fig-forth-auto680):00255
256 (fig-forth-auto680):00256 PAGE
257 (fig-forth-auto680):00257 * This system is shown with one user (task),
258 (fig-forth-auto680):00258 * but additional users (tasks) may be added
259 (fig-forth-auto680):00259 * by allocating additional user tables:
260 (fig-forth-auto680):00260 *
261 (fig-forth-auto680):00261 ORG IUP
262 7C00 (fig-forth-auto680):00262 UBASE RMB USERSZ
263 7D00 (fig-forth-auto680):00263 UBASEX RMB USERSZ data table for extra users
264 (fig-forth-auto680):00264 *
265 (fig-forth-auto680):00265 * Some of this stuff gets initialized during
266 (fig-forth-auto680):00266 * COLD start and WARM start:
267 (fig-forth-auto680):00267 * [ names correspond to FORTH words of similar (no X) name ]
268 (fig-forth-auto680):00268 *
269 (fig-forth-auto680):00269 ORG IUP
270 7C00 (fig-forth-auto680):00270 UORIG EQU *
271 (fig-forth-auto680):00271 * A few useful VM variables
272 (fig-forth-auto680):00272 * Will be removed when they are no longer needed.
273 (fig-forth-auto680):00273 * All are replaced by 6809 registers.
274 (fig-forth-auto680):00274
275 7C00 (fig-forth-auto680):00275 N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
276 (fig-forth-auto680):00276 * SP@,SWAP,DOES>,COLD
277 (fig-forth-auto680):00277
278 (fig-forth-auto680):00278
279 (fig-forth-auto680):00279 * These locations are used by the TRACE routine :
280 (fig-forth-auto680):00280
281 7C0A (fig-forth-auto680):00281 TRLIM RMB 1 the count for tracing without user intervention
282 7C0B (fig-forth-auto680):00282 TRACEM RMB 1 non-zero = trace mode
283 7C0C (fig-forth-auto680):00283 BRKPT RMB 2 the breakpoint address at which
284 (fig-forth-auto680):00284 * the program will go into trace mode
285 7C0E (fig-forth-auto680):00285 VECT RMB 2 vector to machine code
286 (fig-forth-auto680):00286 * (only needed if the TRACE routine is resident)
287 (fig-forth-auto680):00287
288 (fig-forth-auto680):00288
289 (fig-forth-auto680):00289 * Registers used by the FORTH virtual machine:
290 (fig-forth-auto680):00290 * Starting at $OOFO:
291 (fig-forth-auto680):00291
292 (fig-forth-auto680):00292
293 7C10 (fig-forth-auto680):00293 W RMB 2 the instruction register points to 6800 code
294 (fig-forth-auto680):00294 * This is not exactly accurate. Points to the definiton body,
295 (fig-forth-auto680):00295 * which is native CPU machine code when it is native CPU machine code.
296 7C12 (fig-forth-auto680):00296 IP RMB 2 the instruction pointer points to pointer to 6800 code
297 7C14 (fig-forth-auto680):00297 RP RMB 2 the return stack pointer
298 7C16 (fig-forth-auto680):00298 UP RMB 2 the pointer to base of current user's 'USER' table
299 (fig-forth-auto680):00299 * ( altered during multi-tasking )
300 (fig-forth-auto680):00300 *
301 (fig-forth-auto680):00301 *UORIG RMB 6 3 reserved variables
302 7C18 (fig-forth-auto680):00302 RMB 6 3 reserved variables
303 7C1E (fig-forth-auto680):00303 XSPZER RMB 2 initial top of data stack for this user
304 7C20 (fig-forth-auto680):00304 XRZERO RMB 2 initial top of return stack
305 7C22 (fig-forth-auto680):00305 XTIB RMB 2 start of terminal input buffer
306 7C24 (fig-forth-auto680):00306 XWIDTH RMB 2 name field width
307 7C26 (fig-forth-auto680):00307 XWARN RMB 2 warning message mode (0 = no disc)
308 7C28 (fig-forth-auto680):00308 XFENCE RMB 2 fence for FORGET
309 7C2A (fig-forth-auto680):00309 XDICTP RMB 2 dictionary pointer
310 7C2C (fig-forth-auto680):00310 XVOCL RMB 2 vocabulary linking
311 7C2E (fig-forth-auto680):00311 XBLK RMB 2 disc block being accessed
312 7C30 (fig-forth-auto680):00312 XIN RMB 2 scan pointer into the block
313 7C32 (fig-forth-auto680):00313 XOUT RMB 2 cursor position
314 7C34 (fig-forth-auto680):00314 XSCR RMB 2 disc screen being accessed ( O=terminal )
315 7C36 (fig-forth-auto680):00315 XOFSET RMB 2 disc sector offset for multi-disc
316 7C38 (fig-forth-auto680):00316 XCONT RMB 2 last word in primary search vocabulary
317 7C3A (fig-forth-auto680):00317 XCURR RMB 2 last word in extensible vocabulary
318 7C3C (fig-forth-auto680):00318 XSTATE RMB 2 flag for 'interpret' or 'compile' modes
319 7C3E (fig-forth-auto680):00319 XBASE RMB 2 number base for I/O numeric conversion
320 7C40 (fig-forth-auto680):00320 XDPL RMB 2 decimal point place
321 7C42 (fig-forth-auto680):00321 XFLD RMB 2
322 7C44 (fig-forth-auto680):00322 XCSP RMB 2 current stack position, for compile checks
323 7C46 (fig-forth-auto680):00323 XRNUM RMB 2
324 7C48 (fig-forth-auto680):00324 XHLD RMB 2
325 7C4A (fig-forth-auto680):00325 XDELAY RMB 2 carriage return delay count
326 7C4C (fig-forth-auto680):00326 XCOLUM RMB 2 carriage width
327 7C4E (fig-forth-auto680):00327 IOSTAT RMB 2 last acia status from write/read
328 7C50 (fig-forth-auto680):00328 RMB 2 ( 4 spares! )
329 7C52 (fig-forth-auto680):00329 RMB 2
330 7C54 (fig-forth-auto680):00330 RMB 2
331 7C56 (fig-forth-auto680):00331 RMB 2
332 (fig-forth-auto680):00332
333 (fig-forth-auto680):00333
334 (fig-forth-auto680):00334
335 (fig-forth-auto680):00335
336 (fig-forth-auto680):00336 *
337 (fig-forth-auto680):00337 *
338 (fig-forth-auto680):00338 * end of user table, start of common system variables
339 (fig-forth-auto680):00339 *
340 (fig-forth-auto680):00340 *
341 (fig-forth-auto680):00341 *
342 7C58 (fig-forth-auto680):00342 XUSE RMB 2
343 7C5A (fig-forth-auto680):00343 XPREV RMB 2
344 7C5C (fig-forth-auto680):00344 RMB 4 ( spares )
345 (fig-forth-auto680):00345
346 (fig-forth-auto680):00346 PAGE
347 (fig-forth-auto680):00347 * The FORTH program ( address $1200 to about $27FF ) will be written
348 (fig-forth-auto680):00348 * so that it can be in a ROM, or write-protected if desired,
349 (fig-forth-auto680):00349 * but right now we're just getting it running.
350 (fig-forth-auto680):00350 ORG CODEBG
351 (fig-forth-auto680):00351
352 (fig-forth-auto680):00352 * ######>> screen 3 <<
353 (fig-forth-auto680):00353 *
354 (fig-forth-auto680):00354 ***************************
355 (fig-forth-auto680):00355 ** C O L D E N T R Y **
356 (fig-forth-auto680):00356 ***************************
357 1200 12 (fig-forth-auto680):00357 ORIG NOP
358 (fig-forth-auto680):00358 * JMP CENT
359 1201 171029 (fig-forth-auto680):00359 LBSR CENT
360 (fig-forth-auto680):00360 ***************************
361 (fig-forth-auto680):00361 ** W A R M E N T R Y **
362 (fig-forth-auto680):00362 ***************************
363 1204 12 (fig-forth-auto680):00363 NOP
364 (fig-forth-auto680):00364 * JMP WENT warm-start code, keeps current dictionary intact
365 1205 171062 (fig-forth-auto680):00365 LBSR WENT warm-start code, keeps current dictionary intact
366 7C (fig-forth-auto680):00366 SETDP IUPDP
367 (fig-forth-auto680):00367
368 (fig-forth-auto680):00368 *
369 (fig-forth-auto680):00369 ******* startup parmeters **************************
370 (fig-forth-auto680):00370 *
371 1208 68090000 (fig-forth-auto680):00371 FDB $6809,0000 cpu & revision
372 120C 0000 (fig-forth-auto680):00372 FDB 0 topmost word in FORTH vocabulary
373 (fig-forth-auto680):00373 * BACKSP FDB $7F backspace character for editing
374 120E 0008 (fig-forth-auto680):00374 BACKSP FDB $08 backspace character for editing
375 1210 7C00 (fig-forth-auto680):00375 UPINIT FDB UORIG initial user area
376 (fig-forth-auto680):00376 * UPINIT FDB UORIG initial user area
377 1212 6A00 (fig-forth-auto680):00377 SINIT FDB ISP ; initial top of data stack
378 (fig-forth-auto680):00378 * SINIT FDB ORIG-$D0 initial top of data stack
379 1214 6BE0 (fig-forth-auto680):00379 RINIT FDB IRP ; initial top of return stack
380 (fig-forth-auto680):00380 * RINIT FDB ORIG-2 initial top of return stack
381 1216 6A00 (fig-forth-auto680):00381 FDB ITIB ; terminal input buffer
382 (fig-forth-auto680):00382 * FDB ORIG-$D0 terminal input buffer
383 1218 001F (fig-forth-auto680):00383 FDB 31 initial name field width
384 121A 0000 (fig-forth-auto680):00384 FDB 0 initial warning mode (0 = no disc)
385 121C 2AD0 (fig-forth-auto680):00385 FENCIN FDB REND initial fence
386 121E 2AD0 (fig-forth-auto680):00386 DPINIT FDB REND cold start value for DICTPT
387 1220 2AA5 (fig-forth-auto680):00387 VOCINT FDB FORTH+4*NATWID
388 1222 0084 (fig-forth-auto680):00388 COLINT FDB 132 initial terminal carriage width
389 1224 0004 (fig-forth-auto680):00389 DELINT FDB 4 initial carriage return delay
390 (fig-forth-auto680):00390 ****************************************************
391 (fig-forth-auto680):00391 *
392 (fig-forth-auto680):00392 PAGE
393 (fig-forth-auto680):00393 *
394 (fig-forth-auto680):00394 * ######>> screen 13 <<
395 (fig-forth-auto680):00395 * These were of questionable use anyway,
396 (fig-forth-auto680):00396 * kept here now to satisfy the assembler and show hints.
397 (fig-forth-auto680):00397 * They're too much trouble to use with native subroutine call anyway.
398 (fig-forth-auto680):00398 * PULABX PULS A ; 24 cycles until 'NEXT'
399 (fig-forth-auto680):00399 * PULS B ;
400 (fig-forth-auto680):00400 * PULABX PULU A,B ; ?? cycles until 'NEXT'
401 (fig-forth-auto680):00401 * STABX STA 0,X 16 cycles until 'NEXT'
402 (fig-forth-auto680):00402 * STB 1,X
403 (fig-forth-auto680):00403 * STABX STD 0,X ; ?? cycles until 'NEXT'
404 1226 2000 (fig-forth-auto680):00404 BRA NEXT
405 (fig-forth-auto680):00405 * GETX LDA 0,X 18 cycles until 'NEXT'
406 (fig-forth-auto680):00406 * LDB 1,X
407 (fig-forth-auto680):00407 * GETX LDD 0,X ?? cycles until 'NEXT'
408 (fig-forth-auto680):00408 * PUSHBA PSHS B ; 8 cycles until 'NEXT'
409 (fig-forth-auto680):00409 * PSHS A ;
410 (fig-forth-auto680):00410 * PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
411 (fig-forth-auto680):00411
412 (fig-forth-auto680):00412
413 (fig-forth-auto680):00413 *
414 (fig-forth-auto680):00414 * "NEXT" takes ?? cycles if TRACE is removed,
415 (fig-forth-auto680):00415 *
416 (fig-forth-auto680):00416 * and ?? cycles if trace is present and NOT tracing.
417 (fig-forth-auto680):00417 *
418 (fig-forth-auto680):00418 * = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
419 (fig-forth-auto680):00419 * =
420 (fig-forth-auto680):00420 * NEXT itself might just completely go away.
421 (fig-forth-auto680):00421 * About the only reason to keep it is to allowing executing a list
422 (fig-forth-auto680):00422 * which allows a cheap TRACE routine.
423 (fig-forth-auto680):00423 *
424 (fig-forth-auto680):00424 * NEXT is a loop which implements the Forth VM.
425 (fig-forth-auto680):00425 * It basically cycles through calling the code out of code lists,
426 (fig-forth-auto680):00426 * one at a time.
427 (fig-forth-auto680):00427 * Using a native CPU return for this uses a few extra cycles per call,
428 (fig-forth-auto680):00428 * compared to simply jumping to each definition and jumping back
429 (fig-forth-auto680):00429 * to the known beginning of the loop,
430 (fig-forth-auto680):00430 * but the loop itself is really only there for convenience.
431 (fig-forth-auto680):00431 *
432 (fig-forth-auto680):00432 * This implementation uses the native subroutine call,
433 (fig-forth-auto680):00433 * to break the wall between Forth code and non-Forth code.
434 (fig-forth-auto680):00434 *
435 (fig-forth-auto680):00435 * NEXT LDX IP
436 (fig-forth-auto680):00436 * LEAX 1,X ; pre-increment mode
437 (fig-forth-auto680):00437 * LEAX 1,X ;
438 (fig-forth-auto680):00438 * STX IP
439 1228 (fig-forth-auto680):00439 NEXT ; IP is Y, push before using, pull before you come back here.
440 (fig-forth-auto680):00440 *
441 (fig-forth-auto680):00441 * NEXT2 LDX 0,X get W which points to CFA of word to be done
442 1228 AEA1 (fig-forth-auto680):00442 NEXT2 LDX ,Y++ get W which points to CFA of word to be done
443 122A 8D08 (fig-forth-auto680):00443 BSR DBGNAM
444 122C 8D58 (fig-forth-auto680):00444 BSR DBGREG
445 (fig-forth-auto680):00445 * But NEXT2 is too much trouble to use with subroutine threading anyway.
446 (fig-forth-auto680):00446 * NEXT3 STX W
447 122E (fig-forth-auto680):00447 NEXT3 ; W is X until you use X for something else. (TOS points back here.)
448 (fig-forth-auto680):00448 * But NEXT3 is too much trouble to use with subroutine threading anyway.
449 (fig-forth-auto680):00449 * LDX 0,X get VECT which points to executable code
450 (fig-forth-auto680):00450 * =
451 (fig-forth-auto680):00451 * The next instruction could be patched to JMP TRACE =
452 (fig-forth-auto680):00452 * if a TRACE routine is available: =
453 (fig-forth-auto680):00453 * =
454 (fig-forth-auto680):00454 * JMP 0,X
455 (fig-forth-auto680):00455
456 122E AD94 (fig-forth-auto680):00456 JSR [,X] ; Saving the postinc cycles,
457 (fig-forth-auto680):00457 * ; but X must be bumped NATWID to the parameters.
458 (fig-forth-auto680):00458 * NOP
459 (fig-forth-auto680):00459 * JMP TRACE ( an alternate for the above )
460 1230 8D54 (fig-forth-auto680):00460 BSR DBGREG ( an alternate for the above )
461 (fig-forth-auto680):00461 * In other words, with the call and the NOP,
462 (fig-forth-auto680):00462 * there is room to patch the call with a JMP to your TRACE
463 (fig-forth-auto680):00463 * routine, which you have to provide.
464 1232 20F4 (fig-forth-auto680):00464 BRA NEXT
465 (fig-forth-auto680):00465 *
466 1234 3437 (fig-forth-auto680):00466 DBGNAM PSHS CC,D,X,Y
467 1236 0D0B (fig-forth-auto680):00467 TST <TRACEM
468 1238 2724 (fig-forth-auto680):00468 BEQ DBGNrt
469 123A 301D (fig-forth-auto680):00469 LEAX -3,X
470 123C E682 (fig-forth-auto680):00470 DBGNlf LDB ,-X
471 123E 2AFC (fig-forth-auto680):00471 BPL DBGNlf
472 1240 108E04C0 (fig-forth-auto680):00472 LDY #$4C0
473 1244 E680 (fig-forth-auto680):00473 LDB ,X+
474 1246 E680 (fig-forth-auto680):00474 DBGNlp LDB ,X+
475 1248 2B04 (fig-forth-auto680):00475 BMI DBGNll
476 124A E7A0 (fig-forth-auto680):00476 STB ,Y+
477 124C 20F8 (fig-forth-auto680):00477 BRA DBGNlp
478 124E C47F (fig-forth-auto680):00478 DBGNll ANDB #$7F
479 1250 E7A0 (fig-forth-auto680):00479 STB ,Y+
480 1252 C660 (fig-forth-auto680):00480 LDB #$60
481 1254 2002 (fig-forth-auto680):00481 BRA DBGNlt
482 1256 E7A0 (fig-forth-auto680):00482 DBGNlc STB ,Y+
483 1258 108C04E0 (fig-forth-auto680):00483 DBGNlt CMPY #$4E0
484 125C 25F8 (fig-forth-auto680):00484 BLO DBGNlc
485 125E 35B7 (fig-forth-auto680):00485 DBGNrt PULS CC,D,X,Y,PC
486 (fig-forth-auto680):00486 *
487 (fig-forth-auto680):00487 *
488 1260 54 (fig-forth-auto680):00488 MKhxBh LSRB
489 1261 54 (fig-forth-auto680):00489 LSRB
490 1262 54 (fig-forth-auto680):00490 LSRB
491 1263 54 (fig-forth-auto680):00491 LSRB
492 1264 C40F (fig-forth-auto680):00492 MKhxBl ANDB #$0F
493 1266 CB30 (fig-forth-auto680):00493 ADDB #$30
494 1268 C139 (fig-forth-auto680):00494 CMPB #$39
495 126A 2302 (fig-forth-auto680):00495 BLS MKhxBx
496 126C CBC7 (fig-forth-auto680):00496 ADDB #$C7 ; ($40-$39)-$40
497 126E 39 (fig-forth-auto680):00497 MKhxBx RTS
498 (fig-forth-auto680):00498 *
499 126F 1E89 (fig-forth-auto680):00499 OUThxA EXG A,B
500 1271 8D05 (fig-forth-auto680):00500 BSR OUThxB
501 1273 1E89 (fig-forth-auto680):00501 EXG A,B
502 1275 39 (fig-forth-auto680):00502 RTS
503 (fig-forth-auto680):00503 *
504 1276 8DF7 (fig-forth-auto680):00504 OUThxD BSR OUThxA
505 1278 3404 (fig-forth-auto680):00505 OUThxB PSHS B
506 127A 8DE4 (fig-forth-auto680):00506 BSR MKhxBh
507 127C E780 (fig-forth-auto680):00507 STB ,X+
508 127E E6E4 (fig-forth-auto680):00508 LDB ,S
509 1280 8DE2 (fig-forth-auto680):00509 BSR MKhxBl
510 1282 E780 (fig-forth-auto680):00510 STB ,X+
511 1284 3584 (fig-forth-auto680):00511 PULS B,PC
512 (fig-forth-auto680):00512 *
513 1286 347F (fig-forth-auto680):00513 DBGREG PSHS U,Y,X,DP,B,A,CC
514 1288 0D0B (fig-forth-auto680):00514 TST <TRACEM
515 128A 102700DF (fig-forth-auto680):00515 LBEQ DBGRrt
516 128E 318D00DD (fig-forth-auto680):00516 LEAY DBGRLB,PCR
517 1292 8E04E0 (fig-forth-auto680):00517 LDX #$4E0
518 1295 ECA1 (fig-forth-auto680):00518 DBGRlp LDD ,Y++
519 1297 2704 (fig-forth-auto680):00519 BEQ DBGRdn
520 1299 ED81 (fig-forth-auto680):00520 STD ,X++
521 129B 20F8 (fig-forth-auto680):00521 BRA DBGRlp
522 129D 8E0500 (fig-forth-auto680):00522 DBGRdn LDX #$500
523 12A0 A663 (fig-forth-auto680):00523 LDA 3,S ; DP
524 12A2 E6E4 (fig-forth-auto680):00524 LDB ,S ; CC
525 12A4 8DD0 (fig-forth-auto680):00525 BSR OUThxD
526 12A6 C660 (fig-forth-auto680):00526 LDB #$60
527 12A8 E780 (fig-forth-auto680):00527 STB ,X+
528 12AA EC6A (fig-forth-auto680):00528 LDD 3*NATWID+4,S ; PC:505
529 12AC 8DC8 (fig-forth-auto680):00529 BSR OUThxD
530 12AE C660 (fig-forth-auto680):00530 LDB #$60
531 12B0 E780 (fig-forth-auto680):00531 STB ,X+
532 12B2 1F40 (fig-forth-auto680):00532 TFR S,D ; 509
533 12B4 C3000C (fig-forth-auto680):00533 ADDD #4*NATWID+4
534 12B7 8DBD (fig-forth-auto680):00534 BSR OUThxD
535 12B9 EC68 (fig-forth-auto680):00535 LDD 2*NATWID+4,S ; U:50E
536 12BB 8DB9 (fig-forth-auto680):00536 BSR OUThxD
537 12BD C660 (fig-forth-auto680):00537 LDB #$60
538 12BF E780 (fig-forth-auto680):00538 STB ,X+
539 12C1 EC66 (fig-forth-auto680):00539 LDD 1*NATWID+4,S ; Y:513
540 12C3 8DB1 (fig-forth-auto680):00540 BSR OUThxD
541 12C5 EC64 (fig-forth-auto680):00541 LDD 0*NATWID+4,S ; X at 517
542 12C7 8DAD (fig-forth-auto680):00542 BSR OUThxD
543 12C9 C660 (fig-forth-auto680):00543 LDB #$60
544 12CB E780 (fig-forth-auto680):00544 STB ,X+
545 12CD EC61 (fig-forth-auto680):00545 LDD 1,S ; D at 51C
546 12CF 8DA5 (fig-forth-auto680):00546 BSR OUThxD
547 12D1 C660 (fig-forth-auto680):00547 LDB #$60
548 12D3 E780 (fig-forth-auto680):00548 STB ,X+
549 12D5 E780 (fig-forth-auto680):00549 STB ,X+
550 12D7 E780 (fig-forth-auto680):00550 STB ,X+
551 12D9 E780 (fig-forth-auto680):00551 STB ,X+
552 12DB E780 (fig-forth-auto680):00552 STB ,X+
553 12DD ECF80A (fig-forth-auto680):00553 LDD [3*NATWID+4,S] ; PC
554 12E0 8D94 (fig-forth-auto680):00554 BSR OUThxD
555 12E2 C660 (fig-forth-auto680):00555 LDB #$60
556 12E4 E780 (fig-forth-auto680):00556 STB ,X+
557 12E6 EC6C (fig-forth-auto680):00557 LDD 4*NATWID+4,S ; S
558 12E8 8D8C (fig-forth-auto680):00558 BSR OUThxD
559 12EA ECF808 (fig-forth-auto680):00559 LDD [2*NATWID+4,S] ; U
560 12ED 8D87 (fig-forth-auto680):00560 BSR OUThxD
561 12EF C660 (fig-forth-auto680):00561 LDB #$60
562 12F1 E780 (fig-forth-auto680):00562 STB ,X+
563 12F3 ECF806 (fig-forth-auto680):00563 LDD [1*NATWID+4,S] ; Y
564 12F6 17FF7D (fig-forth-auto680):00564 LBSR OUThxD
565 12F9 ECF804 (fig-forth-auto680):00565 LDD [0*NATWID+4,S] ; X
566 12FC 17FF77 (fig-forth-auto680):00566 LBSR OUThxD
567 12FF C660 (fig-forth-auto680):00567 LDB #$60
568 1301 E780 (fig-forth-auto680):00568 STB ,X+
569 1303 E780 (fig-forth-auto680):00569 STB ,X+
570 1305 E780 (fig-forth-auto680):00570 STB ,X+
571 1307 E780 (fig-forth-auto680):00571 STB ,X+
572 1309 E780 (fig-forth-auto680):00572 STB ,X+
573 130B C600 (fig-forth-auto680):00573 LDB #0
574 130D 1E9B (fig-forth-auto680):00574 EXG B,DP
575 130F AD9FA000 (fig-forth-auto680):00575 DBGRkl JSR [$A000]
576 1313 27FA (fig-forth-auto680):00576 BEQ DBGRkl
577 1315 FD043E (fig-forth-auto680):00577 STD $43E
578 1318 1EB9 (fig-forth-auto680):00578 EXG DP,B
579 131A 8155 (fig-forth-auto680):00579 CMPA #$55 ; 'U'
580 131C 273C (fig-forth-auto680):00580 BEQ DBGRdU
581 131E 8153 (fig-forth-auto680):00581 CMPA #$53 ; 'S'
582 1320 271E (fig-forth-auto680):00582 BEQ DBGRdS
583 1322 8149 (fig-forth-auto680):00583 CMPA #$49 ; 'I'
584 1324 2647 (fig-forth-auto680):00584 BNE DBGRrt
585 1326 DC22 (fig-forth-auto680):00585 DBGRin LDD <XTIB
586 1328 D330 (fig-forth-auto680):00586 ADDD <XIN
587 132A 1F02 (fig-forth-auto680):00587 TFR D,Y
588 132C 17FF47 (fig-forth-auto680):00588 LBSR OUThxD
589 132F C63A (fig-forth-auto680):00589 LDB #$3a ; ':'
590 1331 E780 (fig-forth-auto680):00590 STB ,X+
591 1333 964C (fig-forth-auto680):00591 LDA <XCOLUM
592 1335 E6A0 (fig-forth-auto680):00592 DBGRip LDB ,Y+
593 1337 E780 (fig-forth-auto680):00593 STB ,X+
594 1339 2732 (fig-forth-auto680):00594 BEQ DBGRrt
595 133B 4A (fig-forth-auto680):00595 DBGRit DECA
596 133C 26F7 (fig-forth-auto680):00596 BNE DBGRip
597 133E 202D (fig-forth-auto680):00597 BRA DBGRrt
598 1340 1F42 (fig-forth-auto680):00598 DBGRdS TFR S,Y
599 1342 2009 (fig-forth-auto680):00599 BRA DBGRst
600 1344 ECA1 (fig-forth-auto680):00600 DBGRsp LDD ,Y++
601 1346 17FF2D (fig-forth-auto680):00601 LBSR OUThxD
602 1349 C660 (fig-forth-auto680):00602 LDB #$60
603 134B E780 (fig-forth-auto680):00603 STB ,X+
604 134D 109C20 (fig-forth-auto680):00604 DBGRst CMPY <XRZERO
605 1350 25F2 (fig-forth-auto680):00605 BLO DBGRsp
606 1352 C63A (fig-forth-auto680):00606 LDB #$3a ; ':'
607 1354 E780 (fig-forth-auto680):00607 STB ,X+
608 1356 C655 (fig-forth-auto680):00608 LDB #$55
609 1358 E780 (fig-forth-auto680):00609 STB ,X+
610 135A 10AE68 (fig-forth-auto680):00610 DBGRdU LDY 2*NATWID+4,S
611 135D 2009 (fig-forth-auto680):00611 BRA DBGRut
612 135F ECA1 (fig-forth-auto680):00612 DBGRup LDD ,Y++
613 1361 17FF12 (fig-forth-auto680):00613 LBSR OUThxD
614 1364 C660 (fig-forth-auto680):00614 LDB #$60
615 1366 E780 (fig-forth-auto680):00615 STB ,X+
616 1368 109C1E (fig-forth-auto680):00616 DBGRut CMPY <XSPZER
617 136B 25F2 (fig-forth-auto680):00617 BLO DBGRup
618 136D 35FF (fig-forth-auto680):00618 DBGRrt PULS CC,A,B,DP,X,Y,U,PC
619 136F 4450434320504320 (fig-forth-auto680):00619 DBGRLB FCC 'DPCC PC S U Y X A B '
623 138F 00000000 (fig-forth-auto680):00620 FDB 0,0
624 (fig-forth-auto680):00621
625 (fig-forth-auto680):00622
626 (fig-forth-auto680):00623 *
627 (fig-forth-auto680):00624 * =
628 (fig-forth-auto680):00625 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
629 (fig-forth-auto680):00626
630 (fig-forth-auto680):00627
631 (fig-forth-auto680):00628 PAGE
632 (fig-forth-auto680):00629 *
633 (fig-forth-auto680):00630 * ======>> 1 <<
634 (fig-forth-auto680):00631 * ( --- n )
635 (fig-forth-auto680):00632 * Pushes the following natural width integer from the instruction stream
636 (fig-forth-auto680):00633 * as a literal, or immediate value.
637 (fig-forth-auto680):00634 *
638 (fig-forth-auto680):00635 * FDB {OP}
639 (fig-forth-auto680):00636 * FDB {OP}
640 (fig-forth-auto680):00637 * FDB LIT
641 (fig-forth-auto680):00638 * FDB LITERAL-TO-BE-PUSHED
642 (fig-forth-auto680):00639 * FDB {OP}
643 (fig-forth-auto680):00640 *
644 (fig-forth-auto680):00641 * In native processor code, there should be a better way, use that instead.
645 (fig-forth-auto680):00642 * More specifically, DO NOT CALL THIS from assembly language code.
646 (fig-forth-auto680):00643 * (Note that there is no compile-only flag in the fig model.)
647 (fig-forth-auto680):00644 *
648 (fig-forth-auto680):00645 * See (FIND), or PFIND , for layout of the header format.
649 (fig-forth-auto680):00646 *
650 1393 83 (fig-forth-auto680):00647 FCB $83
651 1394 4C49 (fig-forth-auto680):00648 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
652 1396 D4 (fig-forth-auto680):00649 FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
653 1397 0000 (fig-forth-auto680):00650 FDB 0 ; link of zero to terminate dictionary scan
654 1399 139B (fig-forth-auto680):00651 LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
655 139B ECA1 (fig-forth-auto680):00652 LDD ,Y++
656 139D 3606 (fig-forth-auto680):00653 PSHU A,B
657 139F 39 (fig-forth-auto680):00654 RTS
658 (fig-forth-auto680):00655 * LDX IP
659 (fig-forth-auto680):00656 * LEAX 1,X ;
660 (fig-forth-auto680):00657 * LEAX 1,X ;
661 (fig-forth-auto680):00658 * STX IP
662 (fig-forth-auto680):00659 * LDA 0,X
663 (fig-forth-auto680):00660 * LDB 1,X
664 (fig-forth-auto680):00661 * JMP PUSHBA
665 (fig-forth-auto680):00662 *
666 (fig-forth-auto680):00663 * ######>> screen 14 <<
667 (fig-forth-auto680):00664 * ======>> 2 <<
668 (fig-forth-auto680):00665 * ( --- n )
669 (fig-forth-auto680):00666 * Pushes the following byte from the instruction stream
670 (fig-forth-auto680):00667 * as a literal, or immediate value.
671 (fig-forth-auto680):00668 *
672 (fig-forth-auto680):00669 * FDB {OP}
673 (fig-forth-auto680):00670 * FDB {OP}
674 (fig-forth-auto680):00671 * FDB LIT8
675 (fig-forth-auto680):00672 * FCB LITERAL-TO-BE-PUSHED
676 (fig-forth-auto680):00673 * FDB {OP}
677 (fig-forth-auto680):00674 *
678 (fig-forth-auto680):00675 * If this is kept, it should have a header for TRACE to read.
679 (fig-forth-auto680):00676 * If the data bus is wider than a byte, you don't want to do this.
680 (fig-forth-auto680):00677 * Byte shaving like this is often counter-productive anyway.
681 (fig-forth-auto680):00678 * Changing the name to LIT8, hoping that will be more understandable.
682 (fig-forth-auto680):00679 * Also, see comments for LIT.
683 (fig-forth-auto680):00680 * (Note that there is no compile-only flag in the fig model.)
684 13A0 84 (fig-forth-auto680):00681 FCB $84
685 13A1 4C4954 (fig-forth-auto680):00682 FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
686 13A4 B8 (fig-forth-auto680):00683 FCB $B8
687 13A5 1393 (fig-forth-auto680):00684 FDB LIT-6
688 13A7 13A9 (fig-forth-auto680):00685 LIT8 FDB *+NATWID (this was an invisible word, with no header)
689 13A9 E6A0 (fig-forth-auto680):00686 LDB ,Y+ ; This also is meaningless in native code.
690 13AB 4F (fig-forth-auto680):00687 CLRA
691 13AC 3606 (fig-forth-auto680):00688 PSHU A,B
692 13AE 39 (fig-forth-auto680):00689 RTS
693 (fig-forth-auto680):00690 * LDX IP
694 (fig-forth-auto680):00691 * LEAX 1,X ;
695 (fig-forth-auto680):00692 * STX IP
696 (fig-forth-auto680):00693 * CLRA ;
697 (fig-forth-auto680):00694 * LDB 1,X
698 (fig-forth-auto680):00695 * JMP PUSHBA
699 (fig-forth-auto680):00696 *
700 (fig-forth-auto680):00697 * ( n off --- n )
701 (fig-forth-auto680):00698 * off is offset in video buffer area.
702 13AF 87 (fig-forth-auto680):00699 FCB $87
703 13B0 53484F57544F (fig-forth-auto680):00700 FCC 'SHOWTO' ; 'SHOWTOS'
704 13B6 D3 (fig-forth-auto680):00701 FCB $D3 ; 'S'
705 13B7 13A0 (fig-forth-auto680):00702 FDB LIT8-7
706 13B9 13BB (fig-forth-auto680):00703 SHOTOS FDB *+NATWID
707 13BB 8E0400 (fig-forth-auto680):00704 LDX #$400
708 13BE ECC1 (fig-forth-auto680):00705 LDD ,U++
709 13C0 308B (fig-forth-auto680):00706 LEAX D,X
710 13C2 ECC4 (fig-forth-auto680):00707 LDD ,U
711 13C4 17FEAF (fig-forth-auto680):00708 LBSR OUThxD
712 13C7 39 (fig-forth-auto680):00709 RTS
713 (fig-forth-auto680):00710 *
714 13C8 85 (fig-forth-auto680):00711 FCB $85
715 13C9 54524F46 (fig-forth-auto680):00712 FCC 'TROF' ; 'TROFF'
716 13CD C6 (fig-forth-auto680):00713 FCB $C6 ; 'F'|$80
717 13CE 13AF (fig-forth-auto680):00714 FDB SHOTOS-10
718 13D0 13D2 (fig-forth-auto680):00715 TROFF FDB *+NATWID
719 13D2 0F0B (fig-forth-auto680):00716 CLR <TRACEM
720 13D4 39 (fig-forth-auto680):00717 RTS
721 (fig-forth-auto680):00718 *
722 13D5 84 (fig-forth-auto680):00719 FCB $84
723 13D6 54524F (fig-forth-auto680):00720 FCC 'TRO' ; 'TRON'
724 13D9 CE (fig-forth-auto680):00721 FCB $CE ; 'N'|$80
725 13DA 13C8 (fig-forth-auto680):00722 FDB TROFF-8
726 13DC 13DE (fig-forth-auto680):00723 TRON FDB *+NATWID
727 13DE 0C0B (fig-forth-auto680):00724 INC <TRACEM
728 13E0 39 (fig-forth-auto680):00725 RTS
729 (fig-forth-auto680):00726 *
730 (fig-forth-auto680):00727 * ======>> 3 <<
731 (fig-forth-auto680):00728 * ( adr --- )
732 (fig-forth-auto680):00729 * Jump to address on stack. Used by the "outer" interpreter to
733 (fig-forth-auto680):00730 * interactively invoke routines.
734 (fig-forth-auto680):00731 * Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
735 13E1 87 (fig-forth-auto680):00732 FCB $87
736 13E2 455845435554 (fig-forth-auto680):00733 FCC 'EXECUT' ; 'EXECUTE'
737 13E8 C5 (fig-forth-auto680):00734 FCB $C5
738 13E9 13D5 (fig-forth-auto680):00735 FDB TRON-7
739 13EB 13ED (fig-forth-auto680):00736 EXEC FDB *+NATWID
740 13ED 3710 (fig-forth-auto680):00737 PULU X ; Gotta have W anyway, just in case.
741 13EF 6E94 (fig-forth-auto680):00738 JMP [,X] ; Tail return.
742 (fig-forth-auto680):00739 * TFR S,X ; TSX :
743 (fig-forth-auto680):00740 * LDX 0,X get code field address (CFA)
744 (fig-forth-auto680):00741 * LEAS 1,S ; pop stack
745 (fig-forth-auto680):00742 * LEAS 1,S ;
746 (fig-forth-auto680):00743 * JMP NEXT3
747 (fig-forth-auto680):00744 *
748 (fig-forth-auto680):00745 * ######>> screen 15 <<
749 (fig-forth-auto680):00746 * ======>> 4 <<
750 (fig-forth-auto680):00747 * ( --- ) C
751 (fig-forth-auto680):00748 * Add the following word from the instruction stream to the
752 (fig-forth-auto680):00749 * instruction pointer (Y++). Causes a program branch in Forth code stream.
753 (fig-forth-auto680):00750 *
754 (fig-forth-auto680):00751 * In native processor code, there should be a better way, use that instead.
755 (fig-forth-auto680):00752 * More specifically, DO NOT CALL THIS from assembly language code.
756 (fig-forth-auto680):00753 * This is only for Forth code stream.
757 (fig-forth-auto680):00754 * Also, see comments for LIT.
758 13F1 86 (fig-forth-auto680):00755 FCB $86
759 13F2 4252414E43 (fig-forth-auto680):00756 FCC 'BRANC' ; 'BRANCH'
760 13F7 C8 (fig-forth-auto680):00757 FCB $C8
761 13F8 13E1 (fig-forth-auto680):00758 FDB EXEC-10
762 13FA 140F (fig-forth-auto680):00759 BRAN FDB ZBYES ; Go steal code in ZBRANCH
763 (fig-forth-auto680):00760
764 (fig-forth-auto680):00761 * Moving code around to optimize the branch taking case in 0BRANCH.
765 13FC 3122 (fig-forth-auto680):00762 ZBNO LEAY NATWID,Y ; No branch.
766 13FE 39 (fig-forth-auto680):00763 RTS
767 (fig-forth-auto680):00764 * ======>> 5 <<
768 (fig-forth-auto680):00765 * ( f --- ) C
769 (fig-forth-auto680):00766 * BRANCH if flag is zero.
770 (fig-forth-auto680):00767 *
771 (fig-forth-auto680):00768 * In native processor code, there should be a better way, use that instead.
772 (fig-forth-auto680):00769 * More specifically, DO NOT CALL THIS from assembly language code.
773 (fig-forth-auto680):00770 * This is only for Forth code stream.
774 (fig-forth-auto680):00771 * Also, see comments for LIT.
775 13FF 87 (fig-forth-auto680):00772 FCB $87
776 1400 304252414E43 (fig-forth-auto680):00773 FCC '0BRANC' ; '0BRANCH'
777 1406 C8 (fig-forth-auto680):00774 FCB $C8
778 1407 13F1 (fig-forth-auto680):00775 FDB BRAN-9
779 1409 140B (fig-forth-auto680):00776 ZBRAN FDB *+NATWID
780 140B ECC1 (fig-forth-auto680):00777 LDD ,U++
781 140D 26ED (fig-forth-auto680):00778 BNE ZBNO
782 140F ECA1 (fig-forth-auto680):00779 ZBYES LDD ,Y++
783 1411 31AB (fig-forth-auto680):00780 LEAY D,Y ; IP is postinc
784 1413 39 (fig-forth-auto680):00781 RTS
785 (fig-forth-auto680):00782 * PULS A ;
786 (fig-forth-auto680):00783 * PULS B ;
787 (fig-forth-auto680):00784 * PSHS B ; ** emulating ABA:
788 (fig-forth-auto680):00785 * ADDA ,S+ ;
789 (fig-forth-auto680):00786 * BNE ZBNO
790 (fig-forth-auto680):00787 * BCS ZBNO
791 (fig-forth-auto680):00788 * ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
792 (fig-forth-auto680):00789 * LDB 3,X
793 (fig-forth-auto680):00790 * LDA 2,X
794 (fig-forth-auto680):00791 * ADDB IP+1
795 (fig-forth-auto680):00792 * ADCA IP
796 (fig-forth-auto680):00793 * STB IP+1
797 (fig-forth-auto680):00794 * STA IP
798 (fig-forth-auto680):00795 * JMP NEXT
799 (fig-forth-auto680):00796 * ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
800 (fig-forth-auto680):00797 * LEAX 1,X ; jump over branch delta
801 (fig-forth-auto680):00798 * LEAX 1,X ;
802 (fig-forth-auto680):00799 * STX IP
803 (fig-forth-auto680):00800 * JMP NEXT
804 (fig-forth-auto680):00801 *
805 (fig-forth-auto680):00802 * ######>> screen 16 <<
806 (fig-forth-auto680):00803 * ======>> 6 <<
807 (fig-forth-auto680):00804 * ( --- ) ( limit index *** limit index+1) C
808 (fig-forth-auto680):00805 * ( limit index *** )
809 (fig-forth-auto680):00806 * Counting loop primitive. The counter and limit are the top two
810 (fig-forth-auto680):00807 * words on the return stack. If the updated index/counter does
811 (fig-forth-auto680):00808 * not exceed the limit, a branch occurs. If it does, the branch
812 (fig-forth-auto680):00809 * does not occur, and the index and limit are dropped from the
813 (fig-forth-auto680):00810 * return stack.
814 (fig-forth-auto680):00811 *
815 (fig-forth-auto680):00812 * In native processor code, there should be a better way, use that instead.
816 (fig-forth-auto680):00813 * More specifically, DO NOT CALL THIS from assembly language code.
817 (fig-forth-auto680):00814 * This is only for Forth code stream.
818 (fig-forth-auto680):00815 * Also, see comments for LIT.
819 1414 86 (fig-forth-auto680):00816 FCB $86
820 1415 284C4F4F50 (fig-forth-auto680):00817 FCC '(LOOP' ; '(LOOP)'
821 141A A9 (fig-forth-auto680):00818 FCB $A9
822 141B 13FF (fig-forth-auto680):00819 FDB ZBRAN-10
823 141D 141F (fig-forth-auto680):00820 XLOOP FDB *+NATWID
824 141F CC0001 (fig-forth-auto680):00821 LDD #1 ; Borrowing from BIF-6809.
825 1422 E362 (fig-forth-auto680):00822 XLOOPA ADDD NATWID,S ; Dodge the return address.
826 1424 ED62 (fig-forth-auto680):00823 STD NATWID,S
827 1426 A364 (fig-forth-auto680):00824 SUBD 2*NATWID,S
828 1428 2DE5 (fig-forth-auto680):00825 BLT ZBYES ; signed
829 142A 3122 (fig-forth-auto680):00826 XLOOPN LEAY NATWID,Y
830 142C AEE4 (fig-forth-auto680):00827 LDX ,S ; synthetic return
831 142E 3266 (fig-forth-auto680):00828 LEAS 3*NATWID,S ; Clean up the index and limit.
832 1430 6E84 (fig-forth-auto680):00829 JMP ,X
833 (fig-forth-auto680):00830 * CLRA ;
834 (fig-forth-auto680):00831 * LDB #1 get set to increment counter by 1 (Clears N.)
835 (fig-forth-auto680):00832 * BRA XPLOP2 go steal other guy's code!
836 (fig-forth-auto680):00833 *
837 (fig-forth-auto680):00834 * ======>> 7 <<
838 (fig-forth-auto680):00835 * ( n --- ) ( limit index *** limit index+n ) C
839 (fig-forth-auto680):00836 * ( limit index *** )
840 (fig-forth-auto680):00837 * Loop with a variable increment. Terminates when the index
841 (fig-forth-auto680):00838 * crosses the boundary from one below the limit to the limit. A
842 (fig-forth-auto680):00839 * positive n will cause termination if the result index equals the
843 (fig-forth-auto680):00840 * limit. A negative n must cause the index to become less than
844 (fig-forth-auto680):00841 * the limit to cause loop termination.
845 (fig-forth-auto680):00842 *
846 (fig-forth-auto680):00843 * Note that the end conditions are not symmetric around zero.
847 (fig-forth-auto680):00844 *
848 (fig-forth-auto680):00845 * In native processor code, there should be a better way, use that instead.
849 (fig-forth-auto680):00846 * More specifically, DO NOT CALL THIS from assembly language code.
850 (fig-forth-auto680):00847 * This is only for Forth code stream.
851 (fig-forth-auto680):00848 * Also, see comments for LIT.
852 1432 87 (fig-forth-auto680):00849 FCB $87
853 1433 282B4C4F4F50 (fig-forth-auto680):00850 FCC '(+LOOP' ; '(+LOOP)'
854 1439 A9 (fig-forth-auto680):00851 FCB $A9
855 143A 1414 (fig-forth-auto680):00852 FDB XLOOP-9
856 143C 143E (fig-forth-auto680):00853 XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
857 143E ECC1 (fig-forth-auto680):00854 LDD ,U++ ; inc val
858 1440 2AE0 (fig-forth-auto680):00855 BPL XLOOPA ; Steal plain loop code for forward count.
859 1442 E362 (fig-forth-auto680):00856 ADDD NATWID,S ; Dodge the return address
860 1444 ED62 (fig-forth-auto680):00857 STD NATWID,S
861 1446 A364 (fig-forth-auto680):00858 SUBD 2*NATWID,S
862 1448 2EC5 (fig-forth-auto680):00859 BGT ZBYES ; signed
863 144A 20DE (fig-forth-auto680):00860 BRA XLOOPN ; This path is less time-sensitive.
864 (fig-forth-auto680):00861 *
865 (fig-forth-auto680):00862 * This should work, but I want to use tested code.
866 (fig-forth-auto680):00863 * PULU A,B ; Get the increment.
867 (fig-forth-auto680):00864 * XPLOP2 PULS X ; Pre-clear the return stack.
868 (fig-forth-auto680):00865 * PSHU A ; Save the direction in high bit.
869 (fig-forth-auto680):00866 * ADDD ,S ; Count.
870 (fig-forth-auto680):00867 * STD ,S ; Update.
871 (fig-forth-auto680):00868 * SUBD NATWID,S ; Check limit.
872 (fig-forth-auto680):00869 **
873 (fig-forth-auto680):00870 ** I think this should work:
874 (fig-forth-auto680):00871 * EORA ,U+ ; dir < 0 and (count - limit) >= 0
875 (fig-forth-auto680):00872 * BPL XPLONO ; or dir >= 0 and (count - limit) < 0
876 (fig-forth-auto680):00873 * LDD ,Y++
877 (fig-forth-auto680):00874 * LEAY D,Y ; IP is postinc
878 (fig-forth-auto680):00875 * JMP ,X
879 (fig-forth-auto680):00876 * XPLONO LEAS 2*NATWID,S
880 (fig-forth-auto680):00877 * JMP ,X ; synthetic return
881 (fig-forth-auto680):00878 *
882 (fig-forth-auto680):00879 * This definitely should work:
883 (fig-forth-auto680):00880 * TST ,U+ ; Get the sign
884 (fig-forth-auto680):00881 * BPL XPLOF ;
885 (fig-forth-auto680):00882 * CMPD NATWID,S
886 (fig-forth-auto680):00883 * BMI XPLONO
887 (fig-forth-auto680):00884 * XPLOYE LDD ,Y++
888 (fig-forth-auto680):00885 * LEAY D,Y ; IP is postinc
889 (fig-forth-auto680):00886 * JMP ,X
890 (fig-forth-auto680):00887 * XPLOF CMPD NATWID,S
891 (fig-forth-auto680):00888 * BMI XPLOYE
892 (fig-forth-auto680):00889 * XPLONO LEAS 2*NATWID,S
893 (fig-forth-auto680):00890 * JMP ,X ; synthetic return
894 (fig-forth-auto680):00891 *
895 (fig-forth-auto680):00892 * 6800 Probably could have used the exclusive-or method, too.:
896 (fig-forth-auto680):00893 * PULS A ; get increment
897 (fig-forth-auto680):00894 * PULS B ;
898 (fig-forth-auto680):00895 * XPLOP2 TSTA ;
899 (fig-forth-auto680):00896 * BPL XPLOF forward looping
900 (fig-forth-auto680):00897 * BSR XPLOPS
901 (fig-forth-auto680):00898 * ORCC #$01 ; SEC :
902 (fig-forth-auto680):00899 * SBCB 5,X
903 (fig-forth-auto680):00900 * SBCA 4,X
904 (fig-forth-auto680):00901 * BPL ZBYES
905 (fig-forth-auto680):00902 * BRA XPLONO fall through
906 (fig-forth-auto680):00903 *
907 (fig-forth-auto680):00904 * the subroutine :
908 (fig-forth-auto680):00905 * XPLOPS LDX RP
909 (fig-forth-auto680):00906 * ADDB 3,X add it to counter
910 (fig-forth-auto680):00907 * ADCA 2,X
911 (fig-forth-auto680):00908 * STB 3,X store new counter value
912 (fig-forth-auto680):00909 * STA 2,X
913 (fig-forth-auto680):00910 * RTS
914 (fig-forth-auto680):00911 *
915 (fig-forth-auto680):00912 * XPLOF BSR XPLOPS
916 (fig-forth-auto680):00913 * SUBB 5,X
917 (fig-forth-auto680):00914 * SBCA 4,X
918 (fig-forth-auto680):00915 * BMI ZBYES
919 (fig-forth-auto680):00916 *
920 (fig-forth-auto680):00917 * XPLONO LEAX 1,X ; done, don't branch back
921 (fig-forth-auto680):00918 * LEAX 1,X ;
922 (fig-forth-auto680):00919 * LEAX 1,X ;
923 (fig-forth-auto680):00920 * LEAX 1,X ;
924 (fig-forth-auto680):00921 * STX RP
925 (fig-forth-auto680):00922 * BRA ZBNO use ZBRAN to skip over unused delta
926 (fig-forth-auto680):00923 *
927 (fig-forth-auto680):00924 * ######>> screen 17 <<
928 (fig-forth-auto680):00925 * ======>> 8 <<
929 (fig-forth-auto680):00926 * ( limit index --- ) ( *** limit index )
930 (fig-forth-auto680):00927 * Move the loop parameters to the return stack. Synonym for D>R.
931 144C 84 (fig-forth-auto680):00928 FCB $84
932 144D 28444F (fig-forth-auto680):00929 FCC '(DO' ; '(DO)'
933 1450 A9 (fig-forth-auto680):00930 FCB $A9
934 1451 1432 (fig-forth-auto680):00931 FDB XPLOOP-10
935 1453 1455 (fig-forth-auto680):00932 XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
936 1455 AEE4 (fig-forth-auto680):00933 LDX ,S ; Save the return address.
937 1457 3706 (fig-forth-auto680):00934 PULU A,B
938 1459 3406 (fig-forth-auto680):00935 PSHS A,B
939 145B 3706 (fig-forth-auto680):00936 PULU A,B ; Maintain order.
940 145D ED62 (fig-forth-auto680):00937 STD NATWID,S
941 145F 6E84 (fig-forth-auto680):00938 JMP ,X ; synthetic return
942 (fig-forth-auto680):00939 *
943 (fig-forth-auto680):00940 * LDX RP
944 (fig-forth-auto680):00941 * LEAX -1,X ;
945 (fig-forth-auto680):00942 * LEAX -1,X ;
946 (fig-forth-auto680):00943 * LEAX -1,X ;
947 (fig-forth-auto680):00944 * LEAX -1,X ;
948 (fig-forth-auto680):00945 * STX RP
949 (fig-forth-auto680):00946 * PULS A ;
950 (fig-forth-auto680):00947 * PULS B ;
951 (fig-forth-auto680):00948 * STA 2,X
952 (fig-forth-auto680):00949 * STB 3,X
953 (fig-forth-auto680):00950 * PULS A ;
954 (fig-forth-auto680):00951 * PULS B ;
955 (fig-forth-auto680):00952 * STA 4,X
956 (fig-forth-auto680):00953 * STB 5,X
957 (fig-forth-auto680):00954 * JMP NEXT
958 (fig-forth-auto680):00955 *
959 (fig-forth-auto680):00956 * ======>> 9 <<
960 (fig-forth-auto680):00957 * ( --- index ) ( limit index *** limit index )
961 (fig-forth-auto680):00958 * Copy the loop index from the return stack. Synonym for R.
962 1461 81 (fig-forth-auto680):00959 FCB $81 I
963 1462 C9 (fig-forth-auto680):00960 FCB $C9
964 1463 144C (fig-forth-auto680):00961 FDB XDO-7
965 1465 1467 (fig-forth-auto680):00962 I FDB *+NATWID
966 1467 EC62 (fig-forth-auto680):00963 LDD NATWID,S ; Dodge return address.
967 1469 3606 (fig-forth-auto680):00964 PSHU A,B
968 146B 39 (fig-forth-auto680):00965 RTS
969 (fig-forth-auto680):00966 * LDX RP
970 (fig-forth-auto680):00967 * LEAX 1,X ;
971 (fig-forth-auto680):00968 * LEAX 1,X ;
972 (fig-forth-auto680):00969 * JMP GETX
973 (fig-forth-auto680):00970 *
974 (fig-forth-auto680):00971 * ######>> screen 18 <<
975 (fig-forth-auto680):00972 * ======>> 10 <<
976 (fig-forth-auto680):00973 * ( c base --- false )
977 (fig-forth-auto680):00974 * ( c base --- n true )
978 (fig-forth-auto680):00975 * Translate C in base, yielding a translation valid flag. If the
979 (fig-forth-auto680):00976 * translation is not valid in the specified base, only the false
980 (fig-forth-auto680):00977 * flag is returned.
981 146C 85 (fig-forth-auto680):00978 FCB $85
982 146D 44494749 (fig-forth-auto680):00979 FCC 'DIGI' ; 'DIGIT'
983 1471 D4 (fig-forth-auto680):00980 FCB $D4
984 1472 1461 (fig-forth-auto680):00981 FDB I-4
985 1474 1476 (fig-forth-auto680):00982 DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
986 1476 EC42 (fig-forth-auto680):00983 LDD NATWID,U ; Check the whole thing.
987 1478 830030 (fig-forth-auto680):00984 SUBD #$30 ; ascii zero
988 147B 2B22 (fig-forth-auto680):00985 BMI DIGIT2 IF LESS THAN '0', ILLEGAL
989 147D 1083000A (fig-forth-auto680):00986 CMPD #$A
990 1481 2B0F (fig-forth-auto680):00987 BMI DIGIT0 IF '9' OR LESS
991 1483 10830011 (fig-forth-auto680):00988 CMPD #$11
992 1487 2B16 (fig-forth-auto680):00989 BMI DIGIT2 if less than 'A'
993 1489 1083002B (fig-forth-auto680):00990 CMPD #$2B
994 148D 2A10 (fig-forth-auto680):00991 BPL DIGIT2 if greater than 'Z'
995 148F 830007 (fig-forth-auto680):00992 SUBD #7 translate 'A' thru 'F'
996 1492 10A3C4 (fig-forth-auto680):00993 DIGIT0 CMPD ,U ; Check the base.
997 1495 2A08 (fig-forth-auto680):00994 BPL DIGIT2 if not less than the base
998 1497 ED42 (fig-forth-auto680):00995 STD NATWID,U ; Store converted digit. (High byte known zero.)
999 1499 CC0001 (fig-forth-auto680):00996 LDD #1 ; set valid flag
1000 149C EDC4 (fig-forth-auto680):00997 DIGIT1 STD ,U ; store the flag
1001 149E 39 (fig-forth-auto680):00998 RTS NEXT
1002 149F CC0000 (fig-forth-auto680):00999 DIGIT2 LDD #0 ; set not valid flag
1003 14A2 3342 (fig-forth-auto680):01000 LEAU NATWID,U ; pop base
1004 14A4 20F6 (fig-forth-auto680):01001 BRA DIGIT1
1005 (fig-forth-auto680):01002 * TFR S,X ; TSX :
1006 (fig-forth-auto680):01003 * LDA 3,X
1007 (fig-forth-auto680):01004 * SUBA #$30 ascii zero
1008 (fig-forth-auto680):01005 * BMI DIGIT2 IF LESS THAN '0', ILLEGAL
1009 (fig-forth-auto680):01006 * CMPA #$A
1010 (fig-forth-auto680):01007 * BMI DIGIT0 IF '9' OR LESS
1011 (fig-forth-auto680):01008 * CMPA #$11
1012 (fig-forth-auto680):01009 * BMI DIGIT2 if less than 'A'
1013 (fig-forth-auto680):01010 * CMPA #$2B
1014 (fig-forth-auto680):01011 * BPL DIGIT2 if greater than 'Z'
1015 (fig-forth-auto680):01012 * SUBA #7 translate 'A' thru 'F'
1016 (fig-forth-auto680):01013 * DIGIT0 CMPA 1,X
1017 (fig-forth-auto680):01014 * BPL DIGIT2 if not less than the base
1018 (fig-forth-auto680):01015 * LDB #1 set flag
1019 (fig-forth-auto680):01016 * STA 3,X store digit
1020 (fig-forth-auto680):01017 * DIGIT1 STB 1,X store the flag
1021 (fig-forth-auto680):01018 * JMP NEXT
1022 (fig-forth-auto680):01019 * DIGIT2 CLRB ;
1023 (fig-forth-auto680):01020 * LEAS 1,S ;
1024 (fig-forth-auto680):01021 * LEAS 1,S ; pop bottom number
1025 (fig-forth-auto680):01022 * TFR S,X ; TSX :
1026 (fig-forth-auto680):01023 * STB 0,X make sure both bytes are 00
1027 (fig-forth-auto680):01024 * BRA DIGIT1
1028 (fig-forth-auto680):01025 *
1029 (fig-forth-auto680):01026 * ######>> screen 19 <<
1030 (fig-forth-auto680):01027 *
1031 (fig-forth-auto680):01028 * The word definition format in the dictionary:
1032 (fig-forth-auto680):01029 *
1033 (fig-forth-auto680):01030 * (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
1034 (fig-forth-auto680):01031 *
1035 (fig-forth-auto680):01032 * NFA (name field address):
1036 (fig-forth-auto680):01033 * char-count + $80 Length of symbol name, flagged with high bit set.
1037 (fig-forth-auto680):01034 * char 1 Characters of symbol name.
1038 (fig-forth-auto680):01035 * char 2
1039 (fig-forth-auto680):01036 * ...
1040 (fig-forth-auto680):01037 * char n + $80 symbol termination flag (char set < 128 code points)
1041 (fig-forth-auto680):01038 * LFA (link field address):
1042 (fig-forth-auto680):01039 * link high byte \___pointer to previous word in list
1043 (fig-forth-auto680):01040 * link low byte / -- Combined allocation/dictionary list. --
1044 (fig-forth-auto680):01041 * CFA (code field address):
1045 (fig-forth-auto680):01042 * CFA high byte \___pointer to native CPU machine code
1046 (fig-forth-auto680):01043 * CFA low byte / -- Consider this the characteristic code. --
1047 (fig-forth-auto680):01044 * PFA (parameter field address):
1048 (fig-forth-auto680):01045 * parameter fields -- Machine code for low-level native machine CPU code,
1049 (fig-forth-auto680):01046 * " instruction list for high-level Forth code,
1050 (fig-forth-auto680):01047 * " constant data for constants, pointers to per task variables,
1051 (fig-forth-auto680):01048 * " space for variables, for global variables, etc.
1052 (fig-forth-auto680):01049 *
1053 (fig-forth-auto680):01050 * In the case of native CPU machine code, the address at CFA will be PFA.
1054 (fig-forth-auto680):01051
1055 (fig-forth-auto680):01052 * Definition attributes:
1056 0040 (fig-forth-auto680):01053 FIMMED EQU $40 ; Immediate word flag.
1057 0020 (fig-forth-auto680):01054 FSMUDG EQU $20 ; Smudged => definition not ready.
1058 003F (fig-forth-auto680):01055 CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte.
1059 (fig-forth-auto680):01056 * Note that the SMUDGE bit is not masked out.
1060 (fig-forth-auto680):01057 *
1061 (fig-forth-auto680):01058 * But we really want more (Thinking for a new model, need one more byte):
1062 (fig-forth-auto680):01059 * FCOMPI EQU $10 ; Compile-time-only.
1063 (fig-forth-auto680):01060 * FASSEM EQU $08 ; Assembly-language code only.
1064 (fig-forth-auto680):01061 * F4THLV EQU $04 ; Must not be called from assembly language code.
1065 (fig-forth-auto680):01062 * These would require some significant adjustments to the model.
1066 (fig-forth-auto680):01063 * We also want to put the low-level VM stuff in its own vocabulary.
1067 (fig-forth-auto680):01064 *
1068 (fig-forth-auto680):01065 * ======>> 11 <<
1069 (fig-forth-auto680):01066 * (FIND) ( name vocptr --- locptr length true )
1070 (fig-forth-auto680):01067 * ( name vocptr --- false )
1071 (fig-forth-auto680):01068 * Search vocabulary for a symbol called name.
1072 (fig-forth-auto680):01069 * name is a pointer to a high-bit bracket string with length head.
1073 (fig-forth-auto680):01070 * vocptr is a pointer to the NFA of the tail-end (LATEST) definition
1074 (fig-forth-auto680):01071 * in the vocabulary to be searched.
1075 (fig-forth-auto680):01072 * Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
1076 14A6 86 (fig-forth-auto680):01073 FCB $86
1077 14A7 2846494E44 (fig-forth-auto680):01074 FCC '(FIND' ; '(FIND)'
1078 14AC A9 (fig-forth-auto680):01075 FCB $A9
1079 14AD 146C (fig-forth-auto680):01076 FDB DIGIT-8
1080 14AF 14B1 (fig-forth-auto680):01077 PFIND FDB *+NATWID
1081 14B1 3420 (fig-forth-auto680):01078 PSHS Y ; Have to track two pointers.
1082 (fig-forth-auto680):01079 * Use the stack and registers instead of temp area N.
1083 0002 (fig-forth-auto680):01080 PA0 EQU NATWID ; pointer to the length byte of name being searched against
1084 0000 (fig-forth-auto680):01081 PD EQU 0 ; pointer to NFA of dict word being checked
1085 (fig-forth-auto680):01082 *
1086 (fig-forth-auto680):01083 * INC <TRACEM
1087 (fig-forth-auto680):01084 * LBSR DBGREG
1088 14B3 AEC4 (fig-forth-auto680):01085 LDX PD,U ; Start in on the vocabulary (NFA).
1089 14B5 10AE42 (fig-forth-auto680):01086 PFNDLP LDY PA0,U ; Point to the name to check against.
1090 14B8 E680 (fig-forth-auto680):01087 LDB ,X+ ; get dict name length byte
1091 14BA 1F98 (fig-forth-auto680):01088 TFR B,A ; Save it in case it matches.
1092 14BC C43F (fig-forth-auto680):01089 ANDB #CTMASK
1093 (fig-forth-auto680):01090 * LBSR DBGREG
1094 14BE E1A0 (fig-forth-auto680):01091 CMPB ,Y+ ; Compare lengths
1095 (fig-forth-auto680):01092 * LBSR DBGREG
1096 14C0 261C (fig-forth-auto680):01093 BNE PFNDUN
1097 14C2 E680 (fig-forth-auto680):01094 PFNDBR LDB ,X+
1098 14C4 5D (fig-forth-auto680):01095 TSTB ; ; Is high bit of character in dictionary entry set?
1099 (fig-forth-auto680):01096 * LBSR DBGREG
1100 14C5 2A13 (fig-forth-auto680):01097 BPL PFNDCH
1101 (fig-forth-auto680):01098 * LBSR DBGREG
1102 14C7 C47F (fig-forth-auto680):01099 ANDB #$7F ; Clear high bit from dictionary.
1103 14C9 E1A0 (fig-forth-auto680):01100 CMPB ,Y+ ; Compare "last" characters.
1104 (fig-forth-auto680):01101 * LBSR DBGREG
1105 14CB 2717 (fig-forth-auto680):01102 BEQ FOUND ; Matches even if dictionary actual length is shorter.
1106 14CD AE81 (fig-forth-auto680):01103 PFNDLN LDX ,X++ ; Get previous link in vocabulary.
1107 (fig-forth-auto680):01104 * LBSR DBGREG
1108 14CF 26E4 (fig-forth-auto680):01105 BNE PFNDLP ; Continue if link not=0
1109 (fig-forth-auto680):01106 *
1110 (fig-forth-auto680):01107 * not found :
1111 14D1 3342 (fig-forth-auto680):01108 LEAU NATWID,U ; Return only false flag.
1112 14D3 CC0000 (fig-forth-auto680):01109 LDD #0
1113 14D6 EDC4 (fig-forth-auto680):01110 STD ,U
1114 (fig-forth-auto680):01111 * LBSR DBGREG
1115 (fig-forth-auto680):01112 * DEC <TRACEM
1116 14D8 35A0 (fig-forth-auto680):01113 PULS Y,PC
1117 (fig-forth-auto680):01114 *
1118 14DA E1A0 (fig-forth-auto680):01115 PFNDCH CMPB ,Y+ ; Compare characters.
1119 (fig-forth-auto680):01116 * LBSR DBGREG
1120 14DC 27E4 (fig-forth-auto680):01117 BEQ PFNDBR
1121 14DE (fig-forth-auto680):01118 PFNDUN
1122 14DE E680 (fig-forth-auto680):01119 PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
1123 (fig-forth-auto680):01120 * LBSR DBGREG
1124 14E0 2AFC (fig-forth-auto680):01121 BPL PFNDSC
1125 (fig-forth-auto680):01122 * LBSR DBGREG
1126 14E2 20E9 (fig-forth-auto680):01123 BRA PFNDLN
1127 (fig-forth-auto680):01124 *
1128 (fig-forth-auto680):01125 * found :
1129 (fig-forth-auto680):01126 *
1130 14E4 3004 (fig-forth-auto680):01127 FOUND LEAX 2*NATWID,X
1131 (fig-forth-auto680):01128 * LBSR DBGREG
1132 14E6 AF42 (fig-forth-auto680):01129 STX NATWID,U
1133 14E8 1F89 (fig-forth-auto680):01130 TFR A,B
1134 14EA 4F (fig-forth-auto680):01131 CLRA
1135 14EB EDC4 (fig-forth-auto680):01132 STD ,U
1136 (fig-forth-auto680):01133 * LBSR DBGREG
1137 14ED C601 (fig-forth-auto680):01134 LDB #1
1138 14EF 3606 (fig-forth-auto680):01135 PSHU A,B
1139 (fig-forth-auto680):01136 * LBSR DBGREG
1140 (fig-forth-auto680):01137 * DEC <TRACEM
1141 14F1 35A0 (fig-forth-auto680):01138 PULS Y,PC
1142 (fig-forth-auto680):01139 *
1143 (fig-forth-auto680):01140 * 6800 model:
1144 (fig-forth-auto680):01141 * NOP ; Probably leftovers from a debugging session.
1145 (fig-forth-auto680):01142 * NOP
1146 (fig-forth-auto680):01143 * PD EQU N ptr to dict word being checked
1147 (fig-forth-auto680):01144 * PA0 EQU N+2
1148 (fig-forth-auto680):01145 * PA EQU N+4
1149 (fig-forth-auto680):01146 * PC EQU N+6
1150 (fig-forth-auto680):01147 * LDX #PD
1151 (fig-forth-auto680):01148 * LDB #4
1152 (fig-forth-auto680):01149 * PFIND0 PULS A ; loop to get arguments
1153 (fig-forth-auto680):01150 * STA 0,X
1154 (fig-forth-auto680):01151 * LEAX 1,X ;
1155 (fig-forth-auto680):01152 * DECB ;
1156 (fig-forth-auto680):01153 * BNE PFIND0
1157 (fig-forth-auto680):01154 *
1158 (fig-forth-auto680):01155 * LDX PD
1159 (fig-forth-auto680):01156 * PFNDLP LDB 0,X get count dict count
1160 (fig-forth-auto680):01157 * STB PC
1161 (fig-forth-auto680):01158 * ANDB #$3F
1162 (fig-forth-auto680):01159 * LEAX 1,X ;
1163 (fig-forth-auto680):01160 * STX PD update PD
1164 (fig-forth-auto680):01161 * LDX PA0
1165 (fig-forth-auto680):01162 * LDA 0,X get count from arg
1166 (fig-forth-auto680):01163 * LEAX 1,X ;
1167 (fig-forth-auto680):01164 * STX PA intialize PA
1168 (fig-forth-auto680):01165 * PSHS B ; ** emulating CBA:
1169 (fig-forth-auto680):01166 * CMPA ,S+ ; compare lengths
1170 (fig-forth-auto680):01167 * BNE PFNDUN
1171 (fig-forth-auto680):01168 * PFNDBR LDX PA
1172 (fig-forth-auto680):01169 * LDA 0,X
1173 (fig-forth-auto680):01170 * LEAX 1,X ;
1174 (fig-forth-auto680):01171 * STX PA
1175 (fig-forth-auto680):01172 * LDX PD
1176 (fig-forth-auto680):01173 * LDB 0,X
1177 (fig-forth-auto680):01174 * LEAX 1,X ;
1178 (fig-forth-auto680):01175 * STX PD
1179 (fig-forth-auto680):01176 * TSTB ; is dict entry neg. ?
1180 (fig-forth-auto680):01177 * BPL PFNDCH
1181 (fig-forth-auto680):01178 * ANDB #$7F clear sign
1182 (fig-forth-auto680):01179 * PSHS B ; ** emulating CBA:
1183 (fig-forth-auto680):01180 * CMPA ,S+ ;
1184 (fig-forth-auto680):01181 * BEQ FOUND
1185 (fig-forth-auto680):01182 * PFNDLN LDX 0,X get new link
1186 (fig-forth-auto680):01183 * BNE PFNDLP continue if link not=0
1187 (fig-forth-auto680):01184 *
1188 (fig-forth-auto680):01185 * not found :
1189 (fig-forth-auto680):01186 *
1190 (fig-forth-auto680):01187 * CLRA ;
1191 (fig-forth-auto680):01188 * CLRB ;
1192 (fig-forth-auto680):01189 * JMP PUSHBA
1193 (fig-forth-auto680):01190 * PFNDCH PSHS B ; ** emulating CBA:
1194 (fig-forth-auto680):01191 * CMPA ,S+ ;
1195 (fig-forth-auto680):01192 * BEQ PFNDBR
1196 (fig-forth-auto680):01193 * PFNDUN LDX PD
1197 (fig-forth-auto680):01194 * PFNDSC LDB 0,X scan forward to end of this name
1198 (fig-forth-auto680):01195 * LEAX 1,X ;
1199 (fig-forth-auto680):01196 * BPL PFNDSC
1200 (fig-forth-auto680):01197 * BRA PFNDLN
1201 (fig-forth-auto680):01198 *
1202 (fig-forth-auto680):01199 * found :
1203 (fig-forth-auto680):01200 *
1204 (fig-forth-auto680):01201 * FOUND LDA PD compute CFA
1205 (fig-forth-auto680):01202 * LDB PD+1
1206 (fig-forth-auto680):01203 * ADDB #4
1207 (fig-forth-auto680):01204 * ADCA #0
1208 (fig-forth-auto680):01205 * PSHS B ;
1209 (fig-forth-auto680):01206 * PSHS A ;
1210 (fig-forth-auto680):01207 * LDA PC
1211 (fig-forth-auto680):01208 * PSHS A ;
1212 (fig-forth-auto680):01209 * CLRA ;
1213 (fig-forth-auto680):01210 * PSHS A ;
1214 (fig-forth-auto680):01211 * LDB #1
1215 (fig-forth-auto680):01212 * JMP PUSHBA
1216 (fig-forth-auto680):01213 *
1217 (fig-forth-auto680):01214 * PSHS A ; Left over from a stray copy-paste, I guess.
1218 (fig-forth-auto680):01215 * CLRA ;
1219 (fig-forth-auto680):01216 * PSHS A ;
1220 (fig-forth-auto680):01217 * LDB #1
1221 (fig-forth-auto680):01218 * JMP PUSHBA
1222 (fig-forth-auto680):01219 *
1223 (fig-forth-auto680):01220 * ######>> screen 20 <<
1224 (fig-forth-auto680):01221 * ======>> 12 <<
1225 (fig-forth-auto680):01222 * ( buffer ch --- buffer symboloffset delimiteroffset scancount )
1226 (fig-forth-auto680):01223 * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
1227 (fig-forth-auto680):01224 * ( buffer ch --- buffer nuloffset onepast scancount )
1228 (fig-forth-auto680):01225 * Scan buffer for a symbol delimited by ch or ASCII NUL,
1229 (fig-forth-auto680):01226 * return the length of the buffer region scanned,
1230 (fig-forth-auto680):01227 * the offset to the trailing delimiter,
1231 (fig-forth-auto680):01228 * and the offset of the first character of the symbol.
1232 (fig-forth-auto680):01229 * Leave the buffer on the stack.
1233 (fig-forth-auto680):01230 * Scancount is also offset to first character not yet looked at.
1234 (fig-forth-auto680):01231 * If no symbol in buffer, scancount and symboloffset point to NUL
1235 (fig-forth-auto680):01232 * and delimiteroffset points one beyond for some reason.
1236 (fig-forth-auto680):01233 * On trailing NUL, delimiteroffset == scancount.
1237 (fig-forth-auto680):01234 * (Buffer is the address of the buffer array to scan.)
1238 (fig-forth-auto680):01235 * (This is a bit too tricky, really.)
1239 14F3 87 (fig-forth-auto680):01236 FCB $87
1240 14F4 454E434C4F53 (fig-forth-auto680):01237 FCC 'ENCLOS' ; 'ENCLOSE'
1241 14FA C5 (fig-forth-auto680):01238 FCB $C5
1242 14FB 14A6 (fig-forth-auto680):01239 FDB PFIND-9
1243 14FD 14FF (fig-forth-auto680):01240 ENCLOS FDB *+NATWID
1244 14FF A641 (fig-forth-auto680):01241 LDA 1,U ; Delimiter character to match against in A.
1245 1501 AE42 (fig-forth-auto680):01242 LDX NATWID,U ; Buffer to scan in.
1246 1503 5F (fig-forth-auto680):01243 CLRB ; Initialize offset. (Buffer < 256 wide!)
1247 (fig-forth-auto680):01244 * Scan to a non-delimiter or a NUL
1248 1504 6D85 (fig-forth-auto680):01245 ENCDEL TST B,X ; NUL ?
1249 1506 271F (fig-forth-auto680):01246 BEQ ENCNUL
1250 1508 A185 (fig-forth-auto680):01247 CMPA B,X ; Delimiter?
1251 150A 2603 (fig-forth-auto680):01248 BNE ENC1ST
1252 150C 5C (fig-forth-auto680):01249 INCB ; count character
1253 150D 20F5 (fig-forth-auto680):01250 BRA ENCDEL
1254 (fig-forth-auto680):01251 * Found first character. Save the offset.
1255 150F E741 (fig-forth-auto680):01252 ENC1ST STB 1,U ; Found first non-delimiter character --
1256 1511 6FC4 (fig-forth-auto680):01253 CLR ,U ; store the count, zero high byte.
1257 (fig-forth-auto680):01254 * Scan to a delimiter or a NUL
1258 1513 6D85 (fig-forth-auto680):01255 ENCSYM TST B,X ; NUL ?
1259 1515 271E (fig-forth-auto680):01256 BEQ ENC0TR
1260 1517 A185 (fig-forth-auto680):01257 CMPA B,X ; delimiter?
1261 1519 2703 (fig-forth-auto680):01258 BEQ ENCEND
1262 151B 5C (fig-forth-auto680):01259 INCB
1263 151C 20F5 (fig-forth-auto680):01260 BRA ENCSYM
1264 (fig-forth-auto680):01261 * Found end of symbol. Push offset to delimiter found.
1265 151E 4F (fig-forth-auto680):01262 ENCEND CLRA ; high byte -- buffer < 255 wide!
1266 151F 3606 (fig-forth-auto680):01263 PSHU A,B ; Offset to seen delimiter.
1267 (fig-forth-auto680):01264 * Advance and push address of next character to check.
1268 1521 C30001 (fig-forth-auto680):01265 ADDD #1 ; In case offset was 255.
1269 1524 3606 (fig-forth-auto680):01266 PSHU A,B
1270 1526 39 (fig-forth-auto680):01267 RTS
1271 (fig-forth-auto680):01268 * Found NUL before non-delimiter, therefore there is no word
1272 1527 4F (fig-forth-auto680):01269 ENCNUL CLRA ; high byte -- buffer < 255 wide!
1273 1528 EDC4 (fig-forth-auto680):01270 STD ,U ; offset to NUL.
1274 152A C30001 (fig-forth-auto680):01271 ADDD #1 ; Point after NUL to allow (FIND) to match it.
1275 152D 3606 (fig-forth-auto680):01272 PSHU A,B ;
1276 152F 830001 (fig-forth-auto680):01273 SUBD #1 ; Next is not passed NUL.
1277 1532 3606 (fig-forth-auto680):01274 PSHU A,B ; Stealing code will save only one byte.
1278 1534 39 (fig-forth-auto680):01275 RTS
1279 (fig-forth-auto680):01276 * Found NUL following the word instead of delimiter.
1280 1535 (fig-forth-auto680):01277 ENC0TR
1281 (fig-forth-auto680):01278 * INC <TRACEM
1282 (fig-forth-auto680):01279 * LBSR DBGREG
1283 1535 4F (fig-forth-auto680):01280 CLRA
1284 1536 3606 (fig-forth-auto680):01281 PSHU A,B ; Save offset to first after symbol (NUL)
1285 (fig-forth-auto680):01282 * LBSR DBGREG
1286 1538 3606 (fig-forth-auto680):01283 PSHU A,B ; and count scanned.
1287 (fig-forth-auto680):01284 * LBSR DBGREG
1288 (fig-forth-auto680):01285 * DEC <TRACEM
1289 153A 39 (fig-forth-auto680):01286 RTS
1290 (fig-forth-auto680):01287 * NOTE :
1291 (fig-forth-auto680):01288 * FC means offset (bytes) to First Character of next word
1292 (fig-forth-auto680):01289 * EW " " to End of Word
1293 (fig-forth-auto680):01290 * NC " " to Next Character to start next enclose at
1294 (fig-forth-auto680):01291 * ENCLOS FDB *+NATWID
1295 (fig-forth-auto680):01292 * LEAS 1,S ;
1296 (fig-forth-auto680):01293 * PULS B ; now, get the low byte, for an 8-bit delimiter
1297 (fig-forth-auto680):01294 * TFR S,X ; TSX :
1298 (fig-forth-auto680):01295 * LDX 0,X
1299 (fig-forth-auto680):01296 * CLR N
1300 (fig-forth-auto680):01297 * * wait for a non-delimiter or a NUL
1301 (fig-forth-auto680):01298 * ENCDEL LDA 0,X
1302 (fig-forth-auto680):01299 * BEQ ENCNUL
1303 (fig-forth-auto680):01300 * PSHS B ; ** emulating CBA:
1304 (fig-forth-auto680):01301 * CMPA ,S+ ; CHECK FOR DELIM
1305 (fig-forth-auto680):01302 * BNE ENC1ST
1306 (fig-forth-auto680):01303 * LEAX 1,X ;
1307 (fig-forth-auto680):01304 * INC N
1308 (fig-forth-auto680):01305 * BRA ENCDEL
1309 (fig-forth-auto680):01306 * * found first character. Push FC
1310 (fig-forth-auto680):01307 * ENC1ST LDA N found first char.
1311 (fig-forth-auto680):01308 * PSHS A ;
1312 (fig-forth-auto680):01309 * CLRA ;
1313 (fig-forth-auto680):01310 * PSHS A ;
1314 (fig-forth-auto680):01311 * wait for a delimiter or a NUL
1315 (fig-forth-auto680):01312 * ENCSYM LDA 0,X
1316 (fig-forth-auto680):01313 * BEQ ENC0TR
1317 (fig-forth-auto680):01314 * PSHS B ; ** emulating CBA:
1318 (fig-forth-auto680):01315 * CMPA ,S+ ; ckech for delim.
1319 (fig-forth-auto680):01316 * BEQ ENCEND
1320 (fig-forth-auto680):01317 * LEAX 1,X ;
1321 (fig-forth-auto680):01318 * INC N
1322 (fig-forth-auto680):01319 * BRA ENCSYM
1323 (fig-forth-auto680):01320 * * found EW. Push it
1324 (fig-forth-auto680):01321 * ENCEND LDB N
1325 (fig-forth-auto680):01322 * CLRA ;
1326 (fig-forth-auto680):01323 * PSHS B ;
1327 (fig-forth-auto680):01324 * PSHS A ;
1328 (fig-forth-auto680):01325 * * advance and push NC
1329 (fig-forth-auto680):01326 * INCB ;
1330 (fig-forth-auto680):01327 * JMP PUSHBA
1331 (fig-forth-auto680):01328 * found NUL before non-delimiter, therefore there is no word
1332 (fig-forth-auto680):01329 * ENCNUL LDB N found NUL
1333 (fig-forth-auto680):01330 * PSHS B ;
1334 (fig-forth-auto680):01331 * PSHS A ;
1335 (fig-forth-auto680):01332 * INCB ;
1336 (fig-forth-auto680):01333 * BRA ENC0TR+2 ; ********** POTENTIAL BUG HERE *******
1337 (fig-forth-auto680):01334 * ******** Should use labels in case opcodes change! ********
1338 (fig-forth-auto680):01335 * found NUL following the word instead of SPACE
1339 (fig-forth-auto680):01336 * ENC0TR LDB N
1340 (fig-forth-auto680):01337 * PSHS B ; save EW
1341 (fig-forth-auto680):01338 * PSHS A ;
1342 (fig-forth-auto680):01339 * ENCL8 LDB N save NC
1343 (fig-forth-auto680):01340 * JMP PUSHBA
1344 (fig-forth-auto680):01341
1345 (fig-forth-auto680):01342 PAGE
1346 (fig-forth-auto680):01343 *
1347 (fig-forth-auto680):01344 * ######>> screen 21 <<
1348 (fig-forth-auto680):01345 * The next 4 words call system dependant I/O routines
1349 (fig-forth-auto680):01346 * which are listed after word "-->" ( lable: "arrow" )
1350 (fig-forth-auto680):01347 * in the dictionary.
1351 (fig-forth-auto680):01348 *
1352 (fig-forth-auto680):01349 * ======>> 13 <<
1353 (fig-forth-auto680):01350 * ( c --- )
1354 (fig-forth-auto680):01351 * Write c to the output device (screen or printer).
1355 (fig-forth-auto680):01352 * ROM Uses the ECB device number at address $6F,
1356 (fig-forth-auto680):01353 * -2 is printer, 0 is screen.
1357 153B 84 (fig-forth-auto680):01354 FCB $84
1358 153C 454D49 (fig-forth-auto680):01355 FCC 'EMI' ; 'EMIT'
1359 153F D4 (fig-forth-auto680):01356 FCB $D4
1360 1540 14F3 (fig-forth-auto680):01357 FDB ENCLOS-10
1361 1542 1544 (fig-forth-auto680):01358 EMIT FDB *+NATWID
1362 1544 3706 (fig-forth-auto680):01359 PULU D
1363 1546 171067 (fig-forth-auto680):01360 LBSR PEMIT ; PEMIT expects the character in D.
1364 1549 0C33 (fig-forth-auto680):01361 INC <XOUT+1
1365 154B 2602 (fig-forth-auto680):01362 BNE EMITDN
1366 154D 0C32 (fig-forth-auto680):01363 INC <XOUT
1367 154F 39 (fig-forth-auto680):01364 EMITDN RTS
1368 (fig-forth-auto680):01365 * PULS A ;
1369 (fig-forth-auto680):01366 * PULS A ;
1370 (fig-forth-auto680):01367 * JSR PEMIT
1371 (fig-forth-auto680):01368 * LDX UP
1372 (fig-forth-auto680):01369 * INC XOUT+1-UORIG,X
1373 (fig-forth-auto680):01370 * BNE *+4 ;
1374 (fig-forth-auto680):01371 * ****WARNING**** HARD OFFSET: *+4 ****
1375 (fig-forth-auto680):01372 * INC XOUT-UORIG,X
1376 (fig-forth-auto680):01373 * JMP NEXT
1377 (fig-forth-auto680):01374 *
1378 (fig-forth-auto680):01375 * ======>> 14 <<
1379 (fig-forth-auto680):01376 * ( --- c )
1380 (fig-forth-auto680):01377 * ( --- BREAK )
1381 (fig-forth-auto680):01378 * Wait for a key from the keyboard.
1382 (fig-forth-auto680):01379 * If the key is BREAK, set the high byte (result $FF03).
1383 1550 83 (fig-forth-auto680):01380 FCB $83
1384 1551 4B45 (fig-forth-auto680):01381 FCC 'KE' ; 'KEY'
1385 1553 D9 (fig-forth-auto680):01382 FCB $D9
1386 1554 153B (fig-forth-auto680):01383 FDB EMIT-7
1387 1556 1558 (fig-forth-auto680):01384 KEY FDB *+NATWID
1388 1558 171062 (fig-forth-auto680):01385 LBSR PKEY ; PKEY leaves the key/break code in D.
1389 155B 3606 (fig-forth-auto680):01386 PSHU D
1390 155D 39 (fig-forth-auto680):01387 RTS
1391 (fig-forth-auto680):01388 * JSR PKEY
1392 (fig-forth-auto680):01389 * PSHS A ;
1393 (fig-forth-auto680):01390 * CLRA ;
1394 (fig-forth-auto680):01391 * PSHS A ;
1395 (fig-forth-auto680):01392 * JMP NEXT
1396 (fig-forth-auto680):01393 *
1397 (fig-forth-auto680):01394 * ======>> 15 <<
1398 (fig-forth-auto680):01395 * ( --- f )
1399 (fig-forth-auto680):01396 * Scan keyboard, but do not wait.
1400 (fig-forth-auto680):01397 * Return 0 if no key,
1401 (fig-forth-auto680):01398 * BREAK ($ff03) if BREAK is pressed,
1402 (fig-forth-auto680):01399 * or key currently pressed.
1403 155E 89 (fig-forth-auto680):01400 FCB $89
1404 155F 3F5445524D494E41 (fig-forth-auto680):01401 FCC '?TERMINA' ; '?TERMINAL'
1405 1567 CC (fig-forth-auto680):01402 FCB $CC
1406 1568 1550 (fig-forth-auto680):01403 FDB KEY-6
1407 156A 156C (fig-forth-auto680):01404 QTERM FDB *+NATWID
1408 156C 171073 (fig-forth-auto680):01405 LBSR PQTER ; PQTER leaves the flag/key in D.
1409 156F 3606 (fig-forth-auto680):01406 PSHU D
1410 1571 39 (fig-forth-auto680):01407 RTS
1411 (fig-forth-auto680):01408 * JSR PQTER
1412 (fig-forth-auto680):01409 * CLRB ;
1413 (fig-forth-auto680):01410 * JMP PUSHBA stack the flag
1414 (fig-forth-auto680):01411 *
1415 (fig-forth-auto680):01412 * ======>> 16 <<
1416 (fig-forth-auto680):01413 * ( --- )
1417 (fig-forth-auto680):01414 * EMIT a Carriage Return (ASCII CR).
1418 1572 82 (fig-forth-auto680):01415 FCB $82
1419 1573 43 (fig-forth-auto680):01416 FCC 'C' ; 'CR'
1420 1574 D2 (fig-forth-auto680):01417 FCB $D2
1421 1575 155E (fig-forth-auto680):01418 FDB QTERM-12
1422 1577 1579 (fig-forth-auto680):01419 CR FDB *+NATWID
1423 1579 161071 (fig-forth-auto680):01420 LBRA PCR ; Nothing really to do here.
1424 (fig-forth-auto680):01421 * JSR PCR
1425 (fig-forth-auto680):01422 * JMP NEXT
1426 (fig-forth-auto680):01423 *
1427 (fig-forth-auto680):01424 * ######>> screen 22 <<
1428 (fig-forth-auto680):01425 * ======>> 17 <<
1429 (fig-forth-auto680):01426 * ( source target count --- )
1430 (fig-forth-auto680):01427 * Copy/move count bytes from source to target.
1431 (fig-forth-auto680):01428 * Moves ascending addresses,
1432 (fig-forth-auto680):01429 * so that overlapping only works if the source is above the destination.
1433 157C 85 (fig-forth-auto680):01430 FCB $85
1434 157D 434D4F56 (fig-forth-auto680):01431 FCC 'CMOV' ; 'CMOVE' : source, destination, count
1435 1581 C5 (fig-forth-auto680):01432 FCB $C5
1436 1582 1572 (fig-forth-auto680):01433 FDB CR-5
1437 1584 1586 (fig-forth-auto680):01434 CMOVE FDB *+NATWID
1438 1586 3420 (fig-forth-auto680):01435 PSHS Y ;
1439 (fig-forth-auto680):01436 * INC <TRACEM
1440 (fig-forth-auto680):01437 * LBSR DBGREG
1441 1588 AE42 (fig-forth-auto680):01438 LDX 1*NATWID,U
1442 158A 10AE44 (fig-forth-auto680):01439 LDY 2*NATWID,U
1443 158D 2004 (fig-forth-auto680):01440 BRA CMOVLE ;
1444 158F (fig-forth-auto680):01441 CMOVLP
1445 (fig-forth-auto680):01442 * LBSR DBGREG
1446 158F A6A0 (fig-forth-auto680):01443 LDA ,Y+
1447 1591 A780 (fig-forth-auto680):01444 STA ,X+
1448 (fig-forth-auto680):01445 * LBSR DBGREG
1449 1593 (fig-forth-auto680):01446 CMOVLE
1450 1593 ECC4 (fig-forth-auto680):01447 LDD ,U
1451 1595 830001 (fig-forth-auto680):01448 SUBD #1
1452 1598 EDC4 (fig-forth-auto680):01449 STD ,U
1453 159A 24F3 (fig-forth-auto680):01450 BCC CMOVLP
1454 159C 3346 (fig-forth-auto680):01451 LEAU 3*NATWID,U
1455 (fig-forth-auto680):01452 * DEC <TRACEM
1456 159E 35A0 (fig-forth-auto680):01453 PULS Y,PC
1457 (fig-forth-auto680):01454 * One way: ; takes ( 37+17*count+9*(count/256) cycles )
1458 (fig-forth-auto680):01455 * PSHS Y ; #2~7 ; Gotta have our pointers.
1459 (fig-forth-auto680):01456 * INC <TRACEM
1460 (fig-forth-auto680):01457 * LBSR DBGREG
1461 (fig-forth-auto680):01458 * PULU D,X,Y ; #2~11
1462 (fig-forth-auto680):01459 * PSHS A ; #2~6 ; Gotta have our pointers.
1463 (fig-forth-auto680):01460 * BRA CMOVLE ; #2~3
1464 (fig-forth-auto680):01461 * CMOVLP
1465 (fig-forth-auto680):01462 * LBSR DBGREG
1466 (fig-forth-auto680):01463 * LDA ,Y+ ; #2~6
1467 (fig-forth-auto680):01464 * STA ,X+ ; #2~6
1468 (fig-forth-auto680):01465 * LBSR DBGREG
1469 (fig-forth-auto680):01466 * CMOVLE
1470 (fig-forth-auto680):01467 * SUBB #1 ; #2~2
1471 (fig-forth-auto680):01468 * BCC CMOVLP ; #2~3
1472 (fig-forth-auto680):01469 * DEC ,S ; #2=6
1473 (fig-forth-auto680):01470 * BPL CMOVLP ; #2~3
1474 (fig-forth-auto680):01471 * DEC <TRACEM
1475 (fig-forth-auto680):01472 * PULS A,Y,PC ; #2~10
1476 (fig-forth-auto680):01473 * Another way ; takes ( 42+17*count+9*(count/256) cycles )
1477 (fig-forth-auto680):01474 * LDD #0 ; #3~3
1478 (fig-forth-auto680):01475 * SUBD ,U++ ; #2~9 ; invert the count
1479 (fig-forth-auto680):01476 * PSHS A,Y ; #2~8
1480 (fig-forth-auto680):01477 * PULU X,Y ; #2~9
1481 (fig-forth-auto680):01478 * BEQ CMOVEX ; #2~3
1482 (fig-forth-auto680):01479 * CMOVEL
1483 (fig-forth-auto680):01480 * LDA ,Y+ ; #2~6
1484 (fig-forth-auto680):01481 * STA ,X+ ; #2~6
1485 (fig-forth-auto680):01482 * INCB ; #1~2
1486 (fig-forth-auto680):01483 * BNE CMOVEL ; #2~3
1487 (fig-forth-auto680):01484 * INC ,S ; #2~6
1488 (fig-forth-auto680):01485 * BNE CMOVEL ; #2~3
1489 (fig-forth-auto680):01486 * CMOVEX
1490 (fig-forth-auto680):01487 * PULS A,Y,PC ; #2~10
1491 (fig-forth-auto680):01488 * Yet another way ; takes ( 37+29*count cycles )
1492 (fig-forth-auto680):01489 * PSHS Y ; #2~7
1493 (fig-forth-auto680):01490 * LDX NATWID,U ; #2~6
1494 (fig-forth-auto680):01491 * LDY NATWID,U ; #3~7
1495 (fig-forth-auto680):01492 * BRA CMOVLE ; #2~3
1496 (fig-forth-auto680):01493 * CMOVLP
1497 (fig-forth-auto680):01494 * LDA ,Y+ ; #2~6
1498 (fig-forth-auto680):01495 * STA ,X+ ; #2~6
1499 (fig-forth-auto680):01496 * CMOVLE
1500 (fig-forth-auto680):01497 * LDD ,U ; #2~5
1501 (fig-forth-auto680):01498 * SUBD #1 ; #3~4
1502 (fig-forth-auto680):01499 * STD ,U ; #2~5
1503 (fig-forth-auto680):01500 * BPL CMOVLP ; #2~3
1504 (fig-forth-auto680):01501 * LEAU 3*NATWID,U ; #2~5
1505 (fig-forth-auto680):01502 * PULS Y,PC ; #2~9
1506 (fig-forth-auto680):01503 * Yet another way ; takes ( 44+24*odd+33*count/2 cycles )
1507 (fig-forth-auto680):01504 * PSHS Y ; #2~7
1508 (fig-forth-auto680):01505 * LDX NATWID,U ; #2~6
1509 (fig-forth-auto680):01506 * LDY 2*NATWID,U ; #3~7
1510 (fig-forth-auto680):01507 * LDD ,U ; #2~5
1511 (fig-forth-auto680):01508 * BITB #1 ; #2~2
1512 (fig-forth-auto680):01509 * BEQ CMOVLE ; #2~3
1513 (fig-forth-auto680):01510 * SUBD #1 ; #3~4
1514 (fig-forth-auto680):01511 * STD ,U ; #2~5
1515 (fig-forth-auto680):01512 * LDA ,Y+ ; #2~6
1516 (fig-forth-auto680):01513 * STA ,X+ ; #2~6
1517 (fig-forth-auto680):01514 * BRA CMOVLE ; #2~3
1518 (fig-forth-auto680):01515 * CMOVLP
1519 (fig-forth-auto680):01516 * LDD ,Y++ ; #2~8
1520 (fig-forth-auto680):01517 * STD ,X++ ; #2~8
1521 (fig-forth-auto680):01518 * CMOVLI
1522 (fig-forth-auto680):01519 * LDD ,U ; #2~5
1523 (fig-forth-auto680):01520 * CMOVLE
1524 (fig-forth-auto680):01521 * SUBD #2 ; #3~4
1525 (fig-forth-auto680):01522 * STD ,U ; #2~5
1526 (fig-forth-auto680):01523 * BPL CMOVLP ; #2~3
1527 (fig-forth-auto680):01524 * LEAU 3*NATWID,U ; #2~5
1528 (fig-forth-auto680):01525 * PULS Y,PC ; #2~9
1529 (fig-forth-auto680):01526 * From the 6800 model:
1530 (fig-forth-auto680):01527 * CMOVE FDB *+2 takes ( 43+47*count cycles ) on 6800
1531 (fig-forth-auto680):01528 * LDX #N
1532 (fig-forth-auto680):01529 * LDB #6
1533 (fig-forth-auto680):01530 * CMOV1 PULS A ;
1534 (fig-forth-auto680):01531 * STA 0,X move parameters to scratch area
1535 (fig-forth-auto680):01532 * LEAX 1,X ;
1536 (fig-forth-auto680):01533 * DECB ;
1537 (fig-forth-auto680):01534 * BNE CMOV1
1538 (fig-forth-auto680):01535 * CMOV2 LDA N
1539 (fig-forth-auto680):01536 * LDB N+1
1540 (fig-forth-auto680):01537 * SUBB #1
1541 (fig-forth-auto680):01538 * SBCA #0
1542 (fig-forth-auto680):01539 * STA N
1543 (fig-forth-auto680):01540 * STB N+1
1544 (fig-forth-auto680):01541 * BCS CMOV3
1545 (fig-forth-auto680):01542 * LDX N+4
1546 (fig-forth-auto680):01543 * LDA 0,X
1547 (fig-forth-auto680):01544 * LEAX 1,X ;
1548 (fig-forth-auto680):01545 * STX N+4
1549 (fig-forth-auto680):01546 * LDX N+2
1550 (fig-forth-auto680):01547 * STA 0,X
1551 (fig-forth-auto680):01548 * LEAX 1,X ;
1552 (fig-forth-auto680):01549 * STX N+2
1553 (fig-forth-auto680):01550 * BRA CMOV2
1554 (fig-forth-auto680):01551 * CMOV3 JMP NEXT
1555 (fig-forth-auto680):01552 *
1556 (fig-forth-auto680):01553 * ######>> screen 23 <<
1557 (fig-forth-auto680):01554 * ======>> 18 <<
1558 (fig-forth-auto680):01555 * ( u1 u2 --- ud )
1559 (fig-forth-auto680):01556 * Multiplies the top two unsigned integers,
1560 (fig-forth-auto680):01557 * yielding a double integer product.
1561 15A0 82 (fig-forth-auto680):01558 FCB $82
1562 15A1 55 (fig-forth-auto680):01559 FCC 'U' ; 'U*'
1563 15A2 AA (fig-forth-auto680):01560 FCB $AA
1564 15A3 157C (fig-forth-auto680):01561 FDB CMOVE-8
1565 15A5 15A7 (fig-forth-auto680):01562 USTAR FDB *+NATWID
1566 15A7 335C (fig-forth-auto680):01563 LEAU -2*NATWID,U
1567 15A9 A645 (fig-forth-auto680):01564 LDA 2*NATWID+1,U ; least
1568 15AB E647 (fig-forth-auto680):01565 LDB 3*NATWID+1,U
1569 15AD 3D (fig-forth-auto680):01566 MUL
1570 15AE ED42 (fig-forth-auto680):01567 STD NATWID,U
1571 15B0 A644 (fig-forth-auto680):01568 LDA 2*NATWID,U ; most
1572 15B2 E646 (fig-forth-auto680):01569 LDB 3*NATWID,U
1573 15B4 3D (fig-forth-auto680):01570 MUL
1574 15B5 EDC4 (fig-forth-auto680):01571 STD ,U
1575 15B7 EC45 (fig-forth-auto680):01572 LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
1576 15B9 3D (fig-forth-auto680):01573 MUL
1577 15BA E341 (fig-forth-auto680):01574 ADDD 1,U
1578 15BC 2402 (fig-forth-auto680):01575 BCC USTAR3
1579 15BE 6CC4 (fig-forth-auto680):01576 INC ,U
1580 15C0 ED41 (fig-forth-auto680):01577 USTAR3 STD 1,U
1581 15C2 A644 (fig-forth-auto680):01578 LDA 2*NATWID,U ; second inner (u2 hi)
1582 15C4 E646 (fig-forth-auto680):01579 LDB 3*NATWID,U ; (u1 lo)
1583 15C6 3D (fig-forth-auto680):01580 MUL
1584 15C7 E341 (fig-forth-auto680):01581 ADDD 1,U
1585 15C9 2402 (fig-forth-auto680):01582 BCC USTAR4
1586 15CB 6CC4 (fig-forth-auto680):01583 INC ,U
1587 15CD ED41 (fig-forth-auto680):01584 USTAR4 STD 1,U
1588 15CF 3716 (fig-forth-auto680):01585 PULU D,X
1589 15D1 EDC4 (fig-forth-auto680):01586 STD ,U
1590 15D3 AF42 (fig-forth-auto680):01587 STX NATWID,U
1591 15D5 39 (fig-forth-auto680):01588 RTS
1592 (fig-forth-auto680):01589 *
1593 (fig-forth-auto680):01590 * from 6800 model:
1594 (fig-forth-auto680):01591 * BSR USTARS
1595 (fig-forth-auto680):01592 * LEAS 1,S ;
1596 (fig-forth-auto680):01593 * LEAS 1,S ;
1597 (fig-forth-auto680):01594 * JMP PUSHBA
1598 (fig-forth-auto680):01595 *
1599 (fig-forth-auto680):01596 * The following is a subroutine which
1600 (fig-forth-auto680):01597 * multiplies top 2 words on stack,
1601 (fig-forth-auto680):01598 * leaving 32-bit result: high order word in A,B
1602 (fig-forth-auto680):01599 * low order word in 2nd word of stack.
1603 (fig-forth-auto680):01600 *
1604 (fig-forth-auto680):01601 * USTARS LDA #16 bits/word counter
1605 (fig-forth-auto680):01602 * PSHS A ;
1606 (fig-forth-auto680):01603 * CLRA ;
1607 (fig-forth-auto680):01604 * CLRB ;
1608 (fig-forth-auto680):01605 * TFR S,X ; TSX :
1609 (fig-forth-auto680):01606 * USTAR2 ROR 5,X shift multiplier
1610 (fig-forth-auto680):01607 * ROR 6,X
1611 (fig-forth-auto680):01608 * DEC 0,X done?
1612 (fig-forth-auto680):01609 * BMI USTAR4
1613 (fig-forth-auto680):01610 * BCC USTAR3
1614 (fig-forth-auto680):01611 * ADDB 4,X
1615 (fig-forth-auto680):01612 * ADCA 3,X
1616 (fig-forth-auto680):01613 * USTAR3 RORA ;
1617 (fig-forth-auto680):01614 * RORB ; shift result
1618 (fig-forth-auto680):01615 * BRA USTAR2
1619 (fig-forth-auto680):01616 * USTAR4 LEAS 1,S ; dump counter
1620 (fig-forth-auto680):01617 * RTS
1621 (fig-forth-auto680):01618 *
1622 (fig-forth-auto680):01619 * ######>> screen 24 <<
1623 (fig-forth-auto680):01620 * ======>> 19 <<
1624 (fig-forth-auto680):01621 * ( ud u --- uremainder uquotient )
1625 (fig-forth-auto680):01622 * Divides the top unsigned integer
1626 (fig-forth-auto680):01623 * into the second and third words on the stack
1627 (fig-forth-auto680):01624 * as a single unsigned double integer,
1628 (fig-forth-auto680):01625 * leaving the remainder and quotient (quotient on top)
1629 (fig-forth-auto680):01626 * as unsigned integers.
1630 (fig-forth-auto680):01627 *
1631 (fig-forth-auto680):01628 * The smaller the divisor, the more likely dropping the high word
1632 (fig-forth-auto680):01629 * of the quotient loses significant bits. See M/MOD .
1633 (fig-forth-auto680):01630 *
1634 15D6 82 (fig-forth-auto680):01631 FCB $82
1635 15D7 55 (fig-forth-auto680):01632 FCC 'U' ; 'U/'
1636 15D8 AF (fig-forth-auto680):01633 FCB $AF
1637 15D9 15A0 (fig-forth-auto680):01634 FDB USTAR-5
1638 15DB 15DD (fig-forth-auto680):01635 USLASH FDB *+NATWID
1639 15DD 8611 (fig-forth-auto680):01636 LDA #17 ; bit ct
1640 15DF 3402 (fig-forth-auto680):01637 PSHS A
1641 15E1 EC42 (fig-forth-auto680):01638 LDD NATWID,U ; dividend
1642 15E3 10A3C4 (fig-forth-auto680):01639 USLDIV CMPD ,U ; divisor
1643 15E6 2404 (fig-forth-auto680):01640 BHS USLSUB
1644 15E8 1CFE (fig-forth-auto680):01641 ANDCC #~1 ; carry clear
1645 15EA 2004 (fig-forth-auto680):01642 BRA USLBIT
1646 15EC A3C4 (fig-forth-auto680):01643 USLSUB SUBD ,U
1647 15EE 1A01 (fig-forth-auto680):01644 ORCC #1 ; quotient, (carry set)
1648 15F0 6945 (fig-forth-auto680):01645 USLBIT ROL 2*NATWID+1,U ; save it
1649 15F2 6944 (fig-forth-auto680):01646 ROL 2*NATWID,U
1650 15F4 6AE4 (fig-forth-auto680):01647 DEC ,S ; more bits?
1651 15F6 2706 (fig-forth-auto680):01648 BEQ USLR
1652 15F8 59 (fig-forth-auto680):01649 ROLB ; remainder
1653 15F9 49 (fig-forth-auto680):01650 ROLA
1654 15FA 24E7 (fig-forth-auto680):01651 BCC USLDIV
1655 15FC 20EE (fig-forth-auto680):01652 BRA USLSUB
1656 15FE 3342 (fig-forth-auto680):01653 USLR LEAU NATWID,U
1657 1600 AE42 (fig-forth-auto680):01654 LDX NATWID,U
1658 1602 ED42 (fig-forth-auto680):01655 STD NATWID,U
1659 1604 AFC4 (fig-forth-auto680):01656 STX ,U
1660 1606 3582 (fig-forth-auto680):01657 PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
1661 (fig-forth-auto680):01658 *
1662 (fig-forth-auto680):01659 * from 6800 model:
1663 (fig-forth-auto680):01660 * LDA #17
1664 (fig-forth-auto680):01661 * PSHS A ;
1665 (fig-forth-auto680):01662 * TFR S,X ; TSX :
1666 (fig-forth-auto680):01663 * LDA 3,X
1667 (fig-forth-auto680):01664 * LDB 4,X
1668 (fig-forth-auto680):01665 * USL1 CMPA 1,X
1669 (fig-forth-auto680):01666 * BHI USL3
1670 (fig-forth-auto680):01667 * BCS USL2
1671 (fig-forth-auto680):01668 * CMPB 2,X
1672 (fig-forth-auto680):01669 * BCC USL3
1673 (fig-forth-auto680):01670 * USL2 ANDCC #~$01 ; CLC :
1674 (fig-forth-auto680):01671 * BRA USL4
1675 (fig-forth-auto680):01672 * USL3 SUBB 2,X
1676 (fig-forth-auto680):01673 * SBCA 1,X
1677 (fig-forth-auto680):01674 * ORCC #$01 ; SEC :
1678 (fig-forth-auto680):01675 * USL4 ROL 6,X
1679 (fig-forth-auto680):01676 * ROL 5,X
1680 (fig-forth-auto680):01677 * DEC 0,X
1681 (fig-forth-auto680):01678 * BEQ USL5
1682 (fig-forth-auto680):01679 * ROLB ;
1683 (fig-forth-auto680):01680 * ROLA ;
1684 (fig-forth-auto680):01681 * BCC USL1
1685 (fig-forth-auto680):01682 * BRA USL3
1686 (fig-forth-auto680):01683 * USL5 LEAS 1,S ;
1687 (fig-forth-auto680):01684 * LEAS 1,S ;
1688 (fig-forth-auto680):01685 * LEAS 1,S ;
1689 (fig-forth-auto680):01686 * LEAS 1,S ;
1690 (fig-forth-auto680):01687 * LEAS 1,S ;
1691 (fig-forth-auto680):01688 * JMP SWAP+4 reverse quotient & remainder
1692 (fig-forth-auto680):01689 *
1693 (fig-forth-auto680):01690 * ######>> screen 25 <<
1694 (fig-forth-auto680):01691 * ======>> 20 <<
1695 (fig-forth-auto680):01692 * ( n1 n2 --- n )
1696 (fig-forth-auto680):01693 * Bitwise and the top two integers.
1697 1608 83 (fig-forth-auto680):01694 FCB $83
1698 1609 414E (fig-forth-auto680):01695 FCC 'AN' ; 'AND'
1699 160B C4 (fig-forth-auto680):01696 FCB $C4
1700 160C 15D6 (fig-forth-auto680):01697 FDB USLASH-5
1701 160E 1610 (fig-forth-auto680):01698 AND FDB *+NATWID
1702 1610 3706 (fig-forth-auto680):01699 PULU A,B
1703 1612 E441 (fig-forth-auto680):01700 ANDB 1,U
1704 1614 A4C4 (fig-forth-auto680):01701 ANDA ,U
1705 1616 EDC4 (fig-forth-auto680):01702 STD ,U
1706 1618 39 (fig-forth-auto680):01703 RTS
1707 (fig-forth-auto680):01704 * PULS A ;
1708 (fig-forth-auto680):01705 * PULS B ;
1709 (fig-forth-auto680):01706 * TFR S,X ; TSX :
1710 (fig-forth-auto680):01707 * ANDB 1,X
1711 (fig-forth-auto680):01708 * ANDA 0,X
1712 (fig-forth-auto680):01709 * JMP STABX
1713 (fig-forth-auto680):01710 *
1714 (fig-forth-auto680):01711 * ======>> 21 <<
1715 (fig-forth-auto680):01712 * ( n1 n2 --- n )
1716 (fig-forth-auto680):01713 * Bitwise or the top two integers.
1717 1619 82 (fig-forth-auto680):01714 FCB $82
1718 161A 4F (fig-forth-auto680):01715 FCC 'O' ; 'OR'
1719 161B D2 (fig-forth-auto680):01716 FCB $D2
1720 161C 1608 (fig-forth-auto680):01717 FDB AND-6
1721 161E 1620 (fig-forth-auto680):01718 OR FDB *+NATWID
1722 1620 3706 (fig-forth-auto680):01719 PULU A,B
1723 1622 EA41 (fig-forth-auto680):01720 ORB 1,U
1724 1624 AAC4 (fig-forth-auto680):01721 ORA ,U
1725 1626 EDC4 (fig-forth-auto680):01722 STD ,U
1726 1628 39 (fig-forth-auto680):01723 RTS
1727 (fig-forth-auto680):01724 * PULS A ;
1728 (fig-forth-auto680):01725 * PULS B ;
1729 (fig-forth-auto680):01726 * TFR S,X ; TSX :
1730 (fig-forth-auto680):01727 * ORB 1,X
1731 (fig-forth-auto680):01728 * ORA 0,X
1732 (fig-forth-auto680):01729 * JMP STABX
1733 (fig-forth-auto680):01730 *
1734 (fig-forth-auto680):01731 * ======>> 22 <<
1735 (fig-forth-auto680):01732 * ( n1 n2 --- n )
1736 (fig-forth-auto680):01733 * Bitwise exclusive or the top two integers.
1737 1629 83 (fig-forth-auto680):01734 FCB $83
1738 162A 584F (fig-forth-auto680):01735 FCC 'XO' ; 'XOR'
1739 162C D2 (fig-forth-auto680):01736 FCB $D2
1740 162D 1619 (fig-forth-auto680):01737 FDB OR-5
1741 162F 1631 (fig-forth-auto680):01738 XOR FDB *+NATWID
1742 1631 3706 (fig-forth-auto680):01739 PULU A,B
1743 1633 E841 (fig-forth-auto680):01740 EORB 1,U
1744 1635 A8C4 (fig-forth-auto680):01741 EORA ,U
1745 1637 EDC4 (fig-forth-auto680):01742 STD ,U
1746 1639 39 (fig-forth-auto680):01743 RTS
1747 (fig-forth-auto680):01744 * PULS A ;
1748 (fig-forth-auto680):01745 * PULS B ;
1749 (fig-forth-auto680):01746 * TFR S,X ; TSX :
1750 (fig-forth-auto680):01747 * EORB 1,X
1751 (fig-forth-auto680):01748 * EORA 0,X
1752 (fig-forth-auto680):01749 * JMP STABX
1753 (fig-forth-auto680):01750 *
1754 (fig-forth-auto680):01751 * ######>> screen 26 <<
1755 (fig-forth-auto680):01752 * ======>> 23 <<
1756 (fig-forth-auto680):01753 * ( --- adr )
1757 (fig-forth-auto680):01754 * Fetch the parameter stack pointer (before it is pushed).
1758 (fig-forth-auto680):01755 * This points at whatever was on the top of stack before.
1759 163A 83 (fig-forth-auto680):01756 FCB $83
1760 163B 5350 (fig-forth-auto680):01757 FCC 'SP' ; 'SP@'
1761 163D C0 (fig-forth-auto680):01758 FCB $C0
1762 163E 1629 (fig-forth-auto680):01759 FDB XOR-6
1763 1640 1642 (fig-forth-auto680):01760 SPAT FDB *+NATWID
1764 1642 1F31 (fig-forth-auto680):01761 TFR U,X
1765 1644 3610 (fig-forth-auto680):01762 PSHU X
1766 1646 39 (fig-forth-auto680):01763 RTS
1767 (fig-forth-auto680):01764 * TFR S,X ; TSX :
1768 (fig-forth-auto680):01765 * STX N scratch area
1769 (fig-forth-auto680):01766 * LDX #N
1770 (fig-forth-auto680):01767 * JMP GETX
1771 (fig-forth-auto680):01768 *
1772 (fig-forth-auto680):01769 * ======>> 24 <<
1773 (fig-forth-auto680):01770 * ( whatever --- nothing )
1774 (fig-forth-auto680):01771 * Initialize the parameter stack pointer from the USER variable S0.
1775 (fig-forth-auto680):01772 * Effectively clears the stack.
1776 1647 83 (fig-forth-auto680):01773 FCB $83
1777 1648 5350 (fig-forth-auto680):01774 FCC 'SP' ; 'SP!'
1778 164A A1 (fig-forth-auto680):01775 FCB $A1
1779 164B 163A (fig-forth-auto680):01776 FDB SPAT-6
1780 164D 164F (fig-forth-auto680):01777 SPSTOR FDB *+NATWID
1781 164F DE1E (fig-forth-auto680):01778 LDU <XSPZER
1782 1651 39 (fig-forth-auto680):01779 RTS
1783 (fig-forth-auto680):01780 * LDX UP
1784 (fig-forth-auto680):01781 * LDX XSPZER-UORIG,X
1785 (fig-forth-auto680):01782 * TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
1786 (fig-forth-auto680):01783 * JMP NEXT
1787 (fig-forth-auto680):01784 * ======>> 25 <<
1788 (fig-forth-auto680):01785 * ( whatever *** nothing )
1789 (fig-forth-auto680):01786 * Initialize the return stack pointer from the initialization table
1790 (fig-forth-auto680):01787 * instead of the user variable R0, for some reason.
1791 (fig-forth-auto680):01788 * Quite possibly, this should be from R0.
1792 (fig-forth-auto680):01789 * Effectively aborts all in process definitions, except the active one.
1793 (fig-forth-auto680):01790 * An emergency measure, to be sure.
1794 (fig-forth-auto680):01791 * The routine that calls this must never execute a return.
1795 (fig-forth-auto680):01792 * So this should never be executed from the terminal, I guess.
1796 (fig-forth-auto680):01793 * This is another that should be compile-time only, and in a separate vocabulary.
1797 1652 83 (fig-forth-auto680):01794 FCB $83
1798 1653 5250 (fig-forth-auto680):01795 FCC 'RP' ; 'RP!'
1799 1655 A1 (fig-forth-auto680):01796 FCB $A1
1800 1656 1647 (fig-forth-auto680):01797 FDB SPSTOR-6
1801 1658 165A (fig-forth-auto680):01798 RPSTOR FDB *+NATWID
1802 165A 3510 (fig-forth-auto680):01799 PULS X ; But this guy has to return to his caller.
1803 165C 10FE1214 (fig-forth-auto680):01800 LDS RINIT
1804 1660 6E84 (fig-forth-auto680):01801 JMP ,X
1805 (fig-forth-auto680):01802 * LDX RINIT initialize from rom constant
1806 (fig-forth-auto680):01803 * STX RP
1807 (fig-forth-auto680):01804 * JMP NEXT
1808 (fig-forth-auto680):01805 *
1809 (fig-forth-auto680):01806 * ======>> 26 <<
1810 (fig-forth-auto680):01807 * ( ip *** )
1811 (fig-forth-auto680):01808 * Pop IP from return stack (return from high-level definition).
1812 (fig-forth-auto680):01809 * Can be used in a screen to force interpretion to terminate.
1813 (fig-forth-auto680):01810 * Must not be executed when temporaries are saved on top of the return stack.
1814 1662 82 (fig-forth-auto680):01811 FCB $82
1815 1663 3B (fig-forth-auto680):01812 FCC ';' ; ';S'
1816 1664 D3 (fig-forth-auto680):01813 FCB $D3
1817 1665 1652 (fig-forth-auto680):01814 FDB RPSTOR-6
1818 1667 1669 (fig-forth-auto680):01815 SEMIS FDB *+NATWID
1819 1669 3526 (fig-forth-auto680):01816 PULS D,Y ; return address in D, and saved IP in Y.
1820 166B 1F05 (fig-forth-auto680):01817 TFR D,PC ; Synthetic return.
1821 (fig-forth-auto680):01818 *
1822 (fig-forth-auto680):01819 * Form 6800 model:
1823 (fig-forth-auto680):01820 * LDX RP
1824 (fig-forth-auto680):01821 * LEAX 1,X ;
1825 (fig-forth-auto680):01822 * LEAX 1,X ;
1826 (fig-forth-auto680):01823 * STX RP
1827 (fig-forth-auto680):01824 * LDX 0,X get address we have just finished.
1828 (fig-forth-auto680):01825 * JMP NEXT+2 increment the return address & do next word
1829 (fig-forth-auto680):01826 *
1830 (fig-forth-auto680):01827 * ######>> screen 27 <<
1831 (fig-forth-auto680):01828 * ======>> 27 <<
1832 (fig-forth-auto680):01829 * ( limit index *** index index )
1833 (fig-forth-auto680):01830 * Force the terminating condition for the innermost loop by
1834 (fig-forth-auto680):01831 * copying its index to its limit.
1835 (fig-forth-auto680):01832 * Termination is postponed until the next
1836 (fig-forth-auto680):01833 * LOOP or +LOOP instruction is executed.
1837 (fig-forth-auto680):01834 * The index remains available for use until
1838 (fig-forth-auto680):01835 * the LOOP or +LOOP instruction is encountered.
1839 (fig-forth-auto680):01836 * Note that the assumption is that the current count is the correct count
1840 (fig-forth-auto680):01837 * to end at, rather than pushing the count to the final count.
1841 166D 85 (fig-forth-auto680):01838 FCB $85
1842 166E 4C454156 (fig-forth-auto680):01839 FCC 'LEAV' ; 'LEAVE'
1843 1672 C5 (fig-forth-auto680):01840 FCB $C5
1844 1673 1662 (fig-forth-auto680):01841 FDB SEMIS-5
1845 1675 1677 (fig-forth-auto680):01842 LEAVE FDB *+NATWID
1846 1677 EC62 (fig-forth-auto680):01843 LDD NATWID,S ; Dodge the return address.
1847 1679 ED64 (fig-forth-auto680):01844 STD 2*NATWID,S
1848 167B 39 (fig-forth-auto680):01845 RTS
1849 (fig-forth-auto680):01846 * LDX RP
1850 (fig-forth-auto680):01847 * LDA 2,X
1851 (fig-forth-auto680):01848 * LDB 3,X
1852 (fig-forth-auto680):01849 * STA 4,X
1853 (fig-forth-auto680):01850 * STB 5,X
1854 (fig-forth-auto680):01851 * JMP NEXT
1855 (fig-forth-auto680):01852 *
1856 (fig-forth-auto680):01853 * ======>> 28 <<
1857 (fig-forth-auto680):01854 * ( n --- )
1858 (fig-forth-auto680):01855 * ( *** n )
1859 (fig-forth-auto680):01856 * Move top of parameter stack to top of return stack.
1860 167C 82 (fig-forth-auto680):01857 FCB $82
1861 167D 3E (fig-forth-auto680):01858 FCC '>' ; '>R'
1862 167E D2 (fig-forth-auto680):01859 FCB $D2
1863 167F 166D (fig-forth-auto680):01860 FDB LEAVE-8
1864 1681 1683 (fig-forth-auto680):01861 TOR FDB *+NATWID
1865 1683 3706 (fig-forth-auto680):01862 PULU A,B
1866 1685 AEE4 (fig-forth-auto680):01863 LDX ,S
1867 1687 EDE4 (fig-forth-auto680):01864 STD ,S ; Put it where the return address was.
1868 1689 6E84 (fig-forth-auto680):01865 JMP ,X
1869 (fig-forth-auto680):01866 * LDX RP
1870 (fig-forth-auto680):01867 * LEAX -1,X ;
1871 (fig-forth-auto680):01868 * LEAX -1,X ;
1872 (fig-forth-auto680):01869 * STX RP
1873 (fig-forth-auto680):01870 * PULS A ;
1874 (fig-forth-auto680):01871 * PULS B ;
1875 (fig-forth-auto680):01872 * STA 2,X
1876 (fig-forth-auto680):01873 * STB 3,X
1877 (fig-forth-auto680):01874 * JMP NEXT
1878 (fig-forth-auto680):01875 *
1879 (fig-forth-auto680):01876 * ======>> 29 <<
1880 (fig-forth-auto680):01877 * ( --- n )
1881 (fig-forth-auto680):01878 * ( n *** )
1882 (fig-forth-auto680):01879 * Move top of return stack to top of parameter stack.
1883 168B 82 (fig-forth-auto680):01880 FCB $82
1884 168C 52 (fig-forth-auto680):01881 FCC 'R' ; 'R>'
1885 168D BE (fig-forth-auto680):01882 FCB $BE
1886 168E 167C (fig-forth-auto680):01883 FDB TOR-5
1887 1690 1692 (fig-forth-auto680):01884 FROMR FDB *+NATWID
1888 1692 3516 (fig-forth-auto680):01885 PULS D,X
1889 1694 3610 (fig-forth-auto680):01886 PSHU X
1890 1696 1F05 (fig-forth-auto680):01887 TFR D,PC
1891 (fig-forth-auto680):01888 * LDX RP
1892 (fig-forth-auto680):01889 * LDA 2,X
1893 (fig-forth-auto680):01890 * LDB 3,X
1894 (fig-forth-auto680):01891 * LEAX 1,X ;
1895 (fig-forth-auto680):01892 * LEAX 1,X ;
1896 (fig-forth-auto680):01893 * STX RP
1897 (fig-forth-auto680):01894 * JMP PUSHBA
1898 (fig-forth-auto680):01895 *
1899 (fig-forth-auto680):01896 * ======>> 30 <<
1900 (fig-forth-auto680):01897 * ( --- n )
1901 (fig-forth-auto680):01898 * ( n *** n )
1902 (fig-forth-auto680):01899 * Copy the top of return stack to top of parameter stack.
1903 (fig-forth-auto680):01900 * A synonym for I.
1904 1698 81 (fig-forth-auto680):01901 FCB $81 R
1905 1699 D2 (fig-forth-auto680):01902 FCB $D2
1906 169A 168B (fig-forth-auto680):01903 FDB FROMR-5
1907 169C 1467 (fig-forth-auto680):01904 R FDB I+NATWID
1908 (fig-forth-auto680):01905
1909 (fig-forth-auto680):01906 * LDX RP
1910 (fig-forth-auto680):01907 * LEAX 1,X ;
1911 (fig-forth-auto680):01908 * LEAX 1,X ;
1912 (fig-forth-auto680):01909 * JMP GETX
1913 (fig-forth-auto680):01910 *
1914 (fig-forth-auto680):01911 * ######>> screen 28 <<
1915 (fig-forth-auto680):01912 * ======>> 31 <<
1916 (fig-forth-auto680):01913 * ( n --- n=0 )
1917 (fig-forth-auto680):01914 * Logically invert top of stack;
1918 (fig-forth-auto680):01915 * or flag true if top is zero, otherwise false.
1919 169E 82 (fig-forth-auto680):01916 FCB $82
1920 169F 30 (fig-forth-auto680):01917 FCC '0' ; '0='
1921 16A0 BD (fig-forth-auto680):01918 FCB $BD
1922 16A1 1698 (fig-forth-auto680):01919 FDB R-4
1923 16A3 16A5 (fig-forth-auto680):01920 ZEQU FDB *+NATWID
1924 16A5 CC0000 (fig-forth-auto680):01921 LDD #0
1925 16A8 AEC4 (fig-forth-auto680):01922 LDX ,U
1926 16AA 2601 (fig-forth-auto680):01923 BNE ZEQUF
1927 16AC 5C (fig-forth-auto680):01924 INCB ; 1 is true
1928 16AD EDC4 (fig-forth-auto680):01925 ZEQUF STD ,U
1929 16AF 39 (fig-forth-auto680):01926 RTS
1930 (fig-forth-auto680):01927 * TFR S,X ; TSX :
1931 (fig-forth-auto680):01928 * CLRA ;
1932 (fig-forth-auto680):01929 * CLRB ;
1933 (fig-forth-auto680):01930 * LDX 0,X
1934 (fig-forth-auto680):01931 * BNE ZEQU2
1935 (fig-forth-auto680):01932 * INCB ;
1936 (fig-forth-auto680):01933 *ZEQU2 TFR S,X ; TSX :
1937 (fig-forth-auto680):01934 * JMP STABX
1938 (fig-forth-auto680):01935 *
1939 (fig-forth-auto680):01936 * ======>> 32 <<
1940 (fig-forth-auto680):01937 * ( n --- n<0 )
1941 (fig-forth-auto680):01938 * Flag true if top is negative (MSbit set), otherwise false.
1942 16B0 82 (fig-forth-auto680):01939 FCB $82
1943 16B1 30 (fig-forth-auto680):01940 FCC '0' ; '0<'
1944 16B2 BC (fig-forth-auto680):01941 FCB $BC
1945 16B3 169E (fig-forth-auto680):01942 FDB ZEQU-5
1946 16B5 16B7 (fig-forth-auto680):01943 ZLESS FDB *+NATWID
1947 16B7 CC0000 (fig-forth-auto680):01944 LDD #0
1948 16BA 6DC4 (fig-forth-auto680):01945 TST ,U
1949 16BC 2A01 (fig-forth-auto680):01946 BPL ZLESSF
1950 16BE 5C (fig-forth-auto680):01947 INCB
1951 16BF EDC4 (fig-forth-auto680):01948 ZLESSF STD ,U
1952 16C1 39 (fig-forth-auto680):01949 RTS
1953 (fig-forth-auto680):01950 * TFR S,X ; TSX :
1954 (fig-forth-auto680):01951 * LDA #$80 check the sign bit
1955 (fig-forth-auto680):01952 * ANDA 0,X
1956 (fig-forth-auto680):01953 * BEQ ZLESS2
1957 (fig-forth-auto680):01954 * CLRA ; if neg.
1958 (fig-forth-auto680):01955 * LDB #1
1959 (fig-forth-auto680):01956 * JMP STABX
1960 (fig-forth-auto680):01957 * ZLESS2 CLRB ;
1961 (fig-forth-auto680):01958 * JMP STABX
1962 (fig-forth-auto680):01959 *
1963 (fig-forth-auto680):01960 * ######>> screen 29 <<
1964 (fig-forth-auto680):01961 * ======>> 33 <<
1965 (fig-forth-auto680):01962 * ( n1 n2 --- n1+n2 )
1966 (fig-forth-auto680):01963 * Add top two words.
1967 16C2 81 (fig-forth-auto680):01964 FCB $81 '+'
1968 16C3 AB (fig-forth-auto680):01965 FCB $AB
1969 16C4 16B0 (fig-forth-auto680):01966 FDB ZLESS-5
1970 16C6 16C8 (fig-forth-auto680):01967 PLUS FDB *+NATWID
1971 16C8 3706 (fig-forth-auto680):01968 PULU A,B ; #2~7
1972 16CA E3C4 (fig-forth-auto680):01969 ADDD ,U ; #2~6
1973 16CC EDC4 (fig-forth-auto680):01970 STD ,U ; #2~5
1974 16CE 39 (fig-forth-auto680):01971 RTS ; #1~5 =#7~23
1975 (fig-forth-auto680):01972 * PULS A ;
1976 (fig-forth-auto680):01973 * PULS B ;
1977 (fig-forth-auto680):01974 * TFR S,X ; TSX :
1978 (fig-forth-auto680):01975 * ADDB 1,X
1979 (fig-forth-auto680):01976 * ADCA 0,X
1980 (fig-forth-auto680):01977 * JMP STABX
1981 (fig-forth-auto680):01978 *
1982 (fig-forth-auto680):01979 * ======>> 34 <<
1983 (fig-forth-auto680):01980 * ( d1 d2 --- d1+d2 )
1984 (fig-forth-auto680):01981 * Add top two double integers.
1985 16CF 82 (fig-forth-auto680):01982 FCB $82
1986 16D0 44 (fig-forth-auto680):01983 FCC 'D' ; 'D+'
1987 16D1 AB (fig-forth-auto680):01984 FCB $AB
1988 16D2 16C2 (fig-forth-auto680):01985 FDB PLUS-4
1989 16D4 16D6 (fig-forth-auto680):01986 DPLUS FDB *+NATWID
1990 16D6 EC46 (fig-forth-auto680):01987 LDD 3*NATWID,U
1991 16D8 E342 (fig-forth-auto680):01988 ADDD NATWID,U
1992 16DA ED46 (fig-forth-auto680):01989 STD 3*NATWID,U
1993 16DC EC44 (fig-forth-auto680):01990 LDD 2*NATWID,U
1994 16DE E941 (fig-forth-auto680):01991 ADCB 1,U
1995 16E0 A9C4 (fig-forth-auto680):01992 ADCA ,U
1996 16E2 3344 (fig-forth-auto680):01993 LEAU 2*NATWID,U
1997 16E4 EDC4 (fig-forth-auto680):01994 STD ,U
1998 16E6 39 (fig-forth-auto680):01995 RTS
1999 (fig-forth-auto680):01996 * TFR S,X ; TSX :
2000 (fig-forth-auto680):01997 * ANDCC #~$01 ; CLC :
2001 (fig-forth-auto680):01998 * LDB #4
2002 (fig-forth-auto680):01999 * DPLUS2 LDA 3,X
2003 (fig-forth-auto680):02000 * ADCA 7,X
2004 (fig-forth-auto680):02001 * STA 7,X
2005 (fig-forth-auto680):02002 * LEAX -1,X ;
2006 (fig-forth-auto680):02003 * DECB ;
2007 (fig-forth-auto680):02004 * BNE DPLUS2
2008 (fig-forth-auto680):02005 * LEAS 1,S ;
2009 (fig-forth-auto680):02006 * LEAS 1,S ;
2010 (fig-forth-auto680):02007 * LEAS 1,S ;
2011 (fig-forth-auto680):02008 * LEAS 1,S ;
2012 (fig-forth-auto680):02009 * JMP NEXT
2013 (fig-forth-auto680):02010 *
2014 (fig-forth-auto680):02011 * ======>> 35 <<
2015 (fig-forth-auto680):02012 * ( n --- -n )
2016 (fig-forth-auto680):02013 * Negate (two's complement) top of stack.
2017 16E7 85 (fig-forth-auto680):02014 FCB $85
2018 16E8 4D494E55 (fig-forth-auto680):02015 FCC 'MINU' ; 'MINUS'
2019 16EC D3 (fig-forth-auto680):02016 FCB $D3
2020 16ED 16CF (fig-forth-auto680):02017 FDB DPLUS-5
2021 16EF 16F1 (fig-forth-auto680):02018 MINUS FDB *+NATWID
2022 16F1 CC0000 (fig-forth-auto680):02019 LDD #0 ; #3~3
2023 16F4 A3C4 (fig-forth-auto680):02020 SUBD ,U ; #2~5
2024 16F6 EDC4 (fig-forth-auto680):02021 STD ,U ; #2~5
2025 16F8 39 (fig-forth-auto680):02022 RTS ; #1~5 = #8~18
2026 (fig-forth-auto680):02023 *
2027 (fig-forth-auto680):02024 * from 6800 model code:
2028 (fig-forth-auto680):02025 * TFR S,X ; TSX :
2029 (fig-forth-auto680):02026 * NEG 1,X
2030 (fig-forth-auto680):02027 * BCC MINUS2
2031 (fig-forth-auto680):02028 * NEG 0,X
2032 (fig-forth-auto680):02029 * BRA MINUS3
2033 (fig-forth-auto680):02030 * MINUS2 COM 0,X
2034 (fig-forth-auto680):02031 * MINUS3 JMP NEXT
2035 (fig-forth-auto680):02032 *
2036 (fig-forth-auto680):02033 * ======>> 36 <<
2037 (fig-forth-auto680):02034 * ( d --- -d )
2038 (fig-forth-auto680):02035 * Negate (two's complement) top two words on stack as a double integer.
2039 16F9 86 (fig-forth-auto680):02036 FCB $86
2040 16FA 444D494E55 (fig-forth-auto680):02037 FCC 'DMINU' ; 'DMINUS'
2041 16FF D3 (fig-forth-auto680):02038 FCB $D3
2042 1700 16E7 (fig-forth-auto680):02039 FDB MINUS-8
2043 1702 1704 (fig-forth-auto680):02040 DMINUS FDB *+NATWID
2044 1704 CC0000 (fig-forth-auto680):02041 LDD #0 ; #3~3
2045 1707 A342 (fig-forth-auto680):02042 SUBD NATWID,U ; #2~7
2046 1709 ED42 (fig-forth-auto680):02043 STD NATWID,U ; #2~7
2047 170B CC0000 (fig-forth-auto680):02044 LDD #0 ; #3~3
2048 170E E241 (fig-forth-auto680):02045 SBCB 1,U ; #2~5
2049 1710 A2C4 (fig-forth-auto680):02046 SBCA ,U ; #2~4
2050 1712 EDC4 (fig-forth-auto680):02047 STD ,U ; #2~5
2051 1714 39 (fig-forth-auto680):02048 RTS ; #1~5 = #17~39
2052 (fig-forth-auto680):02049 * TFR S,X ; TSX :
2053 (fig-forth-auto680):02050 * COM 0,X
2054 (fig-forth-auto680):02051 * COM 1,X
2055 (fig-forth-auto680):02052 * COM 2,X
2056 (fig-forth-auto680):02053 * NEG 3,X
2057 (fig-forth-auto680):02054 * BNE DMINX
2058 (fig-forth-auto680):02055 * INC 2,X
2059 (fig-forth-auto680):02056 * BNE DMINX
2060 (fig-forth-auto680):02057 * INC 1,X
2061 (fig-forth-auto680):02058 * BNE DMINX
2062 (fig-forth-auto680):02059 * INC 0,X
2063 (fig-forth-auto680):02060 * DMINX JMP NEXT
2064 (fig-forth-auto680):02061 *
2065 (fig-forth-auto680):02062 * ######>> screen 30 <<
2066 (fig-forth-auto680):02063 * ======>> 37 <<
2067 (fig-forth-auto680):02064 * ( n1 n2 --- n1 n2 n1 )
2068 (fig-forth-auto680):02065 * Push a copy of the second word on stack.
2069 1715 84 (fig-forth-auto680):02066 FCB $84
2070 1716 4F5645 (fig-forth-auto680):02067 FCC 'OVE' ; 'OVER'
2071 1719 D2 (fig-forth-auto680):02068 FCB $D2
2072 171A 16F9 (fig-forth-auto680):02069 FDB DMINUS-9
2073 171C 171E (fig-forth-auto680):02070 OVER FDB *+NATWID
2074 171E EC42 (fig-forth-auto680):02071 LDD NATWID,U
2075 1720 3606 (fig-forth-auto680):02072 PSHU D
2076 1722 39 (fig-forth-auto680):02073 RTS
2077 (fig-forth-auto680):02074 * TFR S,X ; TSX :
2078 (fig-forth-auto680):02075 * LDA 2,X
2079 (fig-forth-auto680):02076 * LDB 3,X
2080 (fig-forth-auto680):02077 * JMP PUSHBA
2081 (fig-forth-auto680):02078 *
2082 (fig-forth-auto680):02079 * ======>> 38 <<
2083 (fig-forth-auto680):02080 * ( n --- )
2084 (fig-forth-auto680):02081 * Discard the top word on stack.
2085 1723 84 (fig-forth-auto680):02082 FCB $84
2086 1724 44524F (fig-forth-auto680):02083 FCC 'DRO' ; 'DROP'
2087 1727 D0 (fig-forth-auto680):02084 FCB $D0
2088 1728 1715 (fig-forth-auto680):02085 FDB OVER-7
2089 172A 172C (fig-forth-auto680):02086 DROP FDB *+NATWID
2090 172C 3342 (fig-forth-auto680):02087 LEAU NATWID,U
2091 172E 39 (fig-forth-auto680):02088 RTS
2092 (fig-forth-auto680):02089 * LEAS 1,S ;
2093 (fig-forth-auto680):02090 * LEAS 1,S ;
2094 (fig-forth-auto680):02091 * JMP NEXT
2095 (fig-forth-auto680):02092 *
2096 (fig-forth-auto680):02093 * ======>> 39 <<
2097 (fig-forth-auto680):02094 * ( n1 n2 --- n2 n1 )
2098 (fig-forth-auto680):02095 * Swap the top two words on stack.
2099 172F 84 (fig-forth-auto680):02096 FCB $84
2100 1730 535741 (fig-forth-auto680):02097 FCC 'SWA' ; 'SWAP'
2101 1733 D0 (fig-forth-auto680):02098 FCB $D0
2102 1734 1723 (fig-forth-auto680):02099 FDB DROP-7
2103 1736 1738 (fig-forth-auto680):02100 SWAP FDB *+NATWID
2104 1738 3716 (fig-forth-auto680):02101 PULU D,X
2105 173A 3606 (fig-forth-auto680):02102 PSHU D
2106 173C 3610 (fig-forth-auto680):02103 PSHU X
2107 173E 39 (fig-forth-auto680):02104 RTS
2108 (fig-forth-auto680):02105 * PULS A ;
2109 (fig-forth-auto680):02106 * PULS B ;
2110 (fig-forth-auto680):02107 * TFR S,X ; TSX :
2111 (fig-forth-auto680):02108 * LDX 0,X
2112 (fig-forth-auto680):02109 * LEAS 1,S ;
2113 (fig-forth-auto680):02110 * LEAS 1,S ;
2114 (fig-forth-auto680):02111 * PSHS B ;
2115 (fig-forth-auto680):02112 * PSHS A ;
2116 (fig-forth-auto680):02113 * STX N
2117 (fig-forth-auto680):02114 * LDX #N
2118 (fig-forth-auto680):02115 * JMP GETX
2119 (fig-forth-auto680):02116 *
2120 (fig-forth-auto680):02117 * ======>> 40 <<
2121 (fig-forth-auto680):02118 * ( n1 --- n1 n1 )
2122 (fig-forth-auto680):02119 * Push a copy of the top word on stack.
2123 173F 83 (fig-forth-auto680):02120 FCB $83
2124 1740 4455 (fig-forth-auto680):02121 FCC 'DU' ; 'DUP'
2125 1742 D0 (fig-forth-auto680):02122 FCB $D0
2126 1743 172F (fig-forth-auto680):02123 FDB SWAP-7
2127 1745 1747 (fig-forth-auto680):02124 DUP FDB *+NATWID
2128 1747 ECC4 (fig-forth-auto680):02125 LDD ,U
2129 1749 3606 (fig-forth-auto680):02126 PSHU D
2130 174B 39 (fig-forth-auto680):02127 RTS
2131 (fig-forth-auto680):02128 * PULS A ;
2132 (fig-forth-auto680):02129 * PULS B ;
2133 (fig-forth-auto680):02130 * PSHS B ;
2134 (fig-forth-auto680):02131 * PSHS A ;
2135 (fig-forth-auto680):02132 * JMP PUSHBA
2136 (fig-forth-auto680):02133 *
2137 (fig-forth-auto680):02134 * ######>> screen 31 <<
2138 (fig-forth-auto680):02135 * ======>> 41 <<
2139 (fig-forth-auto680):02136 * ( n adr --- )
2140 (fig-forth-auto680):02137 * Add the second word on stack to the word at the adr on top of stack.
2141 174C 82 (fig-forth-auto680):02138 FCB $82
2142 174D 2B (fig-forth-auto680):02139 FCC '+' ; '+!'
2143 174E A1 (fig-forth-auto680):02140 FCB $A1
2144 174F 173F (fig-forth-auto680):02141 FDB DUP-6
2145 1751 1753 (fig-forth-auto680):02142 PSTORE FDB *+NATWID
2146 1753 3710 (fig-forth-auto680):02143 PULU X
2147 1755 EC84 (fig-forth-auto680):02144 LDD ,X
2148 1757 E3C1 (fig-forth-auto680):02145 ADDD ,U++
2149 1759 ED84 (fig-forth-auto680):02146 STD ,X
2150 175B 39 (fig-forth-auto680):02147 RTS
2151 (fig-forth-auto680):02148 * TFR S,X ; TSX :
2152 (fig-forth-auto680):02149 * LDX 0,X
2153 (fig-forth-auto680):02150 * LEAS 1,S ;
2154 (fig-forth-auto680):02151 * LEAS 1,S ;
2155 (fig-forth-auto680):02152 * PULS A ; get stack data
2156 (fig-forth-auto680):02153 * PULS B ;
2157 (fig-forth-auto680):02154 * ADDB 1,X add & store low byte
2158 (fig-forth-auto680):02155 * STB 1,X
2159 (fig-forth-auto680):02156 * ADCA 0,X add & store hi byte
2160 (fig-forth-auto680):02157 * STA 0,X
2161 (fig-forth-auto680):02158 * JMP NEXT
2162 (fig-forth-auto680):02159 *
2163 (fig-forth-auto680):02160 * ======>> 42 <<
2164 (fig-forth-auto680):02161 * ( adr b --- )
2165 (fig-forth-auto680):02162 * Exclusive or byte at adr with low byte of top word.
2166 175C 86 (fig-forth-auto680):02163 FCB $86
2167 175D 544F47474C (fig-forth-auto680):02164 FCC 'TOGGL' ; 'TOGGLE'
2168 1762 C5 (fig-forth-auto680):02165 FCB $C5
2169 1763 174C (fig-forth-auto680):02166 FDB PSTORE-5
2170 1765 1767 (fig-forth-auto680):02167 TOGGLE FDB *+NATWID
2171 1767 3716 (fig-forth-auto680):02168 PULU D,X
2172 1769 E884 (fig-forth-auto680):02169 EORB ,X
2173 176B E784 (fig-forth-auto680):02170 STB ,X
2174 176D 39 (fig-forth-auto680):02171 RTS
2175 (fig-forth-auto680):02172 * Using the model code would be less likely to introduce bugs,
2176 (fig-forth-auto680):02173 * but that would sort-of defeat my purposes here.
2177 (fig-forth-auto680):02174 * Anyway, I can borrow from theoretically known good bif-6809 code
2178 (fig-forth-auto680):02175 * and it's fewer bytes and much faster code this way.
2179 (fig-forth-auto680):02176 * TOGGLE
2180 (fig-forth-auto680):02177 * FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
2181 (fig-forth-auto680):02178 * FDB SEMIS
2182 (fig-forth-auto680):02179 *
2183 (fig-forth-auto680):02180 * ######>> screen 32 <<
2184 (fig-forth-auto680):02181 * ======>> 43 <<
2185 (fig-forth-auto680):02182 * ( adr --- n )
2186 (fig-forth-auto680):02183 * Replace address on stack with the word at the address.
2187 176E 81 (fig-forth-auto680):02184 FCB $81 @
2188 176F C0 (fig-forth-auto680):02185 FCB $C0
2189 1770 175C (fig-forth-auto680):02186 FDB TOGGLE-9
2190 1772 1774 (fig-forth-auto680):02187 AT FDB *+NATWID
2191 1774 ECD4 (fig-forth-auto680):02188 LDD [,U]
2192 1776 EDC4 (fig-forth-auto680):02189 STD ,U
2193 1778 39 (fig-forth-auto680):02190 RTS
2194 (fig-forth-auto680):02191 * TFR S,X ; TSX :
2195 (fig-forth-auto680):02192 * LDX 0,X get address
2196 (fig-forth-auto680):02193 * LEAS 1,S ;
2197 (fig-forth-auto680):02194 * LEAS 1,S ;
2198 (fig-forth-auto680):02195 * JMP GETX
2199 (fig-forth-auto680):02196 *
2200 (fig-forth-auto680):02197 * ======>> 44 <<
2201 (fig-forth-auto680):02198 * ( adr --- b )
2202 (fig-forth-auto680):02199 * Replace address on top of stack with the byte at the address.
2203 (fig-forth-auto680):02200 * High byte of result is clear.
2204 1779 82 (fig-forth-auto680):02201 FCB $82
2205 177A 43 (fig-forth-auto680):02202 FCC 'C' ; 'C@'
2206 177B C0 (fig-forth-auto680):02203 FCB $C0
2207 177C 176E (fig-forth-auto680):02204 FDB AT-4
2208 177E 1780 (fig-forth-auto680):02205 CAT FDB *+NATWID
2209 1780 E6D4 (fig-forth-auto680):02206 LDB [,U]
2210 1782 4F (fig-forth-auto680):02207 CLRA
2211 1783 EDC4 (fig-forth-auto680):02208 STD ,U
2212 1785 39 (fig-forth-auto680):02209 RTS
2213 (fig-forth-auto680):02210
2214 (fig-forth-auto680):02211
2215 (fig-forth-auto680):02212 * TFR S,X ; TSX :
2216 (fig-forth-auto680):02213 * LDX 0,X
2217 (fig-forth-auto680):02214 * CLRA ;
2218 (fig-forth-auto680):02215 * LDB 0,X
2219 (fig-forth-auto680):02216 * LEAS 1,S ;
2220 (fig-forth-auto680):02217 * LEAS 1,S ;
2221 (fig-forth-auto680):02218 * JMP PUSHBA
2222 (fig-forth-auto680):02219 *
2223 (fig-forth-auto680):02220 * ======>> 45 <<
2224 (fig-forth-auto680):02221 * ( n adr --- )
2225 (fig-forth-auto680):02222 * Store second word on stack at address on top of stack.
2226 1786 81 (fig-forth-auto680):02223 FCB $81
2227 1787 A1 (fig-forth-auto680):02224 FCB $A1
2228 1788 1779 (fig-forth-auto680):02225 FDB CAT-5
2229 178A 178C (fig-forth-auto680):02226 STORE FDB *+NATWID
2230 178C EC42 (fig-forth-auto680):02227 LDD NATWID,U
2231 178E EDD4 (fig-forth-auto680):02228 STD [,U]
2232 1790 3344 (fig-forth-auto680):02229 LEAU 2*NATWID,U
2233 1792 39 (fig-forth-auto680):02230 RTS
2234 (fig-forth-auto680):02231 * TFR S,X ; TSX :
2235 (fig-forth-auto680):02232 * LDX 0,X get address
2236 (fig-forth-auto680):02233 * LEAS 1,S ;
2237 (fig-forth-auto680):02234 * LEAS 1,S ;
2238 (fig-forth-auto680):02235 * JMP PULABX
2239 (fig-forth-auto680):02236 *
2240 (fig-forth-auto680):02237 * ======>> 46 <<
2241 (fig-forth-auto680):02238 * ( b adr --- )
2242 (fig-forth-auto680):02239 * Store low byte of second word on stack at address on top of stack.
2243 (fig-forth-auto680):02240 * High byte is ignored.
2244 1793 82 (fig-forth-auto680):02241 FCB $82
2245 1794 43 (fig-forth-auto680):02242 FCC 'C' ; 'C!'
2246 1795 A1 (fig-forth-auto680):02243 FCB $A1
2247 1796 1786 (fig-forth-auto680):02244 FDB STORE-4
2248 1798 179A (fig-forth-auto680):02245 CSTORE FDB *+NATWID
2249 179A E643 (fig-forth-auto680):02246 LDB 3,U
2250 179C E7D4 (fig-forth-auto680):02247 STB [,U]
2251 179E 3344 (fig-forth-auto680):02248 LEAU 2*NATWID,U
2252 17A0 39 (fig-forth-auto680):02249 RTS
2253 (fig-forth-auto680):02250 * TFR S,X ; TSX :
2254 (fig-forth-auto680):02251 * LDX 0,X get address
2255 (fig-forth-auto680):02252 * LEAS 1,S ;
2256 (fig-forth-auto680):02253 * LEAS 1,S ;
2257 (fig-forth-auto680):02254 * LEAS 1,S ;
2258 (fig-forth-auto680):02255 * PULS B ;
2259 (fig-forth-auto680):02256 * STB 0,X
2260 (fig-forth-auto680):02257 * JMP NEXT
2261 (fig-forth-auto680):02258 PAGE
2262 (fig-forth-auto680):02259 *
2263 (fig-forth-auto680):02260 * ######>> screen 33 <<
2264 (fig-forth-auto680):02261 * ======>> 47 <<
2265 (fig-forth-auto680):02262 * ( --- ) P
2266 (fig-forth-auto680):02263 * { : name sundry-activities ; } typical input
2267 (fig-forth-auto680):02264 * If executing (not compiling),
2268 (fig-forth-auto680):02265 * record the data stack mark in CSP,
2269 (fig-forth-auto680):02266 * Set the CONTEXT vocabulary to CURRENT,
2270 (fig-forth-auto680):02267 * CREATE a header,
2271 (fig-forth-auto680):02268 * set state to compile,
2272 (fig-forth-auto680):02269 * and compile the call to the trailing native CPU machine code DOCOL.
2273 (fig-forth-auto680):02270 *
2274 (fig-forth-auto680):02271 * This would not be hard to flatten to native code.
2275 (fig-forth-auto680):02272 * But that's not the purpose of a model.
2276 17A1 C1 (fig-forth-auto680):02273 FCB $C1 : immediate
2277 17A2 BA (fig-forth-auto680):02274 FCB $BA
2278 17A3 1793 (fig-forth-auto680):02275 FDB CSTORE-5
2279 17A5 17B91B6A1B26194C (fig-forth-auto680):02276 COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
2281 17B3 20661BEB (fig-forth-auto680):02277 FDB CREATE,RBRAK
2282 17B7 1C3A (fig-forth-auto680):02278 FDB PSCODE
2283 (fig-forth-auto680):02279
2284 (fig-forth-auto680):02280 * Here is the IP pusher for allowing
2285 (fig-forth-auto680):02281 * nested words in the virtual machine:
2286 (fig-forth-auto680):02282 * ( ;S is the equivalent un-nester )
2287 (fig-forth-auto680):02283
2288 (fig-forth-auto680):02284 * ( *** oldIP )
2289 (fig-forth-auto680):02285 * Characteristic of a colon (:) definition.
2290 (fig-forth-auto680):02286 * Begins execution of a high-level definition,
2291 (fig-forth-auto680):02287 * i. e., nests the definition and begins processing icodes.
2292 (fig-forth-auto680):02288 * Mechanically, it pushes the IP (Y register)
2293 (fig-forth-auto680):02289 * and loads the Parameter Field Address of the definition which
2294 (fig-forth-auto680):02290 * called it into the IP.
2295 17B9 ECE4 (fig-forth-auto680):02291 DOCOL LDD ,S ; Save the return address.
2296 17BB 10AFE4 (fig-forth-auto680):02292 STY ,S ; Nest the old IP.
2297 17BE 3102 (fig-forth-auto680):02293 LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
2298 17C0 1F05 (fig-forth-auto680):02294 TFR D,PC ; synthetic return to interpret.
2299 (fig-forth-auto680):02295
2300 (fig-forth-auto680):02296 * DOCOL LDX RP make room in the stack
2301 (fig-forth-auto680):02297 * LEAX -1,X ;
2302 (fig-forth-auto680):02298 * LEAX -1,X ;
2303 (fig-forth-auto680):02299 * STX RP
2304 (fig-forth-auto680):02300 * LDA IP
2305 (fig-forth-auto680):02301 * LDB IP+1
2306 (fig-forth-auto680):02302 * STA 2,X Store address of the high level word
2307 (fig-forth-auto680):02303 * STB 3,X that we are starting to execute
2308 (fig-forth-auto680):02304 * LDX W Get first sub-word of that definition
2309 (fig-forth-auto680):02305 * JMP NEXT+2 and execute it
2310 (fig-forth-auto680):02306 *
2311 (fig-forth-auto680):02307 * ======>> 48 <<
2312 (fig-forth-auto680):02308 * ( --- ) P
2313 (fig-forth-auto680):02309 * { : name sundry-activities ; } typical input
2314 (fig-forth-auto680):02310 * ERROR check data stack against mark in CSP,
2315 (fig-forth-auto680):02311 * compile ;S,
2316 (fig-forth-auto680):02312 * unSMUDGE LATEST definition,
2317 (fig-forth-auto680):02313 * and set state to interpretation.
2318 17C2 C1 (fig-forth-auto680):02314 FCB $C1 ; imnediate code
2319 17C3 BB (fig-forth-auto680):02315 FCB $BB
2320 17C4 17A1 (fig-forth-auto680):02316 FDB COLON-4
2321 17C6 17B91B921BC71667 (fig-forth-auto680):02317 SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
2323 17D2 1667 (fig-forth-auto680):02318 FDB SEMIS
2324 (fig-forth-auto680):02319 *
2325 (fig-forth-auto680):02320 * ######>> screen 34 <<
2326 (fig-forth-auto680):02321 * ======>> 49 <<
2327 (fig-forth-auto680):02322 * ( n --- )
2328 (fig-forth-auto680):02323 * { value CONSTANT name } typical input
2329 (fig-forth-auto680):02324 * CREATE a header,
2330 (fig-forth-auto680):02325 * unSMUDGE it,
2331 (fig-forth-auto680):02326 * compile the constant value,
2332 (fig-forth-auto680):02327 * and compile the call to the trailing native CPU machine code DOCON.
2333 17D4 88 (fig-forth-auto680):02328 FCB $88
2334 17D5 434F4E5354414E (fig-forth-auto680):02329 FCC 'CONSTAN' ; 'CONSTANT'
2335 17DC D4 (fig-forth-auto680):02330 FCB $D4
2336 17DD 17C2 (fig-forth-auto680):02331 FDB SEMI-4
2337 17DF 17B920661BFF19E3 (fig-forth-auto680):02332 CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
2339 (fig-forth-auto680):02333 * ( --- n )
2340 (fig-forth-auto680):02334 * Characteristic of a CONSTANT.
2341 (fig-forth-auto680):02335 * A CONSTANT simply loads its value from its parameter field
2342 (fig-forth-auto680):02336 * and pushes it on the stack.
2343 17E9 EC02 (fig-forth-auto680):02337 DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
2344 17EB 3606 (fig-forth-auto680):02338 PSHU D
2345 17ED 39 (fig-forth-auto680):02339 RTS
2346 (fig-forth-auto680):02340 * DOCON LDX W
2347 (fig-forth-auto680):02341 * LDA 2,X
2348 (fig-forth-auto680):02342 * LDB 3,X A & B now contain the constant
2349 (fig-forth-auto680):02343 * JMP PUSHBA
2350 (fig-forth-auto680):02344 *
2351 (fig-forth-auto680):02345 * Not in model, needed for abstraction:
2352 (fig-forth-auto680):02346 * ( --- NATWID )
2353 (fig-forth-auto680):02347 * The byte width of objects on stack.
2354 17EE 86 (fig-forth-auto680):02348 FCB $86
2355 17EF 4E41545749 (fig-forth-auto680):02349 FCC 'NATWI' ; 'NATWID'
2356 17F4 C4 (fig-forth-auto680):02350 FCB $C4
2357 17F5 17D4 (fig-forth-auto680):02351 FDB CON-11
2358 17F7 17E9 (fig-forth-auto680):02352 NATWC FDB DOCON
2359 17F9 0002 (fig-forth-auto680):02353 NATWCV FDB NATWID
2360 (fig-forth-auto680):02354 *
2361 (fig-forth-auto680):02355 * Not in model, needed for abstraction:
2362 (fig-forth-auto680):02356 * Note that this is not defined as an INCREMENTER!
2363 (fig-forth-auto680):02357 * Coded to increment by the exact constant returned by NATWID
2364 (fig-forth-auto680):02358 * ( n --- n+NATWID )
2365 17FB 84 (fig-forth-auto680):02359 FCB $84
2366 17FC 4E4154 (fig-forth-auto680):02360 FCC 'NAT' ; 'NAT+'
2367 17FF AB (fig-forth-auto680):02361 FCB $AB
2368 1800 17EE (fig-forth-auto680):02362 FDB NATWC-9
2369 1802 1804 (fig-forth-auto680):02363 NATP FDB *+NATWID
2370 1804 ECC4 (fig-forth-auto680):02364 LDD ,U
2371 1806 E38CF0 (fig-forth-auto680):02365 ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
2372 1809 EDC4 (fig-forth-auto680):02366 STD ,U
2373 180B 39 (fig-forth-auto680):02367 RTS
2374 (fig-forth-auto680):02368 * How this might have been done for 6800 model:
2375 (fig-forth-auto680):02369 * CLRA ; We know the natural width is less than 255, LOL.
2376 (fig-forth-auto680):02370 * LDAB NATWCV+1
2377 (fig-forth-auto680):02371 * TSX
2378 (fig-forth-auto680):02372 * ADDB 1,X
2379 (fig-forth-auto680):02373 * ADCA ,X
2380 (fig-forth-auto680):02374 * JMP STABX
2381 (fig-forth-auto680):02375 *
2382 (fig-forth-auto680):02376 * ======>> 50 <<
2383 (fig-forth-auto680):02377 * ( init --- )
2384 (fig-forth-auto680):02378 * { init VARIABLE name } typical input
2385 (fig-forth-auto680):02379 * Use CONSTANT to CREATE a header and compile the initial value, init,
2386 (fig-forth-auto680):02380 * then overwrite the characteristic to point to DOVAR.
2387 180C 88 (fig-forth-auto680):02381 FCB $88
2388 180D 5641524941424C (fig-forth-auto680):02382 FCC 'VARIABL' ; 'VARIABLE'
2389 1814 C5 (fig-forth-auto680):02383 FCB $C5
2390 1815 17FB (fig-forth-auto680):02384 FDB NATP-7
2391 1817 17B917DF1C3A (fig-forth-auto680):02385 VAR FDB DOCOL,CON,PSCODE
2392 (fig-forth-auto680):02386 * ( --- vadr )
2393 (fig-forth-auto680):02387 * Characteristic of a VARIABLE.
2394 (fig-forth-auto680):02388 * A VARIABLE pushes its PFA address on the stack.
2395 (fig-forth-auto680):02389 * The parameter field of a VARIABLE is the actual allocation of the variable,
2396 (fig-forth-auto680):02390 * so that pushing its address allows its contents to be @ed (fetched).
2397 (fig-forth-auto680):02391 * Ordinary arrays and strings that do not subscript themselves
2398 (fig-forth-auto680):02392 * may be allocated by defining a variable
2399 (fig-forth-auto680):02393 * and immediately ALLOTting the remaining needed space.
2400 (fig-forth-auto680):02394 * VARIABLES are global to all users,
2401 (fig-forth-auto680):02395 * and thus should be hidden in resource monitors, but aren't.
2402 181D 3002 (fig-forth-auto680):02396 DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
2403 181F 3610 (fig-forth-auto680):02397 PSHU X
2404 1821 39 (fig-forth-auto680):02398 RTS
2405 (fig-forth-auto680):02399 * DOVAR LDA W
2406 (fig-forth-auto680):02400 * LDB W+1
2407 (fig-forth-auto680):02401 * ADDB #2
2408 (fig-forth-auto680):02402 * ADCA #0 A,B now contain the address of the variable
2409 (fig-forth-auto680):02403 * JMP PUSHBA
2410 (fig-forth-auto680):02404 *
2411 (fig-forth-auto680):02405 * ======>> 51 <<
2412 (fig-forth-auto680):02406 * ( ub --- )
2413 (fig-forth-auto680):02407 * { uboffset USER name } typical input
2414 (fig-forth-auto680):02408 * CREATE a header and compile the unsigned byte offset in the per-USER table,
2415 (fig-forth-auto680):02409 * then overwrite the header with a call to DOUSER.
2416 (fig-forth-auto680):02410 * The USER is entirely responsible for maintaining allocation!
2417 1822 84 (fig-forth-auto680):02411 FCB $84
2418 1823 555345 (fig-forth-auto680):02412 FCC 'USE' ; 'USER'
2419 1826 D2 (fig-forth-auto680):02413 FCB $D2
2420 1827 180C (fig-forth-auto680):02414 FDB VAR-11
2421 1829 17B917DF1C3A (fig-forth-auto680):02415 USER FDB DOCOL,CON,PSCODE
2422 (fig-forth-auto680):02416 * ( --- vadr )
2423 (fig-forth-auto680):02417 * Characteristic of a per-USER variable.
2424 (fig-forth-auto680):02418 * USER variables are similiar to VARIABLEs,
2425 (fig-forth-auto680):02419 * but are allocated (by hand!) in the per-user table.
2426 (fig-forth-auto680):02420 * A USER variable's parameter field contains its offset in the per-user table.
2427 182F 1FB8 (fig-forth-auto680):02421 DOUSER TFR DP,A ; Make a pointer to the direct page.
2428 1831 5F (fig-forth-auto680):02422 CLRB
2429 (fig-forth-auto680):02423 * See Alternative -- alternatives start from this point.
2430 1832 E302 (fig-forth-auto680):02424 ADDD NATWID,X ; Add it to the offset to the per-user variable.
2431 1834 3606 (fig-forth-auto680):02425 PSHU D
2432 1836 1F01 (fig-forth-auto680):02426 TFR D,X ; Cache the pointer in X for the caller.
2433 1838 39 (fig-forth-auto680):02427 RTS
2434 (fig-forth-auto680):02428 * Hey, the per-user table could actually be larger than 256 bytes!
2435 (fig-forth-auto680):02429 * But we knew that. It's just not as esthetic to calculate it this way.
2436 (fig-forth-auto680):02430 * Alternative A:
2437 (fig-forth-auto680):02431 * LDX NATWID,X ; Keep the offset
2438 (fig-forth-auto680):02432 * EXG D,X ; Prepare for EA
2439 (fig-forth-auto680):02433 * LEAX D,X
2440 (fig-forth-auto680):02434 * PSHU X
2441 (fig-forth-auto680):02435 * RTS
2442 (fig-forth-auto680):02436 * Alternative B:
2443 (fig-forth-auto680):02437 * PSHS Y ; Get Y free for calculations.
2444 (fig-forth-auto680):02438 * TFR D,Y ; Y points to the UP base
2445 (fig-forth-auto680):02439 * LDD NATWID,X ; Get the offset
2446 (fig-forth-auto680):02440 * LEAX D,Y ; Leave the pointer cached in X.
2447 (fig-forth-auto680):02441 * PSHU X
2448 (fig-forth-auto680):02442 * PULS Y,PC
2449 (fig-forth-auto680):02443 *
2450 (fig-forth-auto680):02444 * From the 6800 model:
2451 (fig-forth-auto680):02445 * DOUSER LDX W get offset into user's table
2452 (fig-forth-auto680):02446 * LDA 2,X
2453 (fig-forth-auto680):02447 * LDB 3,X
2454 (fig-forth-auto680):02448 * ADDB UP+1 add to users base address
2455 (fig-forth-auto680):02449 * ADCA UP
2456 (fig-forth-auto680):02450 * JMP PUSHBA push address of user's variable
2457 (fig-forth-auto680):02451 *
2458 (fig-forth-auto680):02452 * ######>> screen 35 <<
2459 (fig-forth-auto680):02453 * ======>> 52 <<
2460 (fig-forth-auto680):02454 * ( --- 0 )
2461 1839 81 (fig-forth-auto680):02455 FCB $81
2462 183A B0 (fig-forth-auto680):02456 FCB $B0 0
2463 183B 1822 (fig-forth-auto680):02457 FDB USER-7
2464 183D 17E9 (fig-forth-auto680):02458 ZERO FDB DOCON
2465 183F 0000 (fig-forth-auto680):02459 FDB 0000
2466 (fig-forth-auto680):02460 *
2467 (fig-forth-auto680):02461 * ======>> 53 <<
2468 (fig-forth-auto680):02462 * ( --- 1 )
2469 1841 81 (fig-forth-auto680):02463 FCB $81
2470 1842 B1 (fig-forth-auto680):02464 FCB $B1 1
2471 1843 1839 (fig-forth-auto680):02465 FDB ZERO-4
2472 1845 17E9 (fig-forth-auto680):02466 ONE FDB DOCON
2473 1847 0001 (fig-forth-auto680):02467 ONEV FDB 1
2474 (fig-forth-auto680):02468 *
2475 (fig-forth-auto680):02469 * ======>> 54 <<
2476 (fig-forth-auto680):02470 * ( --- 2 )
2477 1849 81 (fig-forth-auto680):02471 FCB $81
2478 184A B2 (fig-forth-auto680):02472 FCB $B2 2
2479 184B 1841 (fig-forth-auto680):02473 FDB ONE-4
2480 184D 17E9 (fig-forth-auto680):02474 TWO FDB DOCON
2481 184F 0002 (fig-forth-auto680):02475 TWOV FDB 2
2482 (fig-forth-auto680):02476 *
2483 (fig-forth-auto680):02477 * ======>> 55 <<
2484 (fig-forth-auto680):02478 * ( --- 3 )
2485 1851 81 (fig-forth-auto680):02479 FCB $81
2486 1852 B3 (fig-forth-auto680):02480 FCB $B3 3
2487 1853 1849 (fig-forth-auto680):02481 FDB TWO-4
2488 1855 17E9 (fig-forth-auto680):02482 THREE FDB DOCON
2489 1857 0003 (fig-forth-auto680):02483 FDB 3
2490 (fig-forth-auto680):02484 *
2491 (fig-forth-auto680):02485 * ======>> 56 <<
2492 (fig-forth-auto680):02486 * ( --- SP )
2493 (fig-forth-auto680):02487 * ASCII SPACE character
2494 1859 82 (fig-forth-auto680):02488 FCB $82
2495 185A 42 (fig-forth-auto680):02489 FCC 'B' ; 'BL'
2496 185B CC (fig-forth-auto680):02490 FCB $CC
2497 185C 1851 (fig-forth-auto680):02491 FDB THREE-4
2498 185E 17E9 (fig-forth-auto680):02492 BL FDB DOCON ascii blank
2499 1860 0020 (fig-forth-auto680):02493 FDB $20
2500 (fig-forth-auto680):02494 *
2501 (fig-forth-auto680):02495 * ======>> 57 <<
2502 (fig-forth-auto680):02496 * This really shouldn't be a CONSTANT.
2503 (fig-forth-auto680):02497 * ( --- adr )
2504 (fig-forth-auto680):02498 * The base of the disk buffer space.
2505 1862 85 (fig-forth-auto680):02499 FCB $85
2506 1863 46495253 (fig-forth-auto680):02500 FCC 'FIRS' ; 'FIRST'
2507 1867 D4 (fig-forth-auto680):02501 FCB $D4
2508 1868 1859 (fig-forth-auto680):02502 FDB BL-5
2509 186A 17E9 (fig-forth-auto680):02503 FIRST FDB DOCON
2510 186C 6BE0 (fig-forth-auto680):02504 FDB BUFBAS
2511 (fig-forth-auto680):02505 * FDB MEMEND-528 (132 * NBLK)
2512 (fig-forth-auto680):02506 *
2513 (fig-forth-auto680):02507 * ======>> 58 <<
2514 (fig-forth-auto680):02508 * This really shouldn't be a CONSTANT.
2515 (fig-forth-auto680):02509 * ( --- adr )
2516 (fig-forth-auto680):02510 * The limit of the disk buffer space.
2517 186E 85 (fig-forth-auto680):02511 FCB $85
2518 186F 4C494D49 (fig-forth-auto680):02512 FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
2519 1873 D4 (fig-forth-auto680):02513 FCB $D4
2520 1874 1862 (fig-forth-auto680):02514 FDB FIRST-8
2521 1876 17E9 (fig-forth-auto680):02515 LIMIT FDB DOCON
2522 1878 7000 (fig-forth-auto680):02516 FDB BUFBAS+BUFSZ
2523 (fig-forth-auto680):02517 * In 6800 model, was
2524 (fig-forth-auto680):02518 * FDB MEMEND
2525 (fig-forth-auto680):02519 *
2526 (fig-forth-auto680):02520 * ======>> 59 <<
2527 (fig-forth-auto680):02521 * ( --- sectorsize )
2528 (fig-forth-auto680):02522 * The size, in bytes, of a buffer.
2529 187A 85 (fig-forth-auto680):02523 FCB $85
2530 187B 422F4255 (fig-forth-auto680):02524 FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
2531 187F C6 (fig-forth-auto680):02525 FCB $C6
2532 1880 186E (fig-forth-auto680):02526 FDB LIMIT-8
2533 1882 17E9 (fig-forth-auto680):02527 BBUF FDB DOCON
2534 1884 0100 (fig-forth-auto680):02528 FDB SECTSZ
2535 (fig-forth-auto680):02529 * Hardcoded in 6800 model:
2536 (fig-forth-auto680):02530 * FDB 128
2537 (fig-forth-auto680):02531 *
2538 (fig-forth-auto680):02532 * ======>> 60 <<
2539 (fig-forth-auto680):02533 * ( --- blocksperscreen )
2540 (fig-forth-auto680):02534 * The size, in blocks, of a screen.
2541 (fig-forth-auto680):02535 * Should this be the same as NBLK, the number of block buffers maintained?
2542 1886 85 (fig-forth-auto680):02536 FCB $85
2543 1887 422F5343 (fig-forth-auto680):02537 FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
2544 188B D2 (fig-forth-auto680):02538 FCB $D2
2545 188C 187A (fig-forth-auto680):02539 FDB BBUF-8
2546 188E 17E9 (fig-forth-auto680):02540 BSCR FDB DOCON
2547 1890 0004 (fig-forth-auto680):02541 FDB SCRSZ/SECTSZ
2548 (fig-forth-auto680):02542 * Hardcoded in 6800 model as:
2549 (fig-forth-auto680):02543 * FDB 8
2550 (fig-forth-auto680):02544 * blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
2551 (fig-forth-auto680):02545 *
2552 (fig-forth-auto680):02546 * ======>> 61 <<
2553 (fig-forth-auto680):02547 * ( n --- adr )
2554 (fig-forth-auto680):02548 * Calculate the address of entry (#n/2) in the boot-up parameter table.
2555 (fig-forth-auto680):02549 * (Adds the base of the boot-up table to n.)
2556 1892 87 (fig-forth-auto680):02550 FCB $87
2557 1893 2B4F52494749 (fig-forth-auto680):02551 FCC '+ORIGI' ; '+ORIGIN'
2558 1899 CE (fig-forth-auto680):02552 FCB $CE
2559 189A 1886 (fig-forth-auto680):02553 FDB BSCR-8
2560 189C 17B91399120016C6 (fig-forth-auto680):02554 PORIG FDB DOCOL,LIT,ORIG,PLUS
2561 18A4 1667 (fig-forth-auto680):02555 FDB SEMIS
2562 (fig-forth-auto680):02556 *
2563 (fig-forth-auto680):02557 * ######>> screen 36 <<
2564 (fig-forth-auto680):02558 * ======>> 62 <<
2565 (fig-forth-auto680):02559 * ( n --- adr )
2566 (fig-forth-auto680):02560 * This is the per-task variable recording the initial parameter stack pointer.
2567 18A6 82 (fig-forth-auto680):02561 FCB $82
2568 18A7 53 (fig-forth-auto680):02562 FCC 'S' ; 'S0'
2569 18A8 B0 (fig-forth-auto680):02563 FCB $B0
2570 18A9 1892 (fig-forth-auto680):02564 FDB PORIG-10
2571 18AB 182F (fig-forth-auto680):02565 SZERO FDB DOUSER
2572 18AD 001E (fig-forth-auto680):02566 FDB XSPZER-UORIG
2573 (fig-forth-auto680):02567 *
2574 (fig-forth-auto680):02568 * ======>> 63 <<
2575 (fig-forth-auto680):02569 * ( n --- adr )
2576 (fig-forth-auto680):02570 * This is the per-task variable recording the initial return stack pointer.
2577 18AF 82 (fig-forth-auto680):02571 FCB $82
2578 18B0 52 (fig-forth-auto680):02572 FCC 'R' ; 'R0'
2579 18B1 B0 (fig-forth-auto680):02573 FCB $B0
2580 18B2 18A6 (fig-forth-auto680):02574 FDB SZERO-5
2581 18B4 182F (fig-forth-auto680):02575 RZERO FDB DOUSER
2582 18B6 0020 (fig-forth-auto680):02576 FDB XRZERO-UORIG
2583 (fig-forth-auto680):02577 *
2584 (fig-forth-auto680):02578 * ======>> 64 <<
2585 (fig-forth-auto680):02579 * ( --- vadr )
2586 (fig-forth-auto680):02580 * Terminal Input Buffer address.
2587 (fig-forth-auto680):02581 * Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
2588 18B8 83 (fig-forth-auto680):02582 FCB $83
2589 18B9 5449 (fig-forth-auto680):02583 FCC 'TI' ; 'TIB'
2590 18BB C2 (fig-forth-auto680):02584 FCB $C2
2591 18BC 18AF (fig-forth-auto680):02585 FDB RZERO-5
2592 18BE 182F (fig-forth-auto680):02586 TIB FDB DOUSER
2593 18C0 0022 (fig-forth-auto680):02587 FDB XTIB-UORIG
2594 (fig-forth-auto680):02588 *
2595 (fig-forth-auto680):02589 * ======>> 65 <<
2596 (fig-forth-auto680):02590 * ( --- maxnamewidth )
2597 (fig-forth-auto680):02591 * This is the maximum width to which symbol names will be recorded.
2598 18C2 85 (fig-forth-auto680):02592 FCB $85
2599 18C3 57494454 (fig-forth-auto680):02593 FCC 'WIDT' ; 'WIDTH'
2600 18C7 C8 (fig-forth-auto680):02594 FCB $C8
2601 18C8 18B8 (fig-forth-auto680):02595 FDB TIB-6
2602 18CA 182F (fig-forth-auto680):02596 WIDTH FDB DOUSER
2603 18CC 0024 (fig-forth-auto680):02597 FDB XWIDTH-UORIG
2604 (fig-forth-auto680):02598 *
2605 (fig-forth-auto680):02599 * ======>> 66 <<
2606 (fig-forth-auto680):02600 * ( --- vadr )
2607 (fig-forth-auto680):02601 * Availability of error messages on disk.
2608 (fig-forth-auto680):02602 * Contains 1 if messages available,
2609 (fig-forth-auto680):02603 * 0 if not,
2610 (fig-forth-auto680):02604 * -1 if a disk error has occurred.
2611 18CE 87 (fig-forth-auto680):02605 FCB $87
2612 18CF 5741524E494E (fig-forth-auto680):02606 FCC 'WARNIN' ; 'WARNING'
2613 18D5 C7 (fig-forth-auto680):02607 FCB $C7
2614 18D6 18C2 (fig-forth-auto680):02608 FDB WIDTH-8
2615 18D8 182F (fig-forth-auto680):02609 WARN FDB DOUSER
2616 18DA 0026 (fig-forth-auto680):02610 FDB XWARN-UORIG
2617 (fig-forth-auto680):02611 *
2618 (fig-forth-auto680):02612 * ======>> 67 <<
2619 (fig-forth-auto680):02613 * ( --- vadr )
2620 (fig-forth-auto680):02614 * Boundary for FORGET.
2621 18DC 85 (fig-forth-auto680):02615 FCB $85
2622 18DD 46454E43 (fig-forth-auto680):02616 FCC 'FENC' ; 'FENCE'
2623 18E1 C5 (fig-forth-auto680):02617 FCB $C5
2624 18E2 18CE (fig-forth-auto680):02618 FDB WARN-10
2625 18E4 182F (fig-forth-auto680):02619 FENCE FDB DOUSER
2626 18E6 0028 (fig-forth-auto680):02620 FDB XFENCE-UORIG
2627 (fig-forth-auto680):02621 *
2628 (fig-forth-auto680):02622 * ======>> 68 <<
2629 (fig-forth-auto680):02623 * ( --- vadr )
2630 (fig-forth-auto680):02624 * Dictionary pointer, fetched by HERE.
2631 18E8 82 (fig-forth-auto680):02625 FCB $82
2632 18E9 44 (fig-forth-auto680):02626 FCC 'D' ; 'DP' : points to first free byte at end of dictionary
2633 18EA D0 (fig-forth-auto680):02627 FCB $D0
2634 18EB 18DC (fig-forth-auto680):02628 FDB FENCE-8
2635 18ED 182F (fig-forth-auto680):02629 DICTPT FDB DOUSER
2636 18EF 002A (fig-forth-auto680):02630 FDB XDICTP-UORIG
2637 (fig-forth-auto680):02631 *
2638 (fig-forth-auto680):02632 * ======>> 68.5 <<
2639 (fig-forth-auto680):02633 * ( --- vadr ) ******* Need to check what this is!
2640 (fig-forth-auto680):02634 * Used in maintaining vocabularies.
2641 (fig-forth-auto680):02635 * I think it points to the "parent" vocabulary, but I'm not sure.
2642 (fig-forth-auto680):02636 * Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
2643 18F1 88 (fig-forth-auto680):02637 FCB $88
2644 18F2 564F432D4C494E (fig-forth-auto680):02638 FCC 'VOC-LIN' ; 'VOC-LINK'
2645 18F9 CB (fig-forth-auto680):02639 FCB $CB
2646 18FA 18E8 (fig-forth-auto680):02640 FDB DICTPT-5
2647 18FC 182F (fig-forth-auto680):02641 VOCLIN FDB DOUSER
2648 18FE 002C (fig-forth-auto680):02642 FDB XVOCL-UORIG
2649 (fig-forth-auto680):02643 *
2650 (fig-forth-auto680):02644 * ======>> 69 <<
2651 (fig-forth-auto680):02645 * ( --- vadr )
2652 (fig-forth-auto680):02646 * Disk block being interpreted.
2653 (fig-forth-auto680):02647 * Zero refers to terminal.
2654 (fig-forth-auto680):02648 * ******** Should be made a 32 bit user variable! ********
2655 (fig-forth-auto680):02649 * But the base system needs to have full 32 bit support, div and mul, etc.
2656 (fig-forth-auto680):02650 * before we can do that.
2657 1900 83 (fig-forth-auto680):02651 FCB $83
2658 1901 424C (fig-forth-auto680):02652 FCC 'BL' ; 'BLK'
2659 1903 CB (fig-forth-auto680):02653 FCB $CB
2660 1904 18F1 (fig-forth-auto680):02654 FDB VOCLIN-11
2661 1906 182F (fig-forth-auto680):02655 BLK FDB DOUSER
2662 1908 002E (fig-forth-auto680):02656 FDB XBLK-UORIG
2663 (fig-forth-auto680):02657 *
2664 (fig-forth-auto680):02658 * ======>> 70 <<
2665 (fig-forth-auto680):02659 * ( --- vadr )
2666 (fig-forth-auto680):02660 * Input buffer offset/cursor.
2667 190A 82 (fig-forth-auto680):02661 FCB $82
2668 190B 49 (fig-forth-auto680):02662 FCC 'I' ; 'IN' : scan pointer for input line buffer
2669 190C CE (fig-forth-auto680):02663 FCB $CE
2670 190D 1900 (fig-forth-auto680):02664 FDB BLK-6
2671 190F 182F (fig-forth-auto680):02665 IN FDB DOUSER
2672 1911 0030 (fig-forth-auto680):02666 FDB XIN-UORIG
2673 (fig-forth-auto680):02667 *
2674 (fig-forth-auto680):02668 * ======>> 71 <<
2675 (fig-forth-auto680):02669 * ( --- vadr )
2676 (fig-forth-auto680):02670 * Output buffer offset/cursor.
2677 1913 83 (fig-forth-auto680):02671 FCB $83
2678 1914 4F55 (fig-forth-auto680):02672 FCC 'OU' ; 'OUT'
2679 1916 D4 (fig-forth-auto680):02673 FCB $D4
2680 1917 190A (fig-forth-auto680):02674 FDB IN-5
2681 1919 182F (fig-forth-auto680):02675 OUT FDB DOUSER
2682 191B 0032 (fig-forth-auto680):02676 FDB XOUT-UORIG
2683 (fig-forth-auto680):02677 *
2684 (fig-forth-auto680):02678 * ======>> 72 <<
2685 (fig-forth-auto680):02679 * ( --- vadr )
2686 (fig-forth-auto680):02680 * Screen currently being edited, once we have an editor running.
2687 191D 83 (fig-forth-auto680):02681 FCB $83
2688 191E 5343 (fig-forth-auto680):02682 FCC 'SC' ; 'SCR'
2689 1920 D2 (fig-forth-auto680):02683 FCB $D2
2690 1921 1913 (fig-forth-auto680):02684 FDB OUT-6
2691 1923 182F (fig-forth-auto680):02685 SCR FDB DOUSER
2692 1925 0034 (fig-forth-auto680):02686 FDB XSCR-UORIG
2693 (fig-forth-auto680):02687 * ######>> screen 37 <<
2694 (fig-forth-auto680):02688 *
2695 (fig-forth-auto680):02689 * ======>> 73 <<
2696 (fig-forth-auto680):02690 * ( --- vadr )
2697 (fig-forth-auto680):02691 * Sector offset for LOADing screens,
2698 (fig-forth-auto680):02692 * set by DRIVE to make a new drive the default.
2699 (fig-forth-auto680):02693 * This should also be 32 bit or bigger.
2700 1927 86 (fig-forth-auto680):02694 FCB $86
2701 1928 4F46465345 (fig-forth-auto680):02695 FCC 'OFFSE' ; 'OFFSET'
2702 192D D4 (fig-forth-auto680):02696 FCB $D4
2703 192E 191D (fig-forth-auto680):02697 FDB SCR-6
2704 1930 182F (fig-forth-auto680):02698 OFSET FDB DOUSER
2705 1932 0036 (fig-forth-auto680):02699 FDB XOFSET-UORIG
2706 (fig-forth-auto680):02700 *
2707 (fig-forth-auto680):02701 * ======>> 74 <<
2708 (fig-forth-auto680):02702 * ( --- vadr )
2709 (fig-forth-auto680):02703 * Current context of interpretation (vocabulary root).
2710 1934 87 (fig-forth-auto680):02704 FCB $87
2711 1935 434F4E544558 (fig-forth-auto680):02705 FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
2712 193B D4 (fig-forth-auto680):02706 FCB $D4
2713 193C 1927 (fig-forth-auto680):02707 FDB OFSET-9
2714 193E 182F (fig-forth-auto680):02708 CONTXT FDB DOUSER
2715 1940 0038 (fig-forth-auto680):02709 FDB XCONT-UORIG
2716 (fig-forth-auto680):02710 *
2717 (fig-forth-auto680):02711 * ======>> 75 <<
2718 (fig-forth-auto680):02712 * ( --- vadr )
2719 (fig-forth-auto680):02713 * Current context of definition (vocabulary root).
2720 1942 87 (fig-forth-auto680):02714 FCB $87
2721 1943 43555252454E (fig-forth-auto680):02715 FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
2722 1949 D4 (fig-forth-auto680):02716 FCB $D4
2723 194A 1934 (fig-forth-auto680):02717 FDB CONTXT-10
2724 194C 182F (fig-forth-auto680):02718 CURENT FDB DOUSER
2725 194E 003A (fig-forth-auto680):02719 FDB XCURR-UORIG
2726 (fig-forth-auto680):02720 *
2727 (fig-forth-auto680):02721 * ======>> 76 <<
2728 (fig-forth-auto680):02722 * ( --- vadr )
2729 (fig-forth-auto680):02723 * Compiler/interpreter state.
2730 1950 85 (fig-forth-auto680):02724 FCB $85
2731 1951 53544154 (fig-forth-auto680):02725 FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
2732 1955 C5 (fig-forth-auto680):02726 FCB $C5
2733 1956 1942 (fig-forth-auto680):02727 FDB CURENT-10
2734 1958 182F (fig-forth-auto680):02728 STATE FDB DOUSER
2735 195A 003C (fig-forth-auto680):02729 FDB XSTATE-UORIG
2736 (fig-forth-auto680):02730 *
2737 (fig-forth-auto680):02731 * ======>> 77 <<
2738 (fig-forth-auto680):02732 * ( --- vadr )
2739 (fig-forth-auto680):02733 * Numeric conversion base.
2740 195C 84 (fig-forth-auto680):02734 FCB $84
2741 195D 424153 (fig-forth-auto680):02735 FCC 'BAS' ; 'BASE' : number base for all input & output
2742 1960 C5 (fig-forth-auto680):02736 FCB $C5
2743 1961 1950 (fig-forth-auto680):02737 FDB STATE-8
2744 1963 182F (fig-forth-auto680):02738 BASE FDB DOUSER
2745 1965 003E (fig-forth-auto680):02739 FDB XBASE-UORIG
2746 (fig-forth-auto680):02740 *
2747 (fig-forth-auto680):02741 * ======>> 78 <<
2748 (fig-forth-auto680):02742 * ( --- vadr )
2749 (fig-forth-auto680):02743 * Decimal point location for output.
2750 1967 83 (fig-forth-auto680):02744 FCB $83
2751 1968 4450 (fig-forth-auto680):02745 FCC 'DP' ; 'DPL'
2752 196A CC (fig-forth-auto680):02746 FCB $CC
2753 196B 195C (fig-forth-auto680):02747 FDB BASE-7
2754 196D 182F (fig-forth-auto680):02748 DPL FDB DOUSER
2755 196F 0040 (fig-forth-auto680):02749 FDB XDPL-UORIG
2756 (fig-forth-auto680):02750 *
2757 (fig-forth-auto680):02751 * ======>> 79 <<
2758 (fig-forth-auto680):02752 * ( --- vadr )
2759 (fig-forth-auto680):02753 * Field width for I/O formatting.
2760 1971 83 (fig-forth-auto680):02754 FCB $83
2761 1972 464C (fig-forth-auto680):02755 FCC 'FL' ; 'FLD'
2762 1974 C4 (fig-forth-auto680):02756 FCB $C4
2763 1975 1967 (fig-forth-auto680):02757 FDB DPL-6
2764 1977 182F (fig-forth-auto680):02758 FLD FDB DOUSER
2765 1979 0042 (fig-forth-auto680):02759 FDB XFLD-UORIG
2766 (fig-forth-auto680):02760 *
2767 (fig-forth-auto680):02761 * ======>> 80 <<
2768 (fig-forth-auto680):02762 * ( --- vadr )
2769 (fig-forth-auto680):02763 * Compiler stack mark for stack check.
2770 197B 83 (fig-forth-auto680):02764 FCB $83
2771 197C 4353 (fig-forth-auto680):02765 FCC 'CS' ; 'CSP'
2772 197E D0 (fig-forth-auto680):02766 FCB $D0
2773 197F 1971 (fig-forth-auto680):02767 FDB FLD-6
2774 1981 182F (fig-forth-auto680):02768 CSP FDB DOUSER
2775 1983 0044 (fig-forth-auto680):02769 FDB XCSP-UORIG
2776 (fig-forth-auto680):02770 *
2777 (fig-forth-auto680):02771 * ======>> 81 <<
2778 (fig-forth-auto680):02772 * ( --- vadr )
2779 (fig-forth-auto680):02773 * Editing cursor location.
2780 1985 82 (fig-forth-auto680):02774 FCB $82
2781 1986 52 (fig-forth-auto680):02775 FCC 'R' ; 'R#'
2782 1987 A3 (fig-forth-auto680):02776 FCB $A3
2783 1988 197B (fig-forth-auto680):02777 FDB CSP-6
2784 198A 182F (fig-forth-auto680):02778 RNUM FDB DOUSER
2785 198C 0046 (fig-forth-auto680):02779 FDB XRNUM-UORIG
2786 (fig-forth-auto680):02780 *
2787 (fig-forth-auto680):02781 * ======>> 82 <<
2788 (fig-forth-auto680):02782 * ( --- vadr )
2789 (fig-forth-auto680):02783 * Pointer to last HELD character in PAD.
2790 198E 83 (fig-forth-auto680):02784 FCB $83
2791 198F 484C (fig-forth-auto680):02785 FCC 'HL' ; 'HLD'
2792 1991 C4 (fig-forth-auto680):02786 FCB $C4
2793 1992 1985 (fig-forth-auto680):02787 FDB RNUM-5
2794 1994 17E9 (fig-forth-auto680):02788 HLD FDB DOCON
2795 1996 7C48 (fig-forth-auto680):02789 FDB XHLD
2796 (fig-forth-auto680):02790 *
2797 (fig-forth-auto680):02791 * ======>> 82.5 <<== SPECIAL
2798 (fig-forth-auto680):02792 * ( --- vadr )
2799 (fig-forth-auto680):02793 * Line width of active terminal.
2800 1998 87 (fig-forth-auto680):02794 FCB $87
2801 1999 434F4C554D4E (fig-forth-auto680):02795 FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
2802 199F D3 (fig-forth-auto680):02796 FCB $D3
2803 19A0 198E (fig-forth-auto680):02797 FDB HLD-6
2804 19A2 182F (fig-forth-auto680):02798 COLUMS FDB DOUSER
2805 19A4 004C (fig-forth-auto680):02799 FDB XCOLUM-UORIG
2806 (fig-forth-auto680):02800 *
2807 (fig-forth-auto680):02801 * ######>> screen 38 <<
2808 (fig-forth-auto680):02802 **
2809 (fig-forth-auto680):02803 ** An INCREMENTER probably should not be defined without a defined CONSTANT?
2810 (fig-forth-auto680):02804 **
2811 (fig-forth-auto680):02805 ** Make an INCREMENTER compiling word (not in model):
2812 (fig-forth-auto680):02806 ** ( n --- )
2813 (fig-forth-auto680):02807 ** { n INCREMENTER name } typical input
2814 (fig-forth-auto680):02808 ** CREATE a header and compile the increment constant,
2815 (fig-forth-auto680):02809 ** then overwrite the header with a call to DOINC.
2816 (fig-forth-auto680):02810 * FCB $8B
2817 (fig-forth-auto680):02811 * FCC 'INCREMENTE' ; 'INCREMENTER'
2818 (fig-forth-auto680):02812 * FCB $D2
2819 (fig-forth-auto680):02813 * FDB COLUMS-10
2820 (fig-forth-auto680):02814 * INCR FDB DOCOL,CON,PSCODE
2821 (fig-forth-auto680):02815 ** ( n --- ninc )
2822 (fig-forth-auto680):02816 ** Characteristic of an INCREMENTER.
2823 (fig-forth-auto680):02817 ** This is too naive:
2824 (fig-forth-auto680):02818 * DOINC LDD ,U
2825 (fig-forth-auto680):02819 * ADDD NATWID,X ; Add the increment.
2826 (fig-forth-auto680):02820 * STD ,U
2827 (fig-forth-auto680):02821 * RTS
2828 (fig-forth-auto680):02822 * Compiling word should check that it is compiling a CONSTANT.
2829 (fig-forth-auto680):02823 *
2830 (fig-forth-auto680):02824 * ======>> 83 <<
2831 (fig-forth-auto680):02825 * ( n --- n+1 )
2832 19A6 82 (fig-forth-auto680):02826 FCB $82
2833 19A7 31 (fig-forth-auto680):02827 FCC '1' ; '1+'
2834 19A8 AB (fig-forth-auto680):02828 FCB $AB
2835 19A9 1998 (fig-forth-auto680):02829 FDB COLUMS-10
2836 (fig-forth-auto680):02830 * Using the model keeps things semantically connected for other processors:
2837 19AB 17B9184516C6 (fig-forth-auto680):02831 ONEP FDB DOCOL,ONE,PLUS
2838 19B1 1667 (fig-forth-auto680):02832 FDB SEMIS
2839 (fig-forth-auto680):02833 ** Greedy alternative:
2840 (fig-forth-auto680):02834 * ONEP FDB *+NATWID
2841 (fig-forth-auto680):02835 * LDD ,U
2842 (fig-forth-auto680):02836 * ADDD ONEV,PCR
2843 (fig-forth-auto680):02837 * STD ,U
2844 (fig-forth-auto680):02838 * RTS
2845 (fig-forth-auto680):02839 * Naive alternative:
2846 (fig-forth-auto680):02840 * ONEP FDB DOINC
2847 (fig-forth-auto680):02841 * FDB 1
2848 (fig-forth-auto680):02842 * Naive alternative:
2849 (fig-forth-auto680):02843 * ONEP FDB *+NATWID
2850 (fig-forth-auto680):02844 * LDD ,U
2851 (fig-forth-auto680):02845 * ADDD #1 ; It's hard to imagine 1+ being other than 1.
2852 (fig-forth-auto680):02846 * STD ,U
2853 (fig-forth-auto680):02847 * RTS
2854 (fig-forth-auto680):02848 *
2855 (fig-forth-auto680):02849 * ======>> 84 <<
2856 (fig-forth-auto680):02850 * ( n --- n+2 )
2857 19B3 82 (fig-forth-auto680):02851 FCB $82
2858 19B4 32 (fig-forth-auto680):02852 FCC '2' ; '2+'
2859 19B5 AB (fig-forth-auto680):02853 FCB $AB
2860 19B6 19A6 (fig-forth-auto680):02854 FDB ONEP-5
2861 (fig-forth-auto680):02855 * Using the model keeps things semantically connected for other processors:
2862 19B8 17B9184D16C6 (fig-forth-auto680):02856 TWOP FDB DOCOL,TWO,PLUS
2863 19BE 1667 (fig-forth-auto680):02857 FDB SEMIS
2864 (fig-forth-auto680):02858 ** Greedy alternative:
2865 (fig-forth-auto680):02859 * TWOP FDB *+NATWID
2866 (fig-forth-auto680):02860 * LDD ,U
2867 (fig-forth-auto680):02861 * ADDD TWOV,PCR ; See NAT+ (NATP)
2868 (fig-forth-auto680):02862 * STD ,U
2869 (fig-forth-auto680):02863 * RTS
2870 (fig-forth-auto680):02864 * Naive alternative:
2871 (fig-forth-auto680):02865 * TWOP FDB DOINC
2872 (fig-forth-auto680):02866 * FDB 2
2873 (fig-forth-auto680):02867 * Naive alternative:
2874 (fig-forth-auto680):02868 * TWOP FDB *+NATWID
2875 (fig-forth-auto680):02869 * LDD ,U
2876 (fig-forth-auto680):02870 * ADDD #2 ; See NAT+ (NATP)
2877 (fig-forth-auto680):02871 * STD ,U
2878 (fig-forth-auto680):02872 * RTS
2879 (fig-forth-auto680):02873 *
2880 (fig-forth-auto680):02874 * ======>> 85 <<
2881 (fig-forth-auto680):02875 * ( --- adr )
2882 (fig-forth-auto680):02876 * Get the DICTPT allocation, like a USER constant.
2883 (fig-forth-auto680):02877 * Should check the stack and heap for collision.
2884 19C0 84 (fig-forth-auto680):02878 FCB $84
2885 19C1 484552 (fig-forth-auto680):02879 FCC 'HER' ; 'HERE'
2886 19C4 C5 (fig-forth-auto680):02880 FCB $C5
2887 19C5 19B3 (fig-forth-auto680):02881 FDB TWOP-5
2888 19C7 17B918ED1772 (fig-forth-auto680):02882 HERE FDB DOCOL,DICTPT,AT
2889 19CD 1667 (fig-forth-auto680):02883 FDB SEMIS
2890 (fig-forth-auto680):02884 *
2891 (fig-forth-auto680):02885 * ======>> 86 <<
2892 (fig-forth-auto680):02886 * ( n --- )
2893 (fig-forth-auto680):02887 * Increase/decrease heap (add n to DP),
2894 (fig-forth-auto680):02888 * Should ERROR check stack/heap.
2895 19CF 85 (fig-forth-auto680):02889 FCB $85
2896 19D0 414C4C4F (fig-forth-auto680):02890 FCC 'ALLO' ; 'ALLOT'
2897 19D4 D4 (fig-forth-auto680):02891 FCB $D4
2898 19D5 19C0 (fig-forth-auto680):02892 FDB HERE-7
2899 19D7 17B918ED1751 (fig-forth-auto680):02893 ALLOT FDB DOCOL,DICTPT,PSTORE
2900 19DD 1667 (fig-forth-auto680):02894 FDB SEMIS
2901 (fig-forth-auto680):02895 *
2902 (fig-forth-auto680):02896 * ======>> 87 <<
2903 (fig-forth-auto680):02897 * ( n --- )
2904 (fig-forth-auto680):02898 * Store word n at DP++,
2905 (fig-forth-auto680):02899 * Should ERROR check stack/heap.
2906 19DF 81 (fig-forth-auto680):02900 FCB $81 ; , (COMMA)
2907 19E0 AC (fig-forth-auto680):02901 FCB $AC
2908 19E1 19CF (fig-forth-auto680):02902 FDB ALLOT-8
2909 19E3 17B919C7178A17F7 (fig-forth-auto680):02903 COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
2911 19ED 1667 (fig-forth-auto680):02904 FDB SEMIS
2912 (fig-forth-auto680):02905 * COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
2913 (fig-forth-auto680):02906 * FDB SEMIS
2914 (fig-forth-auto680):02907 *
2915 (fig-forth-auto680):02908 * ======>> 88 <<
2916 (fig-forth-auto680):02909 * ( b --- )
2917 (fig-forth-auto680):02910 * Store byte b at DP+,
2918 (fig-forth-auto680):02911 * Should ERROR check stack/heap.
2919 19EF 82 (fig-forth-auto680):02912 FCB $82
2920 19F0 43 (fig-forth-auto680):02913 FCC 'C' ; 'C,'
2921 19F1 AC (fig-forth-auto680):02914 FCB $AC
2922 19F2 19DF (fig-forth-auto680):02915 FDB COMMA-4
2923 19F4 17B919C717981845 (fig-forth-auto680):02916 CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
2925 19FE 1667 (fig-forth-auto680):02917 FDB SEMIS
2926 (fig-forth-auto680):02918 *
2927 (fig-forth-auto680):02919 * ======>> 89 <<
2928 (fig-forth-auto680):02920 * ( n1 n2 --- n1-n2 )
2929 (fig-forth-auto680):02921 * Subtract top two words.
2930 1A00 81 (fig-forth-auto680):02922 FCB $81 ; -
2931 1A01 AD (fig-forth-auto680):02923 FCB $AD
2932 1A02 19EF (fig-forth-auto680):02924 FDB CCOMM-5
2933 1A04 1A06 (fig-forth-auto680):02925 SUB FDB *+NATWID
2934 1A06 EC42 (fig-forth-auto680):02926 LDD NATWID,U ; #2~6
2935 1A08 A3C1 (fig-forth-auto680):02927 SUBD ,U++ ; #2~9
2936 1A0A EDC4 (fig-forth-auto680):02928 STD ,U ; #2~5
2937 1A0C 39 (fig-forth-auto680):02929 RTS ; #1~5 = #7~25
2938 (fig-forth-auto680):02930 * SUB FDB DOCOL,MINUS,PLUS
2939 (fig-forth-auto680):02931 * FDB SEMIS ; Costs 6 bytes and lots of cycles.
2940 (fig-forth-auto680):02932 *
2941 (fig-forth-auto680):02933 * ======>> 90 <<
2942 (fig-forth-auto680):02934 * ( n1 n2 --- n1==n2 )
2943 (fig-forth-auto680):02935 * Return flag true if n1 and n2 are equal, otherwise false.
2944 1A0D 81 (fig-forth-auto680):02936 FCB $81 =
2945 1A0E BD (fig-forth-auto680):02937 FCB $BD
2946 1A0F 1A00 (fig-forth-auto680):02938 FDB SUB-4
2947 1A11 17B91A0416A3 (fig-forth-auto680):02939 EQUAL FDB DOCOL,SUB,ZEQU
2948 1A17 1667 (fig-forth-auto680):02940 FDB SEMIS
2949 (fig-forth-auto680):02941 *
2950 (fig-forth-auto680):02942 * ======>> 91 <<
2951 (fig-forth-auto680):02943 * ( n1 n2 --- n1<n2 )
2952 (fig-forth-auto680):02944 * Return flag true if n1 is less than n2, otherwise false.
2953 1A19 81 (fig-forth-auto680):02945 FCB $81 <
2954 1A1A BC (fig-forth-auto680):02946 FCB $BC
2955 1A1B 1A0D (fig-forth-auto680):02947 FDB EQUAL-4
2956 1A1D 1A1F (fig-forth-auto680):02948 LESS FDB *+NATWID
2957 1A1F EC42 (fig-forth-auto680):02949 LDD NATWID,U
2958 1A21 A3C1 (fig-forth-auto680):02950 SUBD ,U++
2959 1A23 2C06 (fig-forth-auto680):02951 BGE FALSE
2960 1A25 CC0001 (fig-forth-auto680):02952 TRUE LDD #1
2961 1A28 EDC4 (fig-forth-auto680):02953 STD ,U
2962 1A2A 39 (fig-forth-auto680):02954 RTS
2963 1A2B CC0000 (fig-forth-auto680):02955 FALSE LDD #0
2964 1A2E EDC4 (fig-forth-auto680):02956 STD ,U
2965 1A30 39 (fig-forth-auto680):02957 RTS
2966 (fig-forth-auto680):02958 * PULS A ;
2967 (fig-forth-auto680):02959 * PULS B ;
2968 (fig-forth-auto680):02960 * TFR S,X ; TSX :
2969 (fig-forth-auto680):02961 * CMPA 0,X
2970 (fig-forth-auto680):02962 * LEAS 1,S ;
2971 (fig-forth-auto680):02963 * BGT LESST
2972 (fig-forth-auto680):02964 * BNE LESSF
2973 (fig-forth-auto680):02965 * CMPB 1,X ; Why not sub, sbc, bge?
2974 (fig-forth-auto680):02966 * BHI LESST
2975 (fig-forth-auto680):02967 * LESSF CLRB ;
2976 (fig-forth-auto680):02968 * BRA LESSX
2977 (fig-forth-auto680):02969 * LESST LDB #1
2978 (fig-forth-auto680):02970 * LESSX CLRA ;
2979 (fig-forth-auto680):02971 * LEAS 1,S ;
2980 (fig-forth-auto680):02972 * JMP PUSHBA
2981 (fig-forth-auto680):02973 *
2982 (fig-forth-auto680):02974 * ======>> 92 <<
2983 (fig-forth-auto680):02975 * ( n1 n2 --- n1>n2 )
2984 (fig-forth-auto680):02976 * Return flag true if n1 is greater than n2, false otherwise.
2985 1A31 81 (fig-forth-auto680):02977 FCB $81 >
2986 1A32 BE (fig-forth-auto680):02978 FCB $BE
2987 1A33 1A19 (fig-forth-auto680):02979 FDB LESS-4
2988 1A35 17B917361A1D (fig-forth-auto680):02980 GREAT FDB DOCOL,SWAP,LESS
2989 1A3B 1667 (fig-forth-auto680):02981 FDB SEMIS
2990 (fig-forth-auto680):02982 *
2991 (fig-forth-auto680):02983 * ======>> 93 <<
2992 (fig-forth-auto680):02984 * ( n1 n2 n3 --- n2 n3 n1 )
2993 (fig-forth-auto680):02985 * Rotate the top three words on stack,
2994 (fig-forth-auto680):02986 * bringing the third word to the top.
2995 1A3D 83 (fig-forth-auto680):02987 FCB $83
2996 1A3E 524F (fig-forth-auto680):02988 FCC 'RO' ; 'ROT'
2997 1A40 D4 (fig-forth-auto680):02989 FCB $D4
2998 1A41 1A31 (fig-forth-auto680):02990 FDB GREAT-4
2999 1A43 1A45 (fig-forth-auto680):02991 ROT FDB *+NATWID
3000 1A45 3420 (fig-forth-auto680):02992 PSHS Y
3001 1A47 3736 (fig-forth-auto680):02993 PULU D,X,Y
3002 1A49 3616 (fig-forth-auto680):02994 PSHU D,X
3003 1A4B 3620 (fig-forth-auto680):02995 PSHU Y
3004 1A4D 35A0 (fig-forth-auto680):02996 PULS Y,PC
3005 (fig-forth-auto680):02997 * ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
3006 (fig-forth-auto680):02998 * FDB SEMIS
3007 (fig-forth-auto680):02999 *
3008 (fig-forth-auto680):03000 * ======>> 94 <<
3009 (fig-forth-auto680):03001 * ( --- )
3010 (fig-forth-auto680):03002 * EMIT a SPACE.
3011 1A4F 85 (fig-forth-auto680):03003 FCB $85
3012 1A50 53504143 (fig-forth-auto680):03004 FCC 'SPAC' ; 'SPACE'
3013 1A54 C5 (fig-forth-auto680):03005 FCB $C5
3014 1A55 1A3D (fig-forth-auto680):03006 FDB ROT-6
3015 1A57 17B9185E1542 (fig-forth-auto680):03007 SPACE FDB DOCOL,BL,EMIT
3016 1A5D 1667 (fig-forth-auto680):03008 FDB SEMIS
3017 (fig-forth-auto680):03009 *
3018 (fig-forth-auto680):03010 * ======>> 95 <<
3019 (fig-forth-auto680):03011 * ( n0 n1 --- min(n0,n1) )
3020 (fig-forth-auto680):03012 * Leave the minimum of the top two integers.
3021 (fig-forth-auto680):03013 * Being too greedy here, but, whatever.
3022 1A5F 83 (fig-forth-auto680):03014 FCB $83
3023 1A60 4D49 (fig-forth-auto680):03015 FCC 'MI' ; 'MIN'
3024 1A62 CE (fig-forth-auto680):03016 FCB $CE
3025 1A63 1A4F (fig-forth-auto680):03017 FDB SPACE-8
3026 1A65 1A67 (fig-forth-auto680):03018 MIN FDB *+NATWID
3027 1A67 3706 (fig-forth-auto680):03019 PULU D
3028 1A69 10A3C4 (fig-forth-auto680):03020 CMPD ,U
3029 1A6C 2F02 (fig-forth-auto680):03021 BLE MINX
3030 1A6E EDC4 (fig-forth-auto680):03022 STD ,U
3031 1A70 39 (fig-forth-auto680):03023 MINX RTS
3032 (fig-forth-auto680):03024 * MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
3033 (fig-forth-auto680):03025 * FDB MIN2-*-NATWID
3034 (fig-forth-auto680):03026 * FDB SWAP
3035 (fig-forth-auto680):03027 * MIN2 FDB DROP
3036 (fig-forth-auto680):03028 * FDB SEMIS
3037 (fig-forth-auto680):03029 *
3038 (fig-forth-auto680):03030 * ======>> 96 <<
3039 (fig-forth-auto680):03031 * ( n0 n1 --- max(n0,n1) )
3040 (fig-forth-auto680):03032 * Leave the maximum of the top two integers.
3041 (fig-forth-auto680):03033 * Really should leave this as in the model.
3042 1A71 83 (fig-forth-auto680):03034 FCB $83
3043 1A72 4D41 (fig-forth-auto680):03035 FCC 'MA' ; 'MAX'
3044 1A74 D8 (fig-forth-auto680):03036 FCB $D8
3045 1A75 1A5F (fig-forth-auto680):03037 FDB MIN-6
3046 1A77 1A79 (fig-forth-auto680):03038 MAX FDB *+NATWID
3047 1A79 3706 (fig-forth-auto680):03039 PULU D
3048 1A7B 10A3C4 (fig-forth-auto680):03040 CMPD ,U
3049 1A7E 2F02 (fig-forth-auto680):03041 BLE MAXX
3050 1A80 EDC4 (fig-forth-auto680):03042 STD ,U
3051 1A82 39 (fig-forth-auto680):03043 MAXX RTS
3052 (fig-forth-auto680):03044 * MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
3053 (fig-forth-auto680):03045 * FDB MAX2-*-NATWID
3054 (fig-forth-auto680):03046 * FDB SWAP
3055 (fig-forth-auto680):03047 * MAX2 FDB DROP
3056 (fig-forth-auto680):03048 * FDB SEMIS
3057 (fig-forth-auto680):03049 *
3058 (fig-forth-auto680):03050 * ======>> 97 <<
3059 (fig-forth-auto680):03051 * ( 0 --- 0 )
3060 (fig-forth-auto680):03052 * ( n --- n n )
3061 (fig-forth-auto680):03053 * DUP if non-zero.
3062 1A83 84 (fig-forth-auto680):03054 FCB $84
3063 1A84 2D4455 (fig-forth-auto680):03055 FCC '-DU' ; '-DUP'
3064 1A87 D0 (fig-forth-auto680):03056 FCB $D0
3065 1A88 1A71 (fig-forth-auto680):03057 FDB MAX-6
3066 1A8A 1A8C (fig-forth-auto680):03058 DDUP FDB *+NATWID
3067 1A8C ECC4 (fig-forth-auto680):03059 LDD ,U
3068 1A8E 2702 (fig-forth-auto680):03060 BEQ DDUPX
3069 1A90 3606 (fig-forth-auto680):03061 PSHU D
3070 1A92 39 (fig-forth-auto680):03062 DDUPX RTS
3071 (fig-forth-auto680):03063 * DDUP FDB DOCOL,DUP,ZBRAN
3072 (fig-forth-auto680):03064 * FDB DDUP2-*-NATWID
3073 (fig-forth-auto680):03065 * FDB DUP
3074 (fig-forth-auto680):03066 * DDUP2 FDB SEMIS
3075 (fig-forth-auto680):03067 *
3076 (fig-forth-auto680):03068 * ######>> screen 39 <<
3077 (fig-forth-auto680):03069 * ======>> 98.1 <<
3078 (fig-forth-auto680):03070 * Supplemental:
3079 (fig-forth-auto680):03071 * ( n<0 --- -1 )
3080 (fig-forth-auto680):03072 * ( n>=~ --- 1 )
3081 (fig-forth-auto680):03073 * Change top integer to its sign.
3082 1A93 86 (fig-forth-auto680):03074 FCB $86
3083 1A94 5349474E55 (fig-forth-auto680):03075 FCC 'SIGNU' ; 'SIGNUM'
3084 1A99 CD (fig-forth-auto680):03076 FCB $CD
3085 1A9A 1A83 (fig-forth-auto680):03077 FDB DDUP-7
3086 1A9C 1A9E (fig-forth-auto680):03078 SIGNUM FDB *+NATWID
3087 1A9E C601 (fig-forth-auto680):03079 SIGNUE LDB #1
3088 1AA0 A6C4 (fig-forth-auto680):03080 LDA ,U
3089 1AA2 2A01 (fig-forth-auto680):03081 BPL SIGNUP
3090 1AA4 50 (fig-forth-auto680):03082 NEGB
3091 1AA5 1D (fig-forth-auto680):03083 SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
3092 1AA6 EDC4 (fig-forth-auto680):03084 STD ,U ; Am I too much of a prude?
3093 1AA8 39 (fig-forth-auto680):03085 RTS
3094 (fig-forth-auto680):03086 * 6800 model version should be something like this:
3095 (fig-forth-auto680):03087 * LDB #1
3096 (fig-forth-auto680):03088 * CLRA
3097 (fig-forth-auto680):03089 * TSX
3098 (fig-forth-auto680):03090 * TST ,X
3099 (fig-forth-auto680):03091 * BPL SIGNUP
3100 (fig-forth-auto680):03092 * NEGB
3101 (fig-forth-auto680):03093 * COMA
3102 (fig-forth-auto680):03094 * SIGNUP JMP STABX
3103 (fig-forth-auto680):03095 *
3104 (fig-forth-auto680):03096 * ======>> 98 <<
3105 (fig-forth-auto680):03097 * ( adr1 direction --- adr2 )
3106 (fig-forth-auto680):03098 * TRAVERSE the symbol name.
3107 (fig-forth-auto680):03099 * If direction is 1, find the end.
3108 (fig-forth-auto680):03100 * If direction is -1, find the beginning.
3109 1AA9 88 (fig-forth-auto680):03101 FCB $88
3110 1AAA 54524156455253 (fig-forth-auto680):03102 FCC 'TRAVERS' ; 'TRAVERSE'
3111 1AB1 C5 (fig-forth-auto680):03103 FCB $C5
3112 1AB2 1A93 (fig-forth-auto680):03104 FDB SIGNUM-9
3113 1AB4 1AB6 (fig-forth-auto680):03105 TRAV FDB *+NATWID
3114 1AB6 8DE6 (fig-forth-auto680):03106 BSR SIGNUE ; Convert negative to -, zero or positive to 1.
3115 1AB8 ECC1 (fig-forth-auto680):03107 LDD ,U++ ; Still in D, but we have to pop it anyway.
3116 1ABA AEC4 (fig-forth-auto680):03108 LDX ,U ; If D is 1 or -1, so is B.
3117 1ABC 867F (fig-forth-auto680):03109 LDA #$7F
3118 1ABE 3085 (fig-forth-auto680):03110 TRAVLP LEAX B,X ; Don't look at the one we start at.
3119 1AC0 A184 (fig-forth-auto680):03111 CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
3120 1AC2 24FA (fig-forth-auto680):03112 BCC TRAVLP
3121 1AC4 AFC4 (fig-forth-auto680):03113 TRAVDN STX ,U
3122 1AC6 39 (fig-forth-auto680):03114 RTS
3123 (fig-forth-auto680):03115 * Doing this in 6809 just because it can be done may be getting too greedy.
3124 (fig-forth-auto680):03116 * TRAV FDB DOCOL,SWAP
3125 (fig-forth-auto680):03117 * TRAV2 FDB OVER,PLUS,LIT8
3126 (fig-forth-auto680):03118 * FCB $7F
3127 (fig-forth-auto680):03119 * FDB OVER,CAT,LESS,ZBRAN
3128 (fig-forth-auto680):03120 * FDB TRAV2-*-NATWID
3129 (fig-forth-auto680):03121 * FDB SWAP,DROP
3130 (fig-forth-auto680):03122 * FDB SEMIS
3131 (fig-forth-auto680):03123 *
3132 (fig-forth-auto680):03124 * ======>> 99 <<
3133 (fig-forth-auto680):03125 * ( --- symptr )
3134 (fig-forth-auto680):03126 * Fetch CURRENT as a per-USER constant.
3135 1AC7 86 (fig-forth-auto680):03127 FCB $86
3136 1AC8 4C41544553 (fig-forth-auto680):03128 FCC 'LATES' ; 'LATEST'
3137 1ACD D4 (fig-forth-auto680):03129 FCB $D4
3138 1ACE 1AA9 (fig-forth-auto680):03130 FDB TRAV-11
3139 1AD0 17B9194C17721772 (fig-forth-auto680):03131 LATEST FDB DOCOL,CURENT,AT,AT
3140 1AD8 1667 (fig-forth-auto680):03132 FDB SEMIS
3141 (fig-forth-auto680):03133 * LATEST FDB *+NATWID
3142 (fig-forth-auto680):03134 * Getting too greedy:
3143 (fig-forth-auto680):03135 * Version 1:
3144 (fig-forth-auto680):03136 * TFR DP,A
3145 (fig-forth-auto680):03137 * CLRB
3146 (fig-forth-auto680):03138 * TFR D,X
3147 (fig-forth-auto680):03139 * LDD CURENT+NATWID,PCR
3148 (fig-forth-auto680):03140 * LDX [D,X]
3149 (fig-forth-auto680):03141 * PSHU X ; Leave the address in X.
3150 (fig-forth-auto680):03142 * RTS
3151 (fig-forth-auto680):03143 * Version 2:
3152 (fig-forth-auto680):03144 * LEAX CURENT,PCR
3153 (fig-forth-auto680):03145 * JSR [,X]
3154 (fig-forth-auto680):03146 * PULU X
3155 (fig-forth-auto680):03147 * LDX [,X]
3156 (fig-forth-auto680):03148 * PSHU X
3157 (fig-forth-auto680):03149 * RTS
3158 (fig-forth-auto680):03150 * Too greedy, too many smantic holes to fall through.
3159 (fig-forth-auto680):03151 * If the address at the CFA is made relative,
3160 (fig-forth-auto680):03152 * this is part of the code that would be affected
3161 (fig-forth-auto680):03153 * if it is in native CPU code.
3162 (fig-forth-auto680):03154 *
3163 (fig-forth-auto680):03155 * ======>> 100 <<
3164 (fig-forth-auto680):03156 * Wanted to do these as INCREMENTERs,
3165 (fig-forth-auto680):03157 * but I need to stick with the model as much as possible,
3166 (fig-forth-auto680):03158 * (mostly, LOL) adding code only to make the model more clear.
3167 (fig-forth-auto680):03159 * ( pfa --- lfa )
3168 (fig-forth-auto680):03160 * Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
3169 1ADA 83 (fig-forth-auto680):03161 FCB $83
3170 1ADB 4C46 (fig-forth-auto680):03162 FCC 'LF' ; 'LFA'
3171 1ADD C1 (fig-forth-auto680):03163 FCB $C1
3172 1ADE 1AC7 (fig-forth-auto680):03164 FDB LATEST-9
3173 1AE0 17B913A7 (fig-forth-auto680):03165 LFA FDB DOCOL,LIT8
3174 (fig-forth-auto680):03166 * FCB 4
3175 1AE4 04 (fig-forth-auto680):03167 FCB 2*NATWID
3176 1AE5 1A04 (fig-forth-auto680):03168 FDB SUB
3177 1AE7 1667 (fig-forth-auto680):03169 FDB SEMIS
3178 (fig-forth-auto680):03170 *
3179 (fig-forth-auto680):03171 * ======>> 101 <<
3180 (fig-forth-auto680):03172 * ( pfa --- cfa )
3181 (fig-forth-auto680):03173 * Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
3182 1AE9 83 (fig-forth-auto680):03174 FCB $83
3183 1AEA 4346 (fig-forth-auto680):03175 FCC 'CF' ; 'CFA'
3184 1AEC C1 (fig-forth-auto680):03176 FCB $C1
3185 1AED 1ADA (fig-forth-auto680):03177 FDB LFA-6
3186 (fig-forth-auto680):03178 * CFA FDB DOCOL,TWO,SUB
3187 1AEF 17B917F71A04 (fig-forth-auto680):03179 CFA FDB DOCOL,NATWC,SUB
3188 1AF5 1667 (fig-forth-auto680):03180 FDB SEMIS
3189 (fig-forth-auto680):03181 *
3190 (fig-forth-auto680):03182 * ======>> 102 <<
3191 (fig-forth-auto680):03183 * ( pfa --- nfa )
3192 (fig-forth-auto680):03184 * Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
3193 1AF7 83 (fig-forth-auto680):03185 FCB $83
3194 1AF8 4E46 (fig-forth-auto680):03186 FCC 'NF' ; 'NFA'
3195 1AFA C1 (fig-forth-auto680):03187 FCB $C1
3196 1AFB 1AE9 (fig-forth-auto680):03188 FDB CFA-6
3197 1AFD 17B913A7 (fig-forth-auto680):03189 NFA FDB DOCOL,LIT8
3198 (fig-forth-auto680):03190 * FCB 5
3199 1B01 05 (fig-forth-auto680):03191 FCB NATWID*2+1
3200 1B02 1A04184516EF1AB4 (fig-forth-auto680):03192 FDB SUB,ONE,MINUS,TRAV
3201 1B0A 1667 (fig-forth-auto680):03193 FDB SEMIS
3202 (fig-forth-auto680):03194 *
3203 (fig-forth-auto680):03195 * ======>> 103 <<
3204 (fig-forth-auto680):03196 * ( nfa --- pfa )
3205 (fig-forth-auto680):03197 * Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
3206 1B0C 83 (fig-forth-auto680):03198 FCB $83
3207 1B0D 5046 (fig-forth-auto680):03199 FCC 'PF' ; 'PFA'
3208 1B0F C1 (fig-forth-auto680):03200 FCB $C1
3209 1B10 1AF7 (fig-forth-auto680):03201 FDB NFA-6
3210 1B12 17B918451AB413A7 (fig-forth-auto680):03202 PFA FDB DOCOL,ONE,TRAV,LIT8
3211 (fig-forth-auto680):03203 * FCB 5
3212 1B1A 05 (fig-forth-auto680):03204 FCB NATWID*2+1
3213 1B1B 16C6 (fig-forth-auto680):03205 FDB PLUS
3214 1B1D 1667 (fig-forth-auto680):03206 FDB SEMIS
3215 (fig-forth-auto680):03207 *
3216 (fig-forth-auto680):03208 * ######>> screen 40 <<
3217 (fig-forth-auto680):03209 * ======>> 104 <<
3218 (fig-forth-auto680):03210 * ( --- )
3219 (fig-forth-auto680):03211 * Save the parameter stack pointer in CSP for compiler checks.
3220 1B1F 84 (fig-forth-auto680):03212 FCB $84
3221 1B20 214353 (fig-forth-auto680):03213 FCC '!CS' ; '!CSP'
3222 1B23 D0 (fig-forth-auto680):03214 FCB $D0
3223 1B24 1B0C (fig-forth-auto680):03215 FDB PFA-6
3224 1B26 17B916401981178A (fig-forth-auto680):03216 SCSP FDB DOCOL,SPAT,CSP,STORE
3225 1B2E 1667 (fig-forth-auto680):03217 FDB SEMIS
3226 (fig-forth-auto680):03218 *
3227 (fig-forth-auto680):03219 * ======>> 105 <<
3228 (fig-forth-auto680):03220 * ( 0 n --- ) ( *** )
3229 (fig-forth-auto680):03221 * ( true n --- IN BLK ) ( anything *** nothing )
3230 (fig-forth-auto680):03222 * If flag is false, do nothing.
3231 (fig-forth-auto680):03223 * If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
3232 (fig-forth-auto680):03224 * Leaves cursor position (IN)
3233 (fig-forth-auto680):03225 * and currently loading block number (BLK) on stack, for analysis.
3234 (fig-forth-auto680):03226 *
3235 (fig-forth-auto680):03227 * This one is too important to be high-level Forth codes.
3236 (fig-forth-auto680):03228 * When we have an error, we want to disturb as little as possible.
3237 (fig-forth-auto680):03229 * But fixing that cascades through ERROR and MESSAGE
3238 (fig-forth-auto680):03230 * into the disk block system.
3239 (fig-forth-auto680):03231 * And we aren't ready for that yet.
3240 1B30 86 (fig-forth-auto680):03232 FCB $86
3241 1B31 3F4552524F (fig-forth-auto680):03233 FCC '?ERRO' ; '?ERROR'
3242 1B36 D2 (fig-forth-auto680):03234 FCB $D2
3243 1B37 1B1F (fig-forth-auto680):03235 FDB SCSP-7
3244 (fig-forth-auto680):03236 * QERR FDB *+NATWID
3245 (fig-forth-auto680):03237 * LDD NATWID,U
3246 (fig-forth-auto680):03238 * BNE QERROR
3247 (fig-forth-auto680):03239 * LEAU 2*NATWID,U
3248 (fig-forth-auto680):03240 * RTS
3249 (fig-forth-auto680):03241 ** this doesn't work anyway: QERROR LBR ERROR
3250 1B39 17B917361409 (fig-forth-auto680):03242 QERR FDB DOCOL,SWAP,ZBRAN
3251 1B3F 0006 (fig-forth-auto680):03243 FDB QERR2-*-NATWID
3252 1B41 1FE713FA (fig-forth-auto680):03244 FDB ERROR,BRAN
3253 1B45 0002 (fig-forth-auto680):03245 FDB QERR3-*-NATWID
3254 1B47 172A (fig-forth-auto680):03246 QERR2 FDB DROP
3255 1B49 1667 (fig-forth-auto680):03247 QERR3 FDB SEMIS
3256 (fig-forth-auto680):03248 *
3257 (fig-forth-auto680):03249 * ======>> 106 <<
3258 (fig-forth-auto680):03250 * STATE is compiling:
3259 (fig-forth-auto680):03251 * ( --- ) ( *** )
3260 (fig-forth-auto680):03252 * STATE is compiling:
3261 (fig-forth-auto680):03253 * ( --- IN BLK ) ( anything *** nothing )
3262 (fig-forth-auto680):03254 * ERROR if not compiling.
3263 1B4B 85 (fig-forth-auto680):03255 FCB $85
3264 1B4C 3F434F4D (fig-forth-auto680):03256 FCC '?COM' ; '?COMP'
3265 1B50 D0 (fig-forth-auto680):03257 FCB $D0
3266 1B51 1B30 (fig-forth-auto680):03258 FDB QERR-9
3267 1B53 17B91958177216A3 (fig-forth-auto680):03259 QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
3269 1B5D 11 (fig-forth-auto680):03260 FCB $11
3270 1B5E 1B39 (fig-forth-auto680):03261 FDB QERR
3271 1B60 1667 (fig-forth-auto680):03262 FDB SEMIS
3272 (fig-forth-auto680):03263 *
3273 (fig-forth-auto680):03264 * ======>> 107 <<
3274 (fig-forth-auto680):03265 * STATE is executing:
3275 (fig-forth-auto680):03266 * ( --- ) ( *** )
3276 (fig-forth-auto680):03267 * STATE is executing:
3277 (fig-forth-auto680):03268 * ( --- IN BLK ) ( anything *** nothing )
3278 (fig-forth-auto680):03269 * ERROR if not executing.
3279 1B62 85 (fig-forth-auto680):03270 FCB $85
3280 1B63 3F455845 (fig-forth-auto680):03271 FCC '?EXE' ; '?EXEC'
3281 1B67 C3 (fig-forth-auto680):03272 FCB $C3
3282 1B68 1B4B (fig-forth-auto680):03273 FDB QCOMP-8
3283 1B6A 17B91958177213A7 (fig-forth-auto680):03274 QEXEC FDB DOCOL,STATE,AT,LIT8
3284 1B72 12 (fig-forth-auto680):03275 FCB $12
3285 1B73 1B39 (fig-forth-auto680):03276 FDB QERR
3286 1B75 1667 (fig-forth-auto680):03277 FDB SEMIS
3287 (fig-forth-auto680):03278 *
3288 (fig-forth-auto680):03279 * ======>> 108 <<
3289 (fig-forth-auto680):03280 * ( n1 n1 --- ) ( *** )
3290 (fig-forth-auto680):03281 * ( n1 n2 --- IN BLK ) ( anything *** nothing )
3291 (fig-forth-auto680):03282 * ERROR if top two are unequal.
3292 (fig-forth-auto680):03283 * MESSAGE says compiled conditionals do not match.
3293 1B77 86 (fig-forth-auto680):03284 FCB $86
3294 1B78 3F50414952 (fig-forth-auto680):03285 FCC '?PAIR' ; '?PAIRS'
3295 1B7D D3 (fig-forth-auto680):03286 FCB $D3
3296 1B7E 1B62 (fig-forth-auto680):03287 FDB QEXEC-8
3297 1B80 17B91A0413A7 (fig-forth-auto680):03288 QPAIRS FDB DOCOL,SUB,LIT8
3298 1B86 13 (fig-forth-auto680):03289 FCB $13
3299 1B87 1B39 (fig-forth-auto680):03290 FDB QERR
3300 1B89 1667 (fig-forth-auto680):03291 FDB SEMIS
3301 (fig-forth-auto680):03292 *
3302 (fig-forth-auto680):03293 * ======>> 109 <<
3303 (fig-forth-auto680):03294 * CSP and parameter stack are balanced (equal):
3304 (fig-forth-auto680):03295 * ( --- ) ( *** )
3305 (fig-forth-auto680):03296 * CSP and parameter stack are not balanced (unequal):
3306 (fig-forth-auto680):03297 * ( --- IN BLK ) ( anything *** nothing )
3307 (fig-forth-auto680):03298 * ERROR if return/control stack is not at same level as last !CSP.
3308 (fig-forth-auto680):03299 * Usually indicates that a definition has been left incomplete.
3309 1B8B 84 (fig-forth-auto680):03300 FCB $84
3310 1B8C 3F4353 (fig-forth-auto680):03301 FCC '?CS' ; '?CSP'
3311 1B8F D0 (fig-forth-auto680):03302 FCB $D0
3312 1B90 1B77 (fig-forth-auto680):03303 FDB QPAIRS-9
3313 1B92 17B9164019811772 (fig-forth-auto680):03304 QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
3315 1B9E 14 (fig-forth-auto680):03305 FCB $14
3316 1B9F 1B39 (fig-forth-auto680):03306 FDB QERR
3317 1BA1 1667 (fig-forth-auto680):03307 FDB SEMIS
3318 (fig-forth-auto680):03308 *
3319 (fig-forth-auto680):03309 * ======>> 110 <<
3320 (fig-forth-auto680):03310 * Active BLK input:
3321 (fig-forth-auto680):03311 * ( --- ) ( *** )
3322 (fig-forth-auto680):03312 * No active BLK input:
3323 (fig-forth-auto680):03313 * ( --- IN BLK ) ( anything *** nothing )
3324 (fig-forth-auto680):03314 * ERROR if not loading, i. e., if BLK is zero.
3325 1BA3 88 (fig-forth-auto680):03315 FCB $88
3326 1BA4 3F4C4F4144494E (fig-forth-auto680):03316 FCC '?LOADIN' ; '?LOADING'
3327 1BAB C7 (fig-forth-auto680):03317 FCB $C7
3328 1BAC 1B8B (fig-forth-auto680):03318 FDB QCSP-7
3329 1BAE 17B91906177216A3 (fig-forth-auto680):03319 QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
3331 1BB8 16 (fig-forth-auto680):03320 FCB $16
3332 1BB9 1B39 (fig-forth-auto680):03321 FDB QERR
3333 1BBB 1667 (fig-forth-auto680):03322 FDB SEMIS
3334 (fig-forth-auto680):03323 *
3335 (fig-forth-auto680):03324 * ######>> screen 41 <<
3336 (fig-forth-auto680):03325 * ======>> 111 <<
3337 (fig-forth-auto680):03326 * ( --- )
3338 (fig-forth-auto680):03327 * Compile an in-line literal value from the instruction stream.
3339 1BBD 87 (fig-forth-auto680):03328 FCB $87
3340 1BBE 434F4D50494C (fig-forth-auto680):03329 FCC 'COMPIL' ; 'COMPILE'
3341 1BC4 C5 (fig-forth-auto680):03330 FCB $C5
3342 1BC5 1BA3 (fig-forth-auto680):03331 FDB QLOAD-11
3343 (fig-forth-auto680):03332 * COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
3344 (fig-forth-auto680):03333 * COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
3345 1BC7 17B91B5316901745 (fig-forth-auto680):03334 COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
3347 1BD7 1667 (fig-forth-auto680):03335 FDB SEMIS
3348 (fig-forth-auto680):03336 *
3349 (fig-forth-auto680):03337 * ======>> 112 <<
3350 (fig-forth-auto680):03338 * ( --- ) P
3351 (fig-forth-auto680):03339 * Clear the compile state bit(s) (shift to interpret).
3352 1BD9 C1 (fig-forth-auto680):03340 FCB $C1 [ immediate
3353 1BDA DB (fig-forth-auto680):03341 FCB $DB
3354 1BDB 1BBD (fig-forth-auto680):03342 FDB COMPIL-10
3355 1BDD 17B9183D1958178A (fig-forth-auto680):03343 LBRAK FDB DOCOL,ZERO,STATE,STORE
3356 1BE5 1667 (fig-forth-auto680):03344 FDB SEMIS
3357 (fig-forth-auto680):03345 *
3358 (fig-forth-auto680):03346 * ======>> 113 <<
3359 (fig-forth-auto680):03347 *
3360 00C0 (fig-forth-auto680):03348 STCOMP EQU $C0
3361 (fig-forth-auto680):03349 * ( --- )
3362 (fig-forth-auto680):03350 * Set the compile state bit(s) (shift to compile).
3363 1BE7 81 (fig-forth-auto680):03351 FCB $81 ]
3364 1BE8 DD (fig-forth-auto680):03352 FCB $DD
3365 1BE9 1BD9 (fig-forth-auto680):03353 FDB LBRAK-4
3366 1BEB 17B913A7 (fig-forth-auto680):03354 RBRAK FDB DOCOL,LIT8
3367 1BEF C0 (fig-forth-auto680):03355 FCB STCOMP
3368 1BF0 1958178A (fig-forth-auto680):03356 FDB STATE,STORE
3369 1BF4 1667 (fig-forth-auto680):03357 FDB SEMIS
3370 (fig-forth-auto680):03358 *
3371 (fig-forth-auto680):03359 * ======>> 114 <<
3372 (fig-forth-auto680):03360 * ( --- )
3373 (fig-forth-auto680):03361 * Toggle SMUDGE bit of LATEST definition header,
3374 (fig-forth-auto680):03362 * to hide it until defined or reveal it after definition.
3375 1BF6 86 (fig-forth-auto680):03363 FCB $86
3376 1BF7 534D554447 (fig-forth-auto680):03364 FCC 'SMUDG' ; 'SMUDGE'
3377 1BFC C5 (fig-forth-auto680):03365 FCB $C5
3378 1BFD 1BE7 (fig-forth-auto680):03366 FDB RBRAK-4
3379 1BFF 17B91AD013A7 (fig-forth-auto680):03367 SMUDGE FDB DOCOL,LATEST,LIT8
3380 1C05 20 (fig-forth-auto680):03368 FCB FSMUDG
3381 1C06 1765 (fig-forth-auto680):03369 FDB TOGGLE
3382 1C08 1667 (fig-forth-auto680):03370 FDB SEMIS
3383 (fig-forth-auto680):03371 *
3384 (fig-forth-auto680):03372 * ======>> 115 <<
3385 (fig-forth-auto680):03373 * ( --- )
3386 (fig-forth-auto680):03374 * Set the conversion base to sixteen (b00010000).
3387 1C0A 83 (fig-forth-auto680):03375 FCB $83
3388 1C0B 4845 (fig-forth-auto680):03376 FCC 'HE' ; 'HEX'
3389 1C0D D8 (fig-forth-auto680):03377 FCB $D8
3390 1C0E 1BF6 (fig-forth-auto680):03378 FDB SMUDGE-9
3391 1C10 17B9 (fig-forth-auto680):03379 HEX FDB DOCOL
3392 1C12 13A7 (fig-forth-auto680):03380 FDB LIT8
3393 1C14 10 (fig-forth-auto680):03381 FCB 16 ; decimal sixteen
3394 1C15 1963178A (fig-forth-auto680):03382 FDB BASE,STORE
3395 1C19 1667 (fig-forth-auto680):03383 FDB SEMIS
3396 (fig-forth-auto680):03384 *
3397 (fig-forth-auto680):03385 * ======>> 116 <<
3398 (fig-forth-auto680):03386 * ( --- )
3399 (fig-forth-auto680):03387 * Set the conversion base to ten (b00001010).
3400 1C1B 87 (fig-forth-auto680):03388 FCB $87
3401 1C1C 444543494D41 (fig-forth-auto680):03389 FCC 'DECIMA' ; 'DECIMAL'
3402 1C22 CC (fig-forth-auto680):03390 FCB $CC
3403 1C23 1C0A (fig-forth-auto680):03391 FDB HEX-6
3404 1C25 17B9 (fig-forth-auto680):03392 DEC FDB DOCOL
3405 1C27 13A7 (fig-forth-auto680):03393 FDB LIT8
3406 1C29 0A (fig-forth-auto680):03394 FCB 10 ; decimal ten
3407 1C2A 1963178A (fig-forth-auto680):03395 FDB BASE,STORE
3408 1C2E 1667 (fig-forth-auto680):03396 FDB SEMIS
3409 (fig-forth-auto680):03397 *
3410 (fig-forth-auto680):03398 * ######>> screen 42 <<
3411 (fig-forth-auto680):03399 * ======>> 117 <<
3412 (fig-forth-auto680):03400 * ( --- ) ( IP *** )
3413 (fig-forth-auto680):03401 * Pop the saved IP and use it to
3414 (fig-forth-auto680):03402 * compile the latest symbol as a reference to a ;CODE definition;
3415 (fig-forth-auto680):03403 * overwrite the code field of the symbol found by LATEST
3416 (fig-forth-auto680):03404 * with the address of the low-level characteristic code
3417 (fig-forth-auto680):03405 * provided in the defining definition.
3418 (fig-forth-auto680):03406 * Look closely at where things return, consider the operation of R> and >R .
3419 (fig-forth-auto680):03407 *
3420 (fig-forth-auto680):03408 * The machine-level code which follows (;CODE) in the instruction stream
3421 (fig-forth-auto680):03409 * is not executed by the defining symbol,
3422 (fig-forth-auto680):03410 * but becomes the characteristic of the defined symbol.
3423 (fig-forth-auto680):03411 * This is the usual way to generate the characteristics of VARIABLEs,
3424 (fig-forth-auto680):03412 * CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
3425 (fig-forth-auto680):03413 *
3426 (fig-forth-auto680):03414 * Finally, note that, if code shifts from low level back to high
3427 (fig-forth-auto680):03415 * (native CPU machine code calling into a list of FORTH codes),
3428 (fig-forth-auto680):03416 * the low level code can't just call a high-level definition.
3429 (fig-forth-auto680):03417 * Leaf definitions can directly call other leaf definitions,
3430 (fig-forth-auto680):03418 * but not non-leafs.
3431 (fig-forth-auto680):03419 * It will need an anonymous list, probably embedded in the low-level code,
3432 (fig-forth-auto680):03420 * and Y and X will have to be set appropriately before entering the list.
3433 1C30 87 (fig-forth-auto680):03421 FCB $87
3434 1C31 283B434F4445 (fig-forth-auto680):03422 FCC '(;CODE' ; '(;CODE)'
3435 1C37 A9 (fig-forth-auto680):03423 FCB $A9
3436 1C38 1C1B (fig-forth-auto680):03424 FDB DEC-10
3437 (fig-forth-auto680):03425 * PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
3438 1C3A 17B91690 (fig-forth-auto680):03426 PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
3439 1C3E 1AD01B121AEF178A (fig-forth-auto680):03427 FDB LATEST,PFA,CFA,STORE
3440 1C46 1667 (fig-forth-auto680):03428 FDB SEMIS
3441 (fig-forth-auto680):03429 *
3442 (fig-forth-auto680):03430 * ======>> 118 <<
3443 (fig-forth-auto680):03431 * ( --- ) P
3444 (fig-forth-auto680):03432 * ?CSP to see if there are loose ends in the defining definition
3445 (fig-forth-auto680):03433 * before shifting to the assembler,
3446 (fig-forth-auto680):03434 * compile (;CODE) in the defining definition's instruction stream,
3447 (fig-forth-auto680):03435 * shift to interpreting,
3448 (fig-forth-auto680):03436 * make the ASSEMBLER vocabulary current,
3449 (fig-forth-auto680):03437 * and !CSP to mark the stack
3450 (fig-forth-auto680):03438 * in preparation for assembling low-level code.
3451 (fig-forth-auto680):03439 * Note that ;CODE, unlike DOES>, is IMMEDIATE,
3452 (fig-forth-auto680):03440 * and compiles (;CODE),
3453 (fig-forth-auto680):03441 * which will do the actual work of changing
3454 (fig-forth-auto680):03442 * the LATEST definition's characteristic when the defining word runs.
3455 (fig-forth-auto680):03443 * Assembly is done by the interpreter, rather than the compiler.
3456 (fig-forth-auto680):03444 * I could have avoided the anomalous three-byte code fields by
3457 (fig-forth-auto680):03445 *
3458 (fig-forth-auto680):03446 * Note that the ASSEMBLER is not part of the model (at this time).
3459 (fig-forth-auto680):03447 * That means that, until the assembler is ready,
3460 (fig-forth-auto680):03448 * if you want to define low-level words,
3461 (fig-forth-auto680):03449 * you have to poke (comma) in hand-assembled stuff.
3462 (fig-forth-auto680):03450 *
3463 1C48 C5 (fig-forth-auto680):03451 FCB $C5 immediate
3464 1C49 3B434F44 (fig-forth-auto680):03452 FCC ';COD' ; ';CODE'
3465 1C4D C5 (fig-forth-auto680):03453 FCB $C5
3466 1C4E 1C30 (fig-forth-auto680):03454 FDB PSCODE-10
3467 1C50 17B91B921BC71C3A (fig-forth-auto680):03455 SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
3469 1C5E 1667 (fig-forth-auto680):03456 FDB SEMIS
3470 (fig-forth-auto680):03457 * note: "QSTACK" will be replaced by "ASSEMBLER" later
3471 (fig-forth-auto680):03458 *
3472 (fig-forth-auto680):03459 * ######>> screen 43 <<
3473 (fig-forth-auto680):03460 * ======>> 119 <<
3474 (fig-forth-auto680):03461 * ( --- ) C
3475 (fig-forth-auto680):03462 * Make the word currently being defined
3476 (fig-forth-auto680):03463 * build a header for DOES> definitions.
3477 (fig-forth-auto680):03464 * Actually just compiles a CONSTANT zero
3478 (fig-forth-auto680):03465 * which can be overwritten later by DOES>.
3479 (fig-forth-auto680):03466 * Since the fig models were established, this technique has been deprecated.
3480 (fig-forth-auto680):03467 *
3481 (fig-forth-auto680):03468 * Note that <BUILDS is not IMMEDIATE,
3482 (fig-forth-auto680):03469 * and therefore executes during a definition's run-time,
3483 (fig-forth-auto680):03470 * rather than its compile-time.
3484 (fig-forth-auto680):03471 * It is not intended to be used directly,
3485 (fig-forth-auto680):03472 * but rather so that one definition word can build another.
3486 (fig-forth-auto680):03473 * Also, note that nothing particularly special happens
3487 (fig-forth-auto680):03474 * in the defining definition until DOES> executes.
3488 (fig-forth-auto680):03475 * The name <BUILDS is intended to be a reminder of what is about to occur.
3489 (fig-forth-auto680):03476 *
3490 (fig-forth-auto680):03477 * <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
3491 1C60 87 (fig-forth-auto680):03478 FCB $87
3492 1C61 3C4255494C44 (fig-forth-auto680):03479 FCC '<BUILD' ; '<BUILDS'
3493 1C67 D3 (fig-forth-auto680):03480 FCB $D3
3494 1C68 1C48 (fig-forth-auto680):03481 FDB SEMIC-8
3495 1C6A 17B9183D17DF (fig-forth-auto680):03482 BUILDS FDB DOCOL,ZERO,CON
3496 1C70 1667 (fig-forth-auto680):03483 FDB SEMIS
3497 (fig-forth-auto680):03484 *
3498 (fig-forth-auto680):03485 * ======>> 120 <<
3499 (fig-forth-auto680):03486 * ( --- ) ( IP *** ) C
3500 (fig-forth-auto680):03487 * Define run-time behavior of definitions compiled/defined
3501 (fig-forth-auto680):03488 * by a high-level defining definition --
3502 (fig-forth-auto680):03489 * the FORTH equivalent of a compiler-compiler.
3503 (fig-forth-auto680):03490 * DOES> assumes that the LATEST symbol table entry
3504 (fig-forth-auto680):03491 * has at least one word of parameter field,
3505 (fig-forth-auto680):03492 * which <BUILDS provides.
3506 (fig-forth-auto680):03493 * Note that DOES> is also not IMMEDIATE.
3507 (fig-forth-auto680):03494 *
3508 (fig-forth-auto680):03495 * When the defining word containing DOES> executes the DOES> icode,
3509 (fig-forth-auto680):03496 * it overwrites the LATEST symbol's CFA with jsr <XDOES,
3510 (fig-forth-auto680):03497 * overwrites the first word of that symbol's parameter field with its own IP,
3511 (fig-forth-auto680):03498 * and pops the previous IP from the return stack.
3512 (fig-forth-auto680):03499 * The icodes which follow DOES> in the stream
3513 (fig-forth-auto680):03500 * do not execute at the defining word's run-time.
3514 (fig-forth-auto680):03501 *
3515 (fig-forth-auto680):03502 * Examining XDOES in the virtual machine shows
3516 (fig-forth-auto680):03503 * that the defined word will execute those icodes
3517 (fig-forth-auto680):03504 * which follow DOES> at its own run-time.
3518 (fig-forth-auto680):03505 *
3519 (fig-forth-auto680):03506 * The advantage of this kind of behaviour,
3520 (fig-forth-auto680):03507 * which you will also note in ;CODE,
3521 (fig-forth-auto680):03508 * is that the defined word can contain
3522 (fig-forth-auto680):03509 * both operations and data to be operated on.
3523 (fig-forth-auto680):03510 * This is how FORTH data objects define their own behavior.
3524 (fig-forth-auto680):03511 *
3525 (fig-forth-auto680):03512 * Finally, note that the effective parameter field for DOES> definitions
3526 (fig-forth-auto680):03513 * starts two NATWID words after the CFA, instead of just one
3527 (fig-forth-auto680):03514 * (four bytes instead of two in a sixteen-bit addressing Forth).
3528 (fig-forth-auto680):03515 *
3529 (fig-forth-auto680):03516 * VOCABULARYs will use this. See definition of word FORTH.
3530 1C72 85 (fig-forth-auto680):03517 FCB $85
3531 1C73 444F4553 (fig-forth-auto680):03518 FCC 'DOES' ; 'DOES>'
3532 1C77 BE (fig-forth-auto680):03519 FCB $BE
3533 1C78 1C60 (fig-forth-auto680):03520 FDB BUILDS-10
3534 (fig-forth-auto680):03521 * DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
3535 1C7A 17B91690 (fig-forth-auto680):03522 DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
3536 1C7E 1AD01B12178A (fig-forth-auto680):03523 FDB LATEST,PFA,STORE
3537 1C84 1C3A (fig-forth-auto680):03524 FDB PSCODE
3538 (fig-forth-auto680):03525 *
3539 (fig-forth-auto680):03526 * ( --- PFA+NATWID ) ( *** IP )
3540 (fig-forth-auto680):03527 * Characteristic of a DOES> defined word.
3541 (fig-forth-auto680):03528 * The characteristics of DOES> definitions are written in high-level
3542 (fig-forth-auto680):03529 * Forth codes rather than native CPU machine level code.
3543 (fig-forth-auto680):03530 * The first parameter word points to the high-level characteristic.
3544 (fig-forth-auto680):03531 * This routine's job is to push the IP,
3545 (fig-forth-auto680):03532 * load the high level characteristic pointer in IP,
3546 (fig-forth-auto680):03533 * and leave the address following the characteristic pointer on the stack
3547 (fig-forth-auto680):03534 * so the parameter field can be accessed.
3548 1C86 ECE4 (fig-forth-auto680):03535 DODOES LDD ,S ; Keep the return address.
3549 1C88 10AFE4 (fig-forth-auto680):03536 STY ,S ; Save/nest the current IP on the return stack.
3550 1C8B 10AE02 (fig-forth-auto680):03537 LDY NATWID,X ; First parameter is new IP.
3551 1C8E 3004 (fig-forth-auto680):03538 LEAX 2*NATWID,X ; Address of second parameter.
3552 1C90 3610 (fig-forth-auto680):03539 PSHU X
3553 1C92 1F05 (fig-forth-auto680):03540 TFR D,PC ; Synthetic return.
3554 (fig-forth-auto680):03541 *
3555 (fig-forth-auto680):03542 * From the 6800 model:
3556 (fig-forth-auto680):03543 * DODOES LDA IP
3557 (fig-forth-auto680):03544 * LDB IP+1
3558 (fig-forth-auto680):03545 * LDX RP make room on return stack
3559 (fig-forth-auto680):03546 * LEAX -1,X ;
3560 (fig-forth-auto680):03547 * LEAX -1,X ;
3561 (fig-forth-auto680):03548 * STX RP
3562 (fig-forth-auto680):03549 * STA 2,X push return address
3563 (fig-forth-auto680):03550 * STB 3,X
3564 (fig-forth-auto680):03551 * LDX W get addr of pointer to run-time code
3565 (fig-forth-auto680):03552 * LEAX 1,X ;
3566 (fig-forth-auto680):03553 * LEAX 1,X ;
3567 (fig-forth-auto680):03554 * STX N stash it in scratch area
3568 (fig-forth-auto680):03555 * LDX 0,X get new IP
3569 (fig-forth-auto680):03556 * STX IP
3570 (fig-forth-auto680):03557 * CLRA ; get address of parameter
3571 (fig-forth-auto680):03558 * LDB #2
3572 (fig-forth-auto680):03559 * ADDB N+1
3573 (fig-forth-auto680):03560 * ADCA N
3574 (fig-forth-auto680):03561 * PSHS B ; and push it on data stack
3575 (fig-forth-auto680):03562 * PSHS A ;
3576 (fig-forth-auto680):03563 * JMP NEXT2
3577 (fig-forth-auto680):03564 *
3578 (fig-forth-auto680):03565 * ######>> screen 44 <<
3579 (fig-forth-auto680):03566 * ======>> 121 <<
3580 (fig-forth-auto680):03567 * ( strptr --- strptr+1 count )
3581 (fig-forth-auto680):03568 * Convert counted string to string and count.
3582 (fig-forth-auto680):03569 * (Fetch the byte at strptr, post-increment.)
3583 1C94 85 (fig-forth-auto680):03570 FCB $85
3584 1C95 434F554E (fig-forth-auto680):03571 FCC 'COUN' ; 'COUNT'
3585 1C99 D4 (fig-forth-auto680):03572 FCB $D4
3586 1C9A 1C72 (fig-forth-auto680):03573 FDB DOES-8
3587 1C9C 17B9174519AB1736 (fig-forth-auto680):03574 COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
3589 1CA6 1667 (fig-forth-auto680):03575 FDB SEMIS
3590 (fig-forth-auto680):03576 *
3591 (fig-forth-auto680):03577 * ======>> 122 <<
3592 (fig-forth-auto680):03578 * ( strptr count --- )
3593 (fig-forth-auto680):03579 * EMIT count characters at strptr.
3594 1CA8 84 (fig-forth-auto680):03580 FCB $84
3595 1CA9 545950 (fig-forth-auto680):03581 FCC 'TYP' ; 'TYPE'
3596 1CAC C5 (fig-forth-auto680):03582 FCB $C5
3597 1CAD 1C94 (fig-forth-auto680):03583 FDB COUNT-8
3598 1CAF 17B91A8A1409 (fig-forth-auto680):03584 TYPE FDB DOCOL,DDUP,ZBRAN
3599 1CB5 0016 (fig-forth-auto680):03585 FDB TYPE3-*-NATWID
3600 1CB7 171C16C617361453 (fig-forth-auto680):03586 FDB OVER,PLUS,SWAP,XDO
3601 1CBF 1465177E1542141D (fig-forth-auto680):03587 TYPE2 FDB I,CAT,EMIT,XLOOP
3602 1CC7 FFF6 (fig-forth-auto680):03588 FDB TYPE2-*-NATWID
3603 1CC9 13FA (fig-forth-auto680):03589 FDB BRAN
3604 1CCB 0002 (fig-forth-auto680):03590 FDB TYPE4-*-NATWID
3605 1CCD 172A (fig-forth-auto680):03591 TYPE3 FDB DROP
3606 1CCF 1667 (fig-forth-auto680):03592 TYPE4 FDB SEMIS
3607 (fig-forth-auto680):03593 *
3608 (fig-forth-auto680):03594 * ======>> 123 <<
3609 (fig-forth-auto680):03595 * ( strptr count1 --- strptr count2 )
3610 (fig-forth-auto680):03596 * Supress trailing blanks (subtract count of trailing blanks from strptr).
3611 1CD1 89 (fig-forth-auto680):03597 FCB $89
3612 1CD2 2D545241494C494E (fig-forth-auto680):03598 FCC '-TRAILIN' ; '-TRAILING'
3613 1CDA C7 (fig-forth-auto680):03599 FCB $C7
3614 1CDB 1CA8 (fig-forth-auto680):03600 FDB TYPE-7
3615 1CDD 17B91745183D1453 (fig-forth-auto680):03601 DTRAIL FDB DOCOL,DUP,ZERO,XDO
3616 1CE5 171C171C16C61845 (fig-forth-auto680):03602 DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
3618 1CF3 1A041409 (fig-forth-auto680):03603 FDB SUB,ZBRAN
3619 1CF7 0006 (fig-forth-auto680):03604 FDB DTRAL3-*-NATWID
3620 1CF9 167513FA (fig-forth-auto680):03605 FDB LEAVE,BRAN
3621 1CFD 0004 (fig-forth-auto680):03606 FDB DTRAL4-*-NATWID
3622 1CFF 18451A04 (fig-forth-auto680):03607 DTRAL3 FDB ONE,SUB
3623 1D03 141D (fig-forth-auto680):03608 DTRAL4 FDB XLOOP
3624 1D05 FFDE (fig-forth-auto680):03609 FDB DTRAL2-*-NATWID
3625 1D07 1667 (fig-forth-auto680):03610 FDB SEMIS
3626 (fig-forth-auto680):03611 *
3627 (fig-forth-auto680):03612 * ======>> 124 <<
3628 (fig-forth-auto680):03613 * ( --- )
3629 (fig-forth-auto680):03614 * TYPE counted string out of instruction stream (updating IP).
3630 1D09 84 (fig-forth-auto680):03615 FCB $84
3631 1D0A 282E22 (fig-forth-auto680):03616 FCC '(."' ; '(.")'
3632 1D0D A9 (fig-forth-auto680):03617 FCB $A9
3633 1D0E 1CD1 (fig-forth-auto680):03618 FDB DTRAIL-12
3634 (fig-forth-auto680):03619 * PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
3635 (fig-forth-auto680):03620 * PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
3636 1D10 17B9169C1C9C1745 (fig-forth-auto680):03621 PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
3638 1D1A 169016C616811CAF (fig-forth-auto680):03622 FDB FROMR,PLUS,TOR,TYPE
3639 1D22 1667 (fig-forth-auto680):03623 FDB SEMIS
3640 (fig-forth-auto680):03624 *
3641 (fig-forth-auto680):03625 * ======>> 125 <<
3642 (fig-forth-auto680):03626 * ( --- ) P
3643 (fig-forth-auto680):03627 * { ." something-to-be-printed " } typical input
3644 (fig-forth-auto680):03628 * Use WORD to parse to trailing quote;
3645 (fig-forth-auto680):03629 * if compiling, compile XDOTQ and string parsed,
3646 (fig-forth-auto680):03630 * otherwise, TYPE string.
3647 1D24 C2 (fig-forth-auto680):03631 FCB $C2 immediate
3648 1D25 2E (fig-forth-auto680):03632 FCC '.' ; '."'
3649 1D26 A2 (fig-forth-auto680):03633 FCB $A2
3650 1D27 1D09 (fig-forth-auto680):03634 FDB PDOTQ-7
3651 1D29 17B9 (fig-forth-auto680):03635 DOTQ FDB DOCOL
3652 1D2B 13A7 (fig-forth-auto680):03636 FDB LIT8
3653 1D2D 22 (fig-forth-auto680):03637 FCB $22 ascii quote
3654 1D2E 195817721409 (fig-forth-auto680):03638 FDB STATE,AT,ZBRAN
3655 1D34 0012 (fig-forth-auto680):03639 FDB DOTQ1-*-NATWID
3656 1D36 1BC71D101EBC (fig-forth-auto680):03640 FDB COMPIL,PDOTQ,WORD
3657 1D3C 19C7177E19AB19D7 (fig-forth-auto680):03641 FDB HERE,CAT,ONEP,ALLOT,BRAN
3659 1D46 0008 (fig-forth-auto680):03642 FDB DOTQ2-*-NATWID
3660 1D48 1EBC19C71C9C1CAF (fig-forth-auto680):03643 DOTQ1 FDB WORD,HERE,COUNT,TYPE
3661 1D50 1667 (fig-forth-auto680):03644 DOTQ2 FDB SEMIS
3662 (fig-forth-auto680):03645 *
3663 (fig-forth-auto680):03646 * ######>> screen 45 <<
3664 (fig-forth-auto680):03647 * ======>> 126 <<== MACHINE DEPENDENT
3665 (fig-forth-auto680):03648 * ( --- ) ( *** )
3666 (fig-forth-auto680):03649 * ( --- IN BLK ) ( anything *** nothing )
3667 (fig-forth-auto680):03650 * ERROR if parameter stack out of bounds.
3668 (fig-forth-auto680):03651 *
3669 (fig-forth-auto680):03652 * But checking whether the stack is in bounds or not
3670 (fig-forth-auto680):03653 * really should not use the stack.
3671 (fig-forth-auto680):03654 * And there really should be a ?RSTACK, as well.
3672 1D52 86 (fig-forth-auto680):03655 FCB $86
3673 1D53 3F53544143 (fig-forth-auto680):03656 FCC '?STAC' ; '?STACK'
3674 1D58 CB (fig-forth-auto680):03657 FCB $CB
3675 1D59 1D24 (fig-forth-auto680):03658 FDB DOTQ-5
3676 1D5B 17B913A7 (fig-forth-auto680):03659 QSTACK FDB DOCOL,LIT8
3677 (fig-forth-auto680):03660 * FCB $12
3678 1D5F 12 (fig-forth-auto680):03661 FCB SINIT-ORIG
3679 (fig-forth-auto680):03662 * But why use that instead of XSPZER (S0)?
3680 (fig-forth-auto680):03663 * Multi-user or multi-tasking would not want that.
3681 (fig-forth-auto680):03664 * CMPU <XSPZER
3682 (fig-forth-auto680):03665 * FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
3683 1D60 189C177216401A1D (fig-forth-auto680):03666 FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
3685 1D6A 1B39 (fig-forth-auto680):03667 FDB QERR
3686 (fig-forth-auto680):03668 * prints 'empty stack'
3687 (fig-forth-auto680):03669 *
3688 1D6C 1640 (fig-forth-auto680):03670 QSTAC2 FDB SPAT
3689 (fig-forth-auto680):03671 * Here, we compare with a value at least 128
3690 (fig-forth-auto680):03672 * higher than dict. ptr. (DICTPT)
3691 1D6E 19C713A7 (fig-forth-auto680):03673 FDB HERE,LIT8
3692 1D72 80 (fig-forth-auto680):03674 FCB $80 ; This is a rough check anyway, leave it as is.
3693 1D73 16C61A1D1409 (fig-forth-auto680):03675 FDB PLUS,LESS,ZBRAN
3694 1D79 0004 (fig-forth-auto680):03676 FDB QSTAC3-*-NATWID
3695 1D7B 184D (fig-forth-auto680):03677 FDB TWO ; NOT the NATWID constant!
3696 1D7D 1B39 (fig-forth-auto680):03678 FDB QERR
3697 (fig-forth-auto680):03679 * prints 'full stack'
3698 (fig-forth-auto680):03680 *
3699 1D7F 1667 (fig-forth-auto680):03681 QSTAC3 FDB SEMIS
3700 (fig-forth-auto680):03682 *
3701 (fig-forth-auto680):03683 * ======>> 127 << this word's function
3702 (fig-forth-auto680):03684 * is done by ?STACK in this version
3703 (fig-forth-auto680):03685 * FCB $85
3704 (fig-forth-auto680):03686 * FCC 4,?FREE
3705 (fig-forth-auto680):03687 * FCB $C5
3706 (fig-forth-auto680):03688 * FDB QSTACK-9
3707 (fig-forth-auto680):03689 *QFREE FDB DOCOL,SPAT,HERE,LIT8
3708 (fig-forth-auto680):03690 * FCB $80
3709 (fig-forth-auto680):03691 * FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
3710 (fig-forth-auto680):03692 *
3711 (fig-forth-auto680):03693 * ######>> screen 46 <<
3712 (fig-forth-auto680):03694 * ======>> 128 <<
3713 (fig-forth-auto680):03695 * ( buffer n --- )
3714 (fig-forth-auto680):03696 * ***** Check that this is how it works here:
3715 (fig-forth-auto680):03697 * Get up to n-1 characters from the keyboard,
3716 (fig-forth-auto680):03698 * storing at buffer and echoing, with backspace editing,
3717 (fig-forth-auto680):03699 * quitting when a CR is read.
3718 (fig-forth-auto680):03700 * Terminate it with a NUL.
3719 1D81 86 (fig-forth-auto680):03701 FCB $86
3720 1D82 4558504543 (fig-forth-auto680):03702 FCC 'EXPEC' ; 'EXPECT'
3721 1D87 D4 (fig-forth-auto680):03703 FCB $D4
3722 1D88 1D52 (fig-forth-auto680):03704 FDB QSTACK-9
3723 1D8A 17B9171C16C6171C (fig-forth-auto680):03705 EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
3725 (fig-forth-auto680):03706 * EXPEC2 FDB KEY,DUP,LIT8
3726 1D94 1556 (fig-forth-auto680):03707 EXPEC2 FDB KEY
3727 1D96 1399001C13B9 (fig-forth-auto680):03708 FDB LIT,$1C,SHOTOS ; DBG
3728 1D9C 174513A7 (fig-forth-auto680):03709 FDB DUP,LIT8
3729 1DA0 0E (fig-forth-auto680):03710 FCB BACKSP-ORIG
3730 1DA1 189C17721A111409 (fig-forth-auto680):03711 FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
3731 1DA9 001D (fig-forth-auto680):03712 FDB EXPEC3-*-NATWID
3732 1DAB 172A13A7 (fig-forth-auto680):03713 FDB DROP,LIT8
3733 1DAF 08 (fig-forth-auto680):03714 FCB 8 ( backspace character to emit )
3734 1DB0 171C14651A111745 (fig-forth-auto680):03715 FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
3736 1DC0 16811A0413FA (fig-forth-auto680):03716 FDB TOR,SUB,BRAN
3737 1DC6 0025 (fig-forth-auto680):03717 FDB EXPEC6-*-NATWID
3738 1DC8 174513A7 (fig-forth-auto680):03718 EXPEC3 FDB DUP,LIT8
3739 1DCC 0D (fig-forth-auto680):03719 FCB $D ( carriage return )
3740 1DCD 1A111409 (fig-forth-auto680):03720 FDB EQUAL,ZBRAN
3741 1DD1 000C (fig-forth-auto680):03721 FDB EXPEC4-*-NATWID
3742 1DD3 1675172A185E183D (fig-forth-auto680):03722 FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
3744 1DDD 0002 (fig-forth-auto680):03723 FDB EXPEC5-*-NATWID
3745 1DDF 1745 (fig-forth-auto680):03724 EXPEC4 FDB DUP
3746 1DE1 14651798183D1465 (fig-forth-auto680):03725 EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
3748 1DED 1542141D (fig-forth-auto680):03726 EXPEC6 FDB EMIT,XLOOP
3749 1DF1 FFA1 (fig-forth-auto680):03727 FDB EXPEC2-*-NATWID
3750 1DF3 172A (fig-forth-auto680):03728 FDB DROP
3751 1DF5 1667 (fig-forth-auto680):03729 FDB SEMIS
3752 (fig-forth-auto680):03730 *
3753 (fig-forth-auto680):03731 * ======>> 129 <<
3754 (fig-forth-auto680):03732 * ( --- )
3755 (fig-forth-auto680):03733 * EXPECT 128 (TWID) characters to TIB.
3756 1DF7 85 (fig-forth-auto680):03734 FCB $85
3757 1DF8 51554552 (fig-forth-auto680):03735 FCC 'QUER' ; 'QUERY'
3758 1DFC D9 (fig-forth-auto680):03736 FCB $D9
3759 1DFD 1D81 (fig-forth-auto680):03737 FDB EXPECT-9
3760 1DFF 17B918BE177219A2 (fig-forth-auto680):03738 QUERY FDB DOCOL,TIB,AT,COLUMS
3761 1E07 17721D8A183D190F (fig-forth-auto680):03739 FDB AT,EXPECT,ZERO,IN,STORE
3763 1E11 1667 (fig-forth-auto680):03740 FDB SEMIS
3764 (fig-forth-auto680):03741 *
3765 (fig-forth-auto680):03742 * ======>> 130 <<
3766 (fig-forth-auto680):03743 * ( --- ) P
3767 (fig-forth-auto680):03744 * End interpretation of a line or screen, and/or prepare for a new block.
3768 (fig-forth-auto680):03745 * Note that the name of this definition is an empty string,
3769 (fig-forth-auto680):03746 * so it matches on the terminating NUL in the terminal or block buffer.
3770 1E13 C1 (fig-forth-auto680):03747 FCB $C1 immediate < carriage return >
3771 1E14 80 (fig-forth-auto680):03748 FCB $80
3772 1E15 1DF7 (fig-forth-auto680):03749 FDB QUERY-8
3773 1E17 17B9190617721409 (fig-forth-auto680):03750 NULL FDB DOCOL,BLK,AT,ZBRAN
3774 1E1F 0024 (fig-forth-auto680):03751 FDB NULL2-*-NATWID
3775 1E21 184519061751 (fig-forth-auto680):03752 FDB ONE,BLK,PSTORE
3776 1E27 183D190F178A1906 (fig-forth-auto680):03753 FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
3778 1E35 16A3 (fig-forth-auto680):03754 FDB ZEQU
3779 (fig-forth-auto680):03755 * check for end of screen
3780 1E37 1409 (fig-forth-auto680):03756 FDB ZBRAN
3781 1E39 0006 (fig-forth-auto680):03757 FDB NULL1-*-NATWID
3782 1E3B 1B6A1690172A (fig-forth-auto680):03758 FDB QEXEC,FROMR,DROP
3783 1E41 13FA (fig-forth-auto680):03759 NULL1 FDB BRAN
3784 1E43 0004 (fig-forth-auto680):03760 FDB NULL3-*-NATWID
3785 1E45 1690172A (fig-forth-auto680):03761 NULL2 FDB FROMR,DROP
3786 1E49 1667 (fig-forth-auto680):03762 NULL3 FDB SEMIS
3787 (fig-forth-auto680):03763 *
3788 (fig-forth-auto680):03764 * ######>> screen 47 <<
3789 (fig-forth-auto680):03765 * ======>> 133 <<
3790 (fig-forth-auto680):03766 * ( adr n b --- )
3791 (fig-forth-auto680):03767 * Fill n bytes at adr with b.
3792 1E4B 84 (fig-forth-auto680):03768 FCB $84
3793 1E4C 46494C (fig-forth-auto680):03769 FCC 'FIL' ; 'FILL'
3794 1E4F CC (fig-forth-auto680):03770 FCB $CC
3795 1E50 1E13 (fig-forth-auto680):03771 FDB NULL-4
3796 1E52 17B917361681171C (fig-forth-auto680):03772 FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
3798 1E60 169018451A041584 (fig-forth-auto680):03773 FDB FROMR,ONE,SUB,CMOVE
3799 1E68 1667 (fig-forth-auto680):03774 FDB SEMIS
3800 (fig-forth-auto680):03775 *
3801 (fig-forth-auto680):03776 * ======>> 134 <<
3802 (fig-forth-auto680):03777 * ( adr n --- )
3803 (fig-forth-auto680):03778 * Fill n bytes with 0.
3804 1E6A 85 (fig-forth-auto680):03779 FCB $85
3805 1E6B 45524153 (fig-forth-auto680):03780 FCC 'ERAS' ; 'ERASE'
3806 1E6F C5 (fig-forth-auto680):03781 FCB $C5
3807 1E70 1E4B (fig-forth-auto680):03782 FDB FILL-7
3808 1E72 17B9183D1E52 (fig-forth-auto680):03783 ERASE FDB DOCOL,ZERO,FILL
3809 1E78 1667 (fig-forth-auto680):03784 FDB SEMIS
3810 (fig-forth-auto680):03785 *
3811 (fig-forth-auto680):03786 * ======>> 135 <<
3812 (fig-forth-auto680):03787 * ( adr n --- )
3813 (fig-forth-auto680):03788 * Fill n bytes with ASCII SPACE.
3814 1E7A 86 (fig-forth-auto680):03789 FCB $86
3815 1E7B 424C414E4B (fig-forth-auto680):03790 FCC 'BLANK' ; 'BLANKS'
3816 1E80 D3 (fig-forth-auto680):03791 FCB $D3
3817 1E81 1E6A (fig-forth-auto680):03792 FDB ERASE-8
3818 1E83 17B9185E1E52 (fig-forth-auto680):03793 BLANKS FDB DOCOL,BL,FILL
3819 1E89 1667 (fig-forth-auto680):03794 FDB SEMIS
3820 (fig-forth-auto680):03795 *
3821 (fig-forth-auto680):03796 * ======>> 136 <<
3822 (fig-forth-auto680):03797 * ( c --- )
3823 (fig-forth-auto680):03798 * Format a character at the left of the HLD output buffer.
3824 1E8B 84 (fig-forth-auto680):03799 FCB $84
3825 1E8C 484F4C (fig-forth-auto680):03800 FCC 'HOL' ; 'HOLD'
3826 1E8F C4 (fig-forth-auto680):03801 FCB $C4
3827 1E90 1E7A (fig-forth-auto680):03802 FDB BLANKS-9
3828 1E92 17B91399FFFF1994 (fig-forth-auto680):03803 HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
3830 1EA2 1667 (fig-forth-auto680):03804 FDB SEMIS
3831 (fig-forth-auto680):03805 *
3832 (fig-forth-auto680):03806 * ======>> 137 <<
3833 (fig-forth-auto680):03807 * ( --- adr )
3834 (fig-forth-auto680):03808 * Give the address of the output PAD buffer.
3835 (fig-forth-auto680):03809 * PAD points to the end of a 68 byte buffer for numeric conversion.
3836 1EA4 83 (fig-forth-auto680):03810 FCB $83
3837 1EA5 5041 (fig-forth-auto680):03811 FCC 'PA' ; 'PAD'
3838 1EA7 C4 (fig-forth-auto680):03812 FCB $C4
3839 1EA8 1E8B (fig-forth-auto680):03813 FDB HOLD-7
3840 1EAA 17B919C713A7 (fig-forth-auto680):03814 PAD FDB DOCOL,HERE,LIT8
3841 1EB0 44 (fig-forth-auto680):03815 FCB $44
3842 1EB1 16C6 (fig-forth-auto680):03816 FDB PLUS
3843 1EB3 1667 (fig-forth-auto680):03817 FDB SEMIS
3844 (fig-forth-auto680):03818 *
3845 (fig-forth-auto680):03819 * ######>> screen 48 <<
3846 (fig-forth-auto680):03820 * ======>> 138 <<
3847 (fig-forth-auto680):03821 * ( c --- )
3848 (fig-forth-auto680):03822 * Scan a string terminated by the character c or ASCII NUL out of input;
3849 (fig-forth-auto680):03823 * store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
3850 (fig-forth-auto680):03824 * Leading c are passed over, per ENCLOSE.
3851 (fig-forth-auto680):03825 * Scans from BLK, or from TIB if BLK is zero.
3852 (fig-forth-auto680):03826 * May overwrite the numeric conversion pad,
3853 (fig-forth-auto680):03827 * if really long (length > 31) symbols are scanned.
3854 1EB5 84 (fig-forth-auto680):03828 FCB $84
3855 1EB6 574F52 (fig-forth-auto680):03829 FCC 'WOR' ; 'WORD'
3856 1EB9 C4 (fig-forth-auto680):03830 FCB $C4
3857 1EBA 1EA4 (fig-forth-auto680):03831 FDB PAD-6
3858 1EBC 17B9190617721409 (fig-forth-auto680):03832 WORD FDB DOCOL,BLK,AT,ZBRAN
3859 1EC4 000A (fig-forth-auto680):03833 FDB WORD2-*-NATWID
3860 1EC6 19061772249213FA (fig-forth-auto680):03834 FDB BLK,AT,BLOCK,BRAN
3861 1ECE 0004 (fig-forth-auto680):03835 FDB WORD3-*-NATWID
3862 1ED0 18BE1772 (fig-forth-auto680):03836 WORD2 FDB TIB,AT
3863 1ED4 190F177216C61736 (fig-forth-auto680):03837 WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
3865 1EE2 22 (fig-forth-auto680):03838 FCB 34
3866 1EE3 1E83190F1751171C (fig-forth-auto680):03839 FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
3868 1EF3 179816C619C719AB (fig-forth-auto680):03840 FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
3870 1EFF 1667 (fig-forth-auto680):03841 FDB SEMIS
3871 (fig-forth-auto680):03842 *
3872 (fig-forth-auto680):03843 * ######>> screen 49 <<
3873 (fig-forth-auto680):03844 * ======>> 139 <<
3874 (fig-forth-auto680):03845 * ( d1 string --- d2 adr )
3875 (fig-forth-auto680):03846 * Convert the text at string into a number, accumulating the result into d1,
3876 (fig-forth-auto680):03847 * leaving adr pointing to the first character not converted.
3877 (fig-forth-auto680):03848 * If DPL is non-negative at entry,
3878 (fig-forth-auto680):03849 * accumulates the number of characters converted into DPL.
3879 1F01 88 (fig-forth-auto680):03850 FCB $88
3880 1F02 284E554D424552 (fig-forth-auto680):03851 FCC '(NUMBER' ; '(NUMBER)'
3881 1F09 A9 (fig-forth-auto680):03852 FCB $A9
3882 1F0A 1EB5 (fig-forth-auto680):03853 FDB WORD-7
3883 1F0C 17B9 (fig-forth-auto680):03854 PNUMB FDB DOCOL
3884 1F0E 19AB17451681177E (fig-forth-auto680):03855 PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
3886 1F1E 002A (fig-forth-auto680):03856 FDB PNUMB4-*-NATWID
3887 1F20 17361963177215A5 (fig-forth-auto680):03857 FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
3889 1F2E 177215A516D4196D (fig-forth-auto680):03858 FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
3891 1F3C 0006 (fig-forth-auto680):03859 FDB PNUMB3-*-NATWID
3892 1F3E 1845196D1751 (fig-forth-auto680):03860 FDB ONE,DPL,PSTORE
3893 1F44 169013FA (fig-forth-auto680):03861 PNUMB3 FDB FROMR,BRAN
3894 1F48 FFC4 (fig-forth-auto680):03862 FDB PNUMB2-*-NATWID
3895 1F4A 1690 (fig-forth-auto680):03863 PNUMB4 FDB FROMR
3896 1F4C 1667 (fig-forth-auto680):03864 FDB SEMIS
3897 (fig-forth-auto680):03865 *
3898 (fig-forth-auto680):03866 * ======>> 140 <<
3899 (fig-forth-auto680):03867 * ( ctstr --- d )
3900 (fig-forth-auto680):03868 * Convert text at ctstr to a double integer,
3901 (fig-forth-auto680):03869 * taking the 0 ERROR if the conversion is not valid.
3902 (fig-forth-auto680):03870 * If a decimal point is present,
3903 (fig-forth-auto680):03871 * accumulate the count of digits to the decimal point's right into DPL
3904 (fig-forth-auto680):03872 * (negative DPL at exit indicates single precision).
3905 (fig-forth-auto680):03873 * ctstr is a counted string
3906 (fig-forth-auto680):03874 * -- the first byte at ctstr is the length of the string,
3907 (fig-forth-auto680):03875 * but NUMBER ignores the count and expects a NUL terminator instead.
3908 1F4E 86 (fig-forth-auto680):03876 FCB $86
3909 1F4F 4E554D4245 (fig-forth-auto680):03877 FCC 'NUMBE' ; 'NUMBER'
3910 1F54 D2 (fig-forth-auto680):03878 FCB $D2
3911 1F55 1F01 (fig-forth-auto680):03879 FDB PNUMB-11
3912 1F57 17B9183D183D1A43 (fig-forth-auto680):03880 NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
3914 1F67 2D (fig-forth-auto680):03881 FCC "-" minus sign
3915 1F68 1A111745168116C6 (fig-forth-auto680):03882 FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
3917 1F74 196D178A1F0C1745 (fig-forth-auto680):03883 NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
3919 1F82 1409 (fig-forth-auto680):03884 FDB ZBRAN
3920 1F84 0013 (fig-forth-auto680):03885 FDB NUMB2-*-NATWID
3921 1F86 1745177E13A7 (fig-forth-auto680):03886 FDB DUP,CAT,LIT8
3922 1F8C 2E (fig-forth-auto680):03887 FCC "."
3923 1F8D 1A04183D1B39183D (fig-forth-auto680):03888 FDB SUB,ZERO,QERR,ZERO,BRAN
3925 1F97 FFDB (fig-forth-auto680):03889 FDB NUMB1-*-NATWID
3926 1F99 172A16901409 (fig-forth-auto680):03890 NUMB2 FDB DROP,FROMR,ZBRAN
3927 1F9F 0002 (fig-forth-auto680):03891 FDB NUMB3-*-NATWID
3928 1FA1 1702 (fig-forth-auto680):03892 FDB DMINUS
3929 1FA3 1667 (fig-forth-auto680):03893 NUMB3 FDB SEMIS
3930 (fig-forth-auto680):03894 *
3931 (fig-forth-auto680):03895 * ======>> 141 <<
3932 (fig-forth-auto680):03896 * ( --- locptr length true ) { -FIND name } typical input
3933 (fig-forth-auto680):03897 * ( --- false )
3934 (fig-forth-auto680):03898 * Parse a word, then FIND,
3935 (fig-forth-auto680):03899 * first in the definition vocabulary,
3936 (fig-forth-auto680):03900 * then in the CONTEXT (interpretation) vocabulary, if necessary.
3937 (fig-forth-auto680):03901 * Returns what (FIND) returns, flag and optional location and length.
3938 1FA5 85 (fig-forth-auto680):03902 FCB $85
3939 1FA6 2D46494E (fig-forth-auto680):03903 FCC '-FIN' ; '-FIND'
3940 1FAA C4 (fig-forth-auto680):03904 FCB $C4
3941 1FAB 1F4E (fig-forth-auto680):03905 FDB NUMB-9
3942 1FAD 17B9185E1EBC19C7 (fig-forth-auto680):03906 DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
3944 1FBB 14AF174516A31409 (fig-forth-auto680):03907 FDB PFIND,DUP,ZEQU,ZBRAN
3945 1FC3 0008 (fig-forth-auto680):03908 FDB DFIND2-*-NATWID
3946 1FC5 172A19C71AD014AF (fig-forth-auto680):03909 FDB DROP,HERE,LATEST,PFIND
3947 1FCD 1667 (fig-forth-auto680):03910 DFIND2 FDB SEMIS
3948 (fig-forth-auto680):03911 *
3949 (fig-forth-auto680):03912 * ######>> screen 50 <<
3950 (fig-forth-auto680):03913 * ======>> 142 <<
3951 (fig-forth-auto680):03914 * ( anything --- nothing ) ( anything *** nothing )
3952 (fig-forth-auto680):03915 * An indirection for ABORT, for ERROR,
3953 (fig-forth-auto680):03916 * which may be modified carefully.
3954 1FCF 87 (fig-forth-auto680):03917 FCB $87
3955 1FD0 2841424F5254 (fig-forth-auto680):03918 FCC '(ABORT' ; '(ABORT)'
3956 1FD6 A9 (fig-forth-auto680):03919 FCB $A9
3957 1FD7 1FA5 (fig-forth-auto680):03920 FDB DFIND-8
3958 1FD9 17B92205 (fig-forth-auto680):03921 PABORT FDB DOCOL,ABORT
3959 1FDD 1667 (fig-forth-auto680):03922 FDB SEMIS
3960 (fig-forth-auto680):03923 *
3961 (fig-forth-auto680):03924 * ======>> 143 <<
3962 1FDF 85 (fig-forth-auto680):03925 FCB $85
3963 1FE0 4552524F (fig-forth-auto680):03926 FCC 'ERRO' ; 'ERROR'
3964 1FE4 D2 (fig-forth-auto680):03927 FCB $D2
3965 1FE5 1FCF (fig-forth-auto680):03928 FDB PABORT-10
3966 (fig-forth-auto680):03929 * This really should not be high level, according to best practices.
3967 (fig-forth-auto680):03930 * But fixing that cascades through MESSAGE,
3968 (fig-forth-auto680):03931 * requiring re-architecting the disk block system.
3969 (fig-forth-auto680):03932 * First, we need to get this transliteration running.
3970 1FE7 17B918D8177216B5 (fig-forth-auto680):03933 ERROR FDB DOCOL,WARN,AT,ZLESS
3971 1FEF 1409 (fig-forth-auto680):03934 FDB ZBRAN
3972 1FF1 0002 (fig-forth-auto680):03935 FDB ERROR2-*-NATWID
3973 (fig-forth-auto680):03936 * note: WARNING is
3974 (fig-forth-auto680):03937 * -1 to abort,
3975 (fig-forth-auto680):03938 * 0 to print error #
3976 (fig-forth-auto680):03939 * and 1 to print error message from disc
3977 1FF3 1FD9 (fig-forth-auto680):03940 FDB PABORT
3978 1FF5 19C71C9C1CAF1D10 (fig-forth-auto680):03941 ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
3979 1FFD 0407 (fig-forth-auto680):03942 FCB 4,7 ( bell )
3980 1FFF 203F20 (fig-forth-auto680):03943 FCC " ? "
3981 2002 252B164D190F1772 (fig-forth-auto680):03944 FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
3983 2010 1667 (fig-forth-auto680):03945 FDB SEMIS
3984 (fig-forth-auto680):03946 *
3985 (fig-forth-auto680):03947 * ======>> 144 <<
3986 (fig-forth-auto680):03948 * ( n adr --- )
3987 (fig-forth-auto680):03949 * Mask byte at adr with n.
3988 (fig-forth-auto680):03950 * Not in FIG, don't need it for 8 bit characters after all.
3989 (fig-forth-auto680):03951 * FCB $85
3990 (fig-forth-auto680):03952 * FCC 'CMAS' ; 'CMASK'
3991 (fig-forth-auto680):03953 * FCB $CB ; 'K'
3992 (fig-forth-auto680):03954 * FDB ERROR-8
3993 (fig-forth-auto680):03955 * CMASK FDB *+NATWID
3994 (fig-forth-auto680):03956 * LDX ,U++ ; adr
3995 (fig-forth-auto680):03957 * LDD ,U++ ; mask
3996 (fig-forth-auto680):03958 * ANDB ,X
3997 (fig-forth-auto680):03959 * STB ,X
3998 (fig-forth-auto680):03960 * RTS
3999 (fig-forth-auto680):03961 *
4000 (fig-forth-auto680):03962 * ( adr --- adr )
4001 (fig-forth-auto680):03963 * Mask high bit of tail of name in PAD buffer.
4002 (fig-forth-auto680):03964 * Not in FIG, need it for 8 bit characters.
4003 2012 86 (fig-forth-auto680):03965 FCB $86
4004 2013 4944464C41 (fig-forth-auto680):03966 FCC 'IDFLA' ; 'IDFLAT'
4005 2018 D4 (fig-forth-auto680):03967 FCB $D4 ; 'T'
4006 2019 1FDF (fig-forth-auto680):03968 FDB ERROR-8
4007 201B 201D (fig-forth-auto680):03969 IDFLAT FDB *+NATWID
4008 201D AEC4 (fig-forth-auto680):03970 LDX ,U
4009 201F E684 (fig-forth-auto680):03971 LDB ,X ; get the count
4010 2021 C43F (fig-forth-auto680):03972 ANDB #CTMASK
4011 2023 A685 (fig-forth-auto680):03973 LDA B,X ; point to the tail
4012 2025 847F (fig-forth-auto680):03974 ANDA #$7F ; Clear the EndOfName flag bit.
4013 2027 A785 (fig-forth-auto680):03975 STA B,X
4014 2029 39 (fig-forth-auto680):03976 RTS
4015 (fig-forth-auto680):03977 *
4016 (fig-forth-auto680):03978 * ( symptr --- )
4017 (fig-forth-auto680):03979 * Print definition's name from its NFA.
4018 202A 83 (fig-forth-auto680):03980 FCB $83
4019 202B 4944 (fig-forth-auto680):03981 FCC 'ID' ; 'ID.'
4020 202D AE (fig-forth-auto680):03982 FCB $AE
4021 202E 2012 (fig-forth-auto680):03983 FDB IDFLAT-9
4022 2030 17B91EAA13A7 (fig-forth-auto680):03984 IDDOT FDB DOCOL,PAD,LIT8
4023 2036 20 (fig-forth-auto680):03985 FCB 32
4024 2037 13A7 (fig-forth-auto680):03986 FDB LIT8
4025 2039 5F (fig-forth-auto680):03987 FCB $5F ( underline )
4026 203A 1E5217451B121AE0 (fig-forth-auto680):03988 FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
4028 (fig-forth-auto680):03989 * FDB SWAP,CMOVE,PAD,COUNT,LIT8
4029 2048 173615841EAA (fig-forth-auto680):03990 FDB SWAP,CMOVE,PAD
4030 204E 201B (fig-forth-auto680):03991 FDB IDFLAT
4031 2050 1C9C13A7 (fig-forth-auto680):03992 FDB COUNT,LIT8
4032 2054 1F (fig-forth-auto680):03993 FCB 31
4033 2055 160E1CAF1A57 (fig-forth-auto680):03994 FDB AND,TYPE,SPACE
4034 205B 1667 (fig-forth-auto680):03995 FDB SEMIS
4035 (fig-forth-auto680):03996 *
4036 (fig-forth-auto680):03997 * ######>> screen 51 <<
4037 (fig-forth-auto680):03998 * ======>> 145 <<
4038 (fig-forth-auto680):03999 * ( --- ) { CREATE name } input
4039 (fig-forth-auto680):04000 * Parse a name (length < 32 characters) and create a header,
4040 (fig-forth-auto680):04001 * reporting first duplicate found in either the defining vocabulary
4041 (fig-forth-auto680):04002 * or the context (interpreting) vocabulary.
4042 (fig-forth-auto680):04003 * Install the header in the defining vocabulary
4043 (fig-forth-auto680):04004 * with CFA dangerously pointing to the parameter field.
4044 (fig-forth-auto680):04005 * Leave the name SMUDGEd.
4045 205D 86 (fig-forth-auto680):04006 FCB $86
4046 205E 4352454154 (fig-forth-auto680):04007 FCC 'CREAT' ; 'CREATE'
4047 2063 C5 (fig-forth-auto680):04008 FCB $C5
4048 2064 202A (fig-forth-auto680):04009 FDB IDDOT-6
4049 2066 17B91FAD1409 (fig-forth-auto680):04010 CREATE FDB DOCOL,DFIND,ZBRAN
4050 206C 0018 (fig-forth-auto680):04011 FDB CREAT2-*-NATWID
4051 206E 172A1D10 (fig-forth-auto680):04012 FDB DROP,PDOTQ
4052 2072 08 (fig-forth-auto680):04013 FCB 8
4053 2073 07 (fig-forth-auto680):04014 FCB 7 ( bel )
4054 2074 72656465663A20 (fig-forth-auto680):04015 FCC "redef: "
4055 207B 1AFD203013A7 (fig-forth-auto680):04016 FDB NFA,IDDOT,LIT8
4056 2081 04 (fig-forth-auto680):04017 FCB 4
4057 2082 252B1A57 (fig-forth-auto680):04018 FDB MESS,SPACE
4058 2086 19C71745177E18CA (fig-forth-auto680):04019 CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
4060 2092 19AB19D7174513A7 (fig-forth-auto680):04020 FDB ONEP,ALLOT,DUP,LIT8
4061 209A A0 (fig-forth-auto680):04021 FCB ($80|FSMUDG) ; Bracket the name.
4062 209B 176519C718451A04 (fig-forth-auto680):04022 FDB TOGGLE,HERE,ONE,SUB,LIT8
4064 20A5 80 (fig-forth-auto680):04023 FCB $80
4065 20A6 17651AD019E3194C (fig-forth-auto680):04024 FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
4067 (fig-forth-auto680):04025 * FDB HERE,TWOP,COMMA
4068 20B2 19C7180219E3 (fig-forth-auto680):04026 FDB HERE,NATP,COMMA
4069 20B8 1667 (fig-forth-auto680):04027 FDB SEMIS
4070 (fig-forth-auto680):04028 *
4071 (fig-forth-auto680):04029 * ######>> screen 52 <<
4072 (fig-forth-auto680):04030 * ======>> 146 <<
4073 (fig-forth-auto680):04031 * ( --- ) P
4074 (fig-forth-auto680):04032 * { [COMPILE] name } typical use
4075 (fig-forth-auto680):04033 * -DFIND next WORD and COMPILE it, literally;
4076 (fig-forth-auto680):04034 * used to compile immediate definitions into words.
4077 20BA C9 (fig-forth-auto680):04035 FCB $C9 immediate
4078 20BB 5B434F4D50494C45 (fig-forth-auto680):04036 FCC '[COMPILE' ; '[COMPILE]'
4079 20C3 DD (fig-forth-auto680):04037 FCB $DD
4080 20C4 205D (fig-forth-auto680):04038 FDB CREATE-9
4081 20C6 17B91FAD16A3183D (fig-forth-auto680):04039 BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
4083 20D6 1667 (fig-forth-auto680):04040 FDB SEMIS
4084 (fig-forth-auto680):04041 *
4085 (fig-forth-auto680):04042 * ======>> 147 <<
4086 (fig-forth-auto680):04043 * ( n --- ) if compiling. P
4087 (fig-forth-auto680):04044 * ( n --- n ) if interpreting.
4088 (fig-forth-auto680):04045 * Compile n as a literal, if compiling.
4089 20D8 C7 (fig-forth-auto680):04046 FCB $C7 immediate
4090 20D9 4C4954455241 (fig-forth-auto680):04047 FCC 'LITERA' ; 'LITERAL'
4091 20DF CC (fig-forth-auto680):04048 FCB $CC
4092 20E0 20BA (fig-forth-auto680):04049 FDB BCOMP-12
4093 20E2 17B9195817721409 (fig-forth-auto680):04050 LITER FDB DOCOL,STATE,AT,ZBRAN
4094 20EA 0006 (fig-forth-auto680):04051 FDB LITER2-*-NATWID
4095 20EC 1BC7139919E3 (fig-forth-auto680):04052 FDB COMPIL,LIT,COMMA
4096 20F2 1667 (fig-forth-auto680):04053 LITER2 FDB SEMIS
4097 (fig-forth-auto680):04054 *
4098 (fig-forth-auto680):04055 * ======>> 148 <<
4099 (fig-forth-auto680):04056 * ( d --- ) if compiling. P
4100 (fig-forth-auto680):04057 * ( d --- d ) if interpreting.
4101 (fig-forth-auto680):04058 * Compile d as a double literal, if compiling.
4102 20F4 C8 (fig-forth-auto680):04059 FCB $C8 immediate
4103 20F5 444C4954455241 (fig-forth-auto680):04060 FCC 'DLITERA' ; 'DLITERAL'
4104 20FC CC (fig-forth-auto680):04061 FCB $CC
4105 20FD 20D8 (fig-forth-auto680):04062 FDB LITER-10
4106 20FF 17B9195817721409 (fig-forth-auto680):04063 DLITER FDB DOCOL,STATE,AT,ZBRAN
4107 2107 0006 (fig-forth-auto680):04064 FDB DLITE2-*-NATWID
4108 2109 173620E220E2 (fig-forth-auto680):04065 FDB SWAP,LITER,LITER ; Just two literals in the right order.
4109 210F 1667 (fig-forth-auto680):04066 DLITE2 FDB SEMIS
4110 (fig-forth-auto680):04067 *
4111 (fig-forth-auto680):04068 * ######>> screen 53 <<
4112 (fig-forth-auto680):04069 * ======>> 149 <<
4113 (fig-forth-auto680):04070 * ( --- )
4114 (fig-forth-auto680):04071 * Interpret or compile, according to STATE.
4115 (fig-forth-auto680):04072 * Searches words parsed in dictionary first, via -FIND,
4116 (fig-forth-auto680):04073 * then checks for valid NUMBER.
4117 (fig-forth-auto680):04074 * Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
4118 (fig-forth-auto680):04075 * ERROR checks the stack via ?STACK before returning to its caller.
4119 2111 89 (fig-forth-auto680):04076 FCB $89
4120 2112 494E544552505245 (fig-forth-auto680):04077 FCC 'INTERPRE' ; 'INTERPRET'
4121 211A D4 (fig-forth-auto680):04078 FCB $D4
4122 211B 20F4 (fig-forth-auto680):04079 FDB DLITER-11
4123 211D 17B9 (fig-forth-auto680):04080 INTERP FDB DOCOL
4124 211F 1FAD1409 (fig-forth-auto680):04081 INTER2 FDB DFIND,ZBRAN
4125 2123 001A (fig-forth-auto680):04082 FDB INTER5-*-NATWID
4126 2125 195817721A1D (fig-forth-auto680):04083 FDB STATE,AT,LESS
4127 212B 1409 (fig-forth-auto680):04084 FDB ZBRAN
4128 212D 0008 (fig-forth-auto680):04085 FDB INTER3-*-NATWID
4129 212F 1AEF19E313FA (fig-forth-auto680):04086 FDB CFA,COMMA,BRAN
4130 2135 0004 (fig-forth-auto680):04087 FDB INTER4-*-NATWID
4131 2137 1AEF13EB (fig-forth-auto680):04088 INTER3 FDB CFA,EXEC
4132 213B 13FA (fig-forth-auto680):04089 INTER4 FDB BRAN
4133 213D 0018 (fig-forth-auto680):04090 FDB INTER7-*-NATWID
4134 213F 19C71F57196D1772 (fig-forth-auto680):04091 INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
4136 214B 0006 (fig-forth-auto680):04092 FDB INTER6-*-NATWID
4137 214D 20FF13FA (fig-forth-auto680):04093 FDB DLITER,BRAN
4138 2151 0004 (fig-forth-auto680):04094 FDB INTER7-*-NATWID
4139 2153 172A20E2 (fig-forth-auto680):04095 INTER6 FDB DROP,LITER
4140 2157 1D5B13FA (fig-forth-auto680):04096 INTER7 FDB QSTACK,BRAN
4141 215B FFC2 (fig-forth-auto680):04097 FDB INTER2-*-NATWID
4142 (fig-forth-auto680):04098 * FDB SEMIS never executed
4143 (fig-forth-auto680):04099
4144 (fig-forth-auto680):04100 *
4145 (fig-forth-auto680):04101 * ######>> screen 54 <<
4146 (fig-forth-auto680):04102 * ======>> 150 <<
4147 (fig-forth-auto680):04103 * ( --- )
4148 (fig-forth-auto680):04104 * Toggle precedence bit of LATEST definition header.
4149 (fig-forth-auto680):04105 * During compiling, most symbols scanned are compiled.
4150 (fig-forth-auto680):04106 * IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
4151 (fig-forth-auto680):04107 * but may be compiled via ' (TICK).
4152 215D 89 (fig-forth-auto680):04108 FCB $89
4153 215E 494D4D4544494154 (fig-forth-auto680):04109 FCC 'IMMEDIAT' ; 'IMMEDIATE'
4154 2166 C5 (fig-forth-auto680):04110 FCB $C5
4155 2167 2111 (fig-forth-auto680):04111 FDB INTERP-12
4156 2169 17B91AD013A7 (fig-forth-auto680):04112 IMMED FDB DOCOL,LATEST,LIT8
4157 216F 40 (fig-forth-auto680):04113 FCB FIMMED
4158 2170 1765 (fig-forth-auto680):04114 FDB TOGGLE
4159 2172 1667 (fig-forth-auto680):04115 FDB SEMIS
4160 (fig-forth-auto680):04116 *
4161 (fig-forth-auto680):04117 * ======>> 151 <<
4162 (fig-forth-auto680):04118 * ( --- ) { VOCABULARY name } input
4163 (fig-forth-auto680):04119 * Create a vocabulary entry with a flag for terminating vocabulary searches.
4164 (fig-forth-auto680):04120 * Store the current search context in it for linking.
4165 (fig-forth-auto680):04121 * At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
4166 2174 8A (fig-forth-auto680):04122 FCB $8A
4167 2175 564F434142554C41 (fig-forth-auto680):04123 FCC 'VOCABULAR' ; 'VOCABULARY'
4169 217E D9 (fig-forth-auto680):04124 FCB $D9
4170 217F 215D (fig-forth-auto680):04125 FDB IMMED-12
4171 2181 17B91C6A139981A0 (fig-forth-auto680):04126 VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
4173 2191 19E319C718FC1772 (fig-forth-auto680):04127 FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
4175 (fig-forth-auto680):04128 * DOVOC FDB TWOP,CONTXT,STORE
4176 21A1 1802193E178A (fig-forth-auto680):04129 DOVOC FDB NATP,CONTXT,STORE
4177 21A7 1667 (fig-forth-auto680):04130 FDB SEMIS
4178 (fig-forth-auto680):04131 *
4179 (fig-forth-auto680):04132 * ======>> 152 <<
4180 (fig-forth-auto680):04133 *
4181 (fig-forth-auto680):04134 * Note: FORTH does not go here in the rom-able dictionary,
4182 (fig-forth-auto680):04135 * since FORTH is a type of variable.
4183 (fig-forth-auto680):04136 *
4184 (fig-forth-auto680):04137 * (Should make a proper architecture for this at some point.)
4185 (fig-forth-auto680):04138 *
4186 (fig-forth-auto680):04139 *
4187 (fig-forth-auto680):04140 * ======>> 153 <<
4188 (fig-forth-auto680):04141 * ( --- )
4189 (fig-forth-auto680):04142 * Makes the current interpretation CONTEXT vocabulary
4190 (fig-forth-auto680):04143 * also the CURRENT defining vocabulary.
4191 21A9 8B (fig-forth-auto680):04144 FCB $8B
4192 21AA 444546494E495449 (fig-forth-auto680):04145 FCC 'DEFINITION' ; 'DEFINITIONS'
4194 21B4 D3 (fig-forth-auto680):04146 FCB $D3
4195 21B5 2174 (fig-forth-auto680):04147 FDB VOCAB-13
4196 21B7 17B9193E1772194C (fig-forth-auto680):04148 DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
4198 21C1 1667 (fig-forth-auto680):04149 FDB SEMIS
4199 (fig-forth-auto680):04150 *
4200 (fig-forth-auto680):04151 * ======>> 154 <<
4201 (fig-forth-auto680):04152 * ( --- )
4202 (fig-forth-auto680):04153 * Parse out a comment and toss it away.
4203 (fig-forth-auto680):04154 * Leaves the first 32 characters in WORDPAD, which may or may not be useful.
4204 21C3 C1 (fig-forth-auto680):04155 FCB $C1 immediate (
4205 21C4 A8 (fig-forth-auto680):04156 FCB $A8
4206 21C5 21A9 (fig-forth-auto680):04157 FDB DEFIN-14
4207 21C7 17B913A7 (fig-forth-auto680):04158 PAREN FDB DOCOL,LIT8
4208 21CB 29 (fig-forth-auto680):04159 FCC ")"
4209 21CC 1EBC (fig-forth-auto680):04160 FDB WORD
4210 21CE 1667 (fig-forth-auto680):04161 FDB SEMIS
4211 (fig-forth-auto680):04162 *
4212 (fig-forth-auto680):04163 * ######>> screen 55 <<
4213 (fig-forth-auto680):04164 * ======>> 155 <<
4214 (fig-forth-auto680):04165 * ( anything *** nothing )
4215 (fig-forth-auto680):04166 * Clear return stack.
4216 (fig-forth-auto680):04167 * Then INTERPRET and, if not compiling, prompt with OK,
4217 (fig-forth-auto680):04168 * in infinite loop.
4218 21D0 84 (fig-forth-auto680):04169 FCB $84
4219 21D1 515549 (fig-forth-auto680):04170 FCC 'QUI' ; 'QUIT'
4220 21D4 D4 (fig-forth-auto680):04171 FCB $D4
4221 21D5 21C3 (fig-forth-auto680):04172 FDB PAREN-4
4222 21D7 17B9183D1906178A (fig-forth-auto680):04173 QUIT FDB DOCOL,ZERO,BLK,STORE
4223 21DF 1BDD (fig-forth-auto680):04174 FDB LBRAK
4224 (fig-forth-auto680):04175 *
4225 (fig-forth-auto680):04176 * Here is the outer interpretter
4226 (fig-forth-auto680):04177 * which gets a line of input, does it, prints " OK"
4227 (fig-forth-auto680):04178 * then repeats :
4228 21E1 165815771DFF211D (fig-forth-auto680):04179 QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
4230 21EF 1409 (fig-forth-auto680):04180 FDB ZBRAN
4231 21F1 0006 (fig-forth-auto680):04181 FDB QUIT3-*-NATWID
4232 21F3 1D10 (fig-forth-auto680):04182 FDB PDOTQ
4233 21F5 03 (fig-forth-auto680):04183 FCB 3
4234 21F6 204F4B (fig-forth-auto680):04184 FCC ' OK' ; ' OK'
4235 21F9 13FA (fig-forth-auto680):04185 QUIT3 FDB BRAN
4236 21FB FFE4 (fig-forth-auto680):04186 FDB QUIT2-*-NATWID
4237 (fig-forth-auto680):04187 * FDB SEMIS ( never executed )
4238 (fig-forth-auto680):04188 *
4239 (fig-forth-auto680):04189 * ======>> 156 <<
4240 (fig-forth-auto680):04190 * ( anything --- nothing ) ( anything *** nothing )
4241 (fig-forth-auto680):04191 * Clear parameter stack,
4242 (fig-forth-auto680):04192 * set STATE to interpret and BASE to DECIMAL,
4243 (fig-forth-auto680):04193 * return to input from terminal,
4244 (fig-forth-auto680):04194 * restore DRIVE OFFSET to 0,
4245 (fig-forth-auto680):04195 * print out "Forth-68",
4246 (fig-forth-auto680):04196 * set interpret and define vocabularies to FORTH,
4247 (fig-forth-auto680):04197 * and finally, QUIT.
4248 (fig-forth-auto680):04198 * Used to force the system to a known state
4249 (fig-forth-auto680):04199 * and return control to the initial INTERPRETer.
4250 21FD 85 (fig-forth-auto680):04200 FCB $85
4251 21FE 41424F52 (fig-forth-auto680):04201 FCC 'ABOR' ; 'ABORT'
4252 2202 D4 (fig-forth-auto680):04202 FCB $D4
4253 2203 21D0 (fig-forth-auto680):04203 FDB QUIT-7
4254 2205 17B9164D1C251D5B (fig-forth-auto680):04204 ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
4256 2213 0A (fig-forth-auto680):04205 FCB 10
4257 2214 466F7274682D3638 (fig-forth-auto680):04206 FCC "Forth-6809"
4259 221E 2A9D21B7 (fig-forth-auto680):04207 FDB FORTH,DEFIN
4260 2222 21D7 (fig-forth-auto680):04208 FDB QUIT
4261 (fig-forth-auto680):04209 * FDB SEMIS never executed
4262 (fig-forth-auto680):04210 PAGE
4263 (fig-forth-auto680):04211 *
4264 (fig-forth-auto680):04212 * ######>> screen 56 <<
4265 (fig-forth-auto680):04213 * bootstrap code... moves rom contents to ram :
4266 (fig-forth-auto680):04214 * ======>> 157 <<
4267 2224 84 (fig-forth-auto680):04215 FCB $84
4268 2225 434F4C (fig-forth-auto680):04216 FCC 'COL' ; 'COLD'
4269 2228 C4 (fig-forth-auto680):04217 FCB $C4
4270 2229 21FD (fig-forth-auto680):04218 FDB ABORT-8
4271 222B 222D (fig-forth-auto680):04219 COLD FDB *+NATWID
4272 (fig-forth-auto680):04220 * Ultimately, we want position indepence,
4273 (fig-forth-auto680):04221 * so I'm using PCR where it seems reasonable.
4274 222D 10EE8DEFE0 (fig-forth-auto680):04222 CENT LDS SINIT,PCR ; Get a useable return stack, at least.
4275 2232 867C (fig-forth-auto680):04223 LDA #IUPDP ; This is not relative to PC.
4276 2234 1F8B (fig-forth-auto680):04224 TFR A,DP ; And a useable direct page, too.
4277 7C (fig-forth-auto680):04225 SETDP IUPDP ; (For good measure.)
4278 (fig-forth-auto680):04226 *
4279 (fig-forth-auto680):04227 * We'll keep this here for the time being.
4280 (fig-forth-auto680):04228 * There are better ways to do this, of course.
4281 (fig-forth-auto680):04229 * Re-architect, re-architect.
4282 2236 308D006A (fig-forth-auto680):04230 LEAX RAM,PCR
4283 223A 9F28 (fig-forth-auto680):04231 STX <XFENCE ; Borrow this variable for a loop terminator.
4284 223C 318D0890 (fig-forth-auto680):04232 LEAY REND,PCR ; top of destination
4285 2240 308D00A3 (fig-forth-auto680):04233 LEAX ERAM,PCR ; top of stuff to move
4286 2244 A682 (fig-forth-auto680):04234 COLD2 LDA ,-X
4287 2246 A7A2 (fig-forth-auto680):04235 STA ,-Y ; move TASK & FORTH to ram
4288 2248 9C28 (fig-forth-auto680):04236 CMPX <XFENCE
4289 224A 26F8 (fig-forth-auto680):04237 BNE COLD2
4290 (fig-forth-auto680):04238 *
4291 (fig-forth-auto680):04239 * CENT LDS #REND-1 top of destination
4292 (fig-forth-auto680):04240 * LDX #ERAM top of stuff to move
4293 (fig-forth-auto680):04241 * COLD2 LEAX -1,X ;
4294 (fig-forth-auto680):04242 * LDA 0,X
4295 (fig-forth-auto680):04243 * PSHS A ; move TASK & FORTH to ram
4296 (fig-forth-auto680):04244 * CMPX #RAM
4297 (fig-forth-auto680):04245 * BNE COLD2
4298 (fig-forth-auto680):04246 *
4299 (fig-forth-auto680):04247 * LDS #XFENCE-1 put stack at a safe place for now
4300 (fig-forth-auto680):04248 * But that is taken care of.
4301 (fig-forth-auto680):04249 * LDX COLINT
4302 (fig-forth-auto680):04250 * STX XCOLUM
4303 224C AE8DEFD2 (fig-forth-auto680):04251 LDX COLINT,PCR
4304 2250 9F4C (fig-forth-auto680):04252 STX <XCOLUM
4305 (fig-forth-auto680):04253 * LDX DELINT
4306 (fig-forth-auto680):04254 * STX XDELAY
4307 2252 AE8DEFCE (fig-forth-auto680):04255 LDX DELINT,PCR
4308 2256 9F4A (fig-forth-auto680):04256 STX <XDELAY
4309 (fig-forth-auto680):04257 * LDX VOCINT
4310 (fig-forth-auto680):04258 * STX XVOCL
4311 2258 AE8DEFC4 (fig-forth-auto680):04259 LDX VOCINT,PCR
4312 225C 9F2C (fig-forth-auto680):04260 STX <XVOCL
4313 (fig-forth-auto680):04261 * LDX DPINIT
4314 (fig-forth-auto680):04262 * STX XDICTP
4315 225E AE8DEFBC (fig-forth-auto680):04263 LDX DPINIT,PCR
4316 2262 9F2A (fig-forth-auto680):04264 STX <XDICTP
4317 (fig-forth-auto680):04265 * LDX FENCIN
4318 (fig-forth-auto680):04266 * STX XFENCE
4319 2264 AE8DEFB4 (fig-forth-auto680):04267 LDX FENCIN,PCR
4320 2268 9F28 (fig-forth-auto680):04268 STX <XFENCE
4321 (fig-forth-auto680):04269 *
4322 226A 10EE8DEFA3 (fig-forth-auto680):04270 WENT LDS SINIT,PCR ; Get a useable return stack, at least.
4323 226F 867C (fig-forth-auto680):04271 LDA #IUPDP ; This is not relative to PC.
4324 2271 1F8B (fig-forth-auto680):04272 TFR A,DP ; And a useable direct page, too.
4325 7C (fig-forth-auto680):04273 SETDP IUPDP ; (For good measure.)
4326 (fig-forth-auto680):04274 *
4327 2273 308DEF9B (fig-forth-auto680):04275 LEAX SINIT,PCR
4328 2277 3410 (fig-forth-auto680):04276 PSHS X ; for loop termination
4329 2279 5F (fig-forth-auto680):04277 CLRB ; Yes, I'm being a little ridiculous. Only a little.
4330 227A 1F02 (fig-forth-auto680):04278 TFR D,Y
4331 227C 31A828 (fig-forth-auto680):04279 LEAY XFENCE-UORIG,Y ; top of destination
4332 227F 308DEF99 (fig-forth-auto680):04280 LEAX FENCIN,PCR ; top of stuff to move
4333 2283 EC83 (fig-forth-auto680):04281 WARM2 LDD ,--X ; All entries are 16 bit.
4334 2285 EDA3 (fig-forth-auto680):04282 STD ,--Y
4335 2287 ACE4 (fig-forth-auto680):04283 CMPX ,S
4336 2289 26F8 (fig-forth-auto680):04284 BNE WARM2
4337 228B 3262 (fig-forth-auto680):04285 LEAS 2,S ; But we'll reset the return stack shortly, anyway.
4338 (fig-forth-auto680):04286 * WENT LDS #XFENCE-1 top of destination
4339 (fig-forth-auto680):04287 * LDX #FENCIN top of stuff to move
4340 (fig-forth-auto680):04288 * WARM2 LEAX -1,X ;
4341 (fig-forth-auto680):04289 * LDA 0,X
4342 (fig-forth-auto680):04290 * PSHS A ;
4343 (fig-forth-auto680):04291 * CMPX #SINIT
4344 (fig-forth-auto680):04292 * BNE WARM2
4345 (fig-forth-auto680):04293 *
4346 (fig-forth-auto680):04294 * LDS SINIT
4347 (fig-forth-auto680):04295 * S is already there.
4348 (fig-forth-auto680):04296 * LDX UPINIT
4349 (fig-forth-auto680):04297 * STX UP init user ram pointer
4350 (fig-forth-auto680):04298 * UP is already there (DP).
4351 (fig-forth-auto680):04299 * LDX #ABORT
4352 (fig-forth-auto680):04300 * STX IP
4353 228D 318DFF76 (fig-forth-auto680):04301 LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
4354 (fig-forth-auto680):04302 *
4355 2291 12 (fig-forth-auto680):04303 NOP Here is a place to jump to special user
4356 2292 12 (fig-forth-auto680):04304 NOP initializations such as I/0 interrups
4357 2293 12 (fig-forth-auto680):04305 NOP
4358 (fig-forth-auto680):04306 *
4359 (fig-forth-auto680):04307 * For systems with TRACE:
4360 2294 8E0000 (fig-forth-auto680):04308 LDX #00
4361 (fig-forth-auto680):04309 * STX TRLIM clear trace mode
4362 2297 9F0A (fig-forth-auto680):04310 STX <TRLIM clear trace mode (both bytes)
4363 2299 8E0000 (fig-forth-auto680):04311 LDX #0
4364 (fig-forth-auto680):04312 * STX BRKPT clear breakpoint address
4365 229C 9F0C (fig-forth-auto680):04313 STX <BRKPT clear breakpoint address
4366 (fig-forth-auto680):04314 * JMP RPSTOR+2 start the virtual machine running !
4367 229E 17F3B9 (fig-forth-auto680):04315 LBSR RPSTOR+NATWID start the virtual machine running !
4368 22A1 16EF84 (fig-forth-auto680):04316 LBRA NEXT ; But we must also give RP! someplace to return.
4369 (fig-forth-auto680):04317 * RP! sets up the return stack pointer, then Y references abort.
4370 (fig-forth-auto680):04318 *
4371 (fig-forth-auto680):04319 * Here is the stuff that gets copied to ram :
4372 (fig-forth-auto680):04320 * (not * at address $140:)
4373 (fig-forth-auto680):04321 * at an appropriate address:
4374 (fig-forth-auto680):04322 *
4375 22A4 3000300000000000 (fig-forth-auto680):04323 RAM FDB $3000,$3000,0,0
4376 (fig-forth-auto680):04324
4377 (fig-forth-auto680):04325 * ======>> (152) <<
4378 (fig-forth-auto680):04326 * ( --- ) P
4379 (fig-forth-auto680):04327 * Makes FORTH the current interpretation vocabulary.
4380 (fig-forth-auto680):04328 * In order to make this ROMmable, this entry is set up as the tail-end,
4381 (fig-forth-auto680):04329 * and copied to RAM in the start-up code.
4382 (fig-forth-auto680):04330 * We want a more elegant solution to this, too. Greedy, maybe.
4383 22AC C5 (fig-forth-auto680):04331 FCB $C5 immediate
4384 22AD 464F5254 (fig-forth-auto680):04332 FCC 'FORT' ; 'FORTH'
4385 22B1 C8 (fig-forth-auto680):04333 FCB $C8
4386 22B2 2A7C (fig-forth-auto680):04334 FDB NOOP-7 ; Note that this does not link to COLD!
4387 22B4 1C8621A181A02AC5 (fig-forth-auto680):04335 RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
4388 22BC 0000 (fig-forth-auto680):04336 FDB 0
4389 22BE 28432920466F7274 (fig-forth-auto680):04337 FCC "(C) Forth Interest Group, 1979"
4393 22DC 84 (fig-forth-auto680):04338 FCB $84
4394 22DD 544153 (fig-forth-auto680):04339 FCC 'TAS' ; 'TASK'
4395 22E0 CB (fig-forth-auto680):04340 FCB $CB
4396 22E1 2A95 (fig-forth-auto680):04341 FDB FORTH-8
4397 22E3 17B91667 (fig-forth-auto680):04342 RTASK FDB DOCOL,SEMIS
4398 22E7 4461766964204C69 (fig-forth-auto680):04343 ERAM FCC "David Lion"
4400 (fig-forth-auto680):04344 PAGE
4401 (fig-forth-auto680):04345 *
4402 (fig-forth-auto680):04346 * ######>> screen 57 <<
4403 (fig-forth-auto680):04347 * ======>> 158 <<
4404 (fig-forth-auto680):04348 * ( n0 --- d0 )
4405 (fig-forth-auto680):04349 * Sign extend n0 to a double integer.
4406 22F1 84 (fig-forth-auto680):04350 FCB $84
4407 22F2 532D3E (fig-forth-auto680):04351 FCC 'S->' ; 'S->D'
4408 22F5 C4 (fig-forth-auto680):04352 FCB $C4
4409 22F6 2224 (fig-forth-auto680):04353 FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
4410 22F8 17B9174516B516EF (fig-forth-auto680):04354 STOD FDB DOCOL,DUP,ZLESS,MINUS
4411 2300 1667 (fig-forth-auto680):04355 FDB SEMIS
4412 (fig-forth-auto680):04356
4413 (fig-forth-auto680):04357
4414 (fig-forth-auto680):04358 *
4415 (fig-forth-auto680):04359 * ======>> 159 <<
4416 (fig-forth-auto680):04360 * ( multiplier multiplicand --- product )
4417 (fig-forth-auto680):04361 * Signed word multiply.
4418 2302 81 (fig-forth-auto680):04362 FCB $81 ; *
4419 2303 AA (fig-forth-auto680):04363 FCB $AA
4420 2304 22F1 (fig-forth-auto680):04364 FDB STOD-7
4421 2306 2308 (fig-forth-auto680):04365 STAR FDB *+NATWID
4422 2308 17F29C (fig-forth-auto680):04366 LBSR USTAR+NATWID ; or [USTAR,PCR]?
4423 230B 3342 (fig-forth-auto680):04367 LEAU NATWID,U ; Drop high word.
4424 230D 39 (fig-forth-auto680):04368 RTS
4425 (fig-forth-auto680):04369 * JSR USTARS
4426 (fig-forth-auto680):04370 * LEAS 1,S ;
4427 (fig-forth-auto680):04371 * LEAS 1,S ;
4428 (fig-forth-auto680):04372 * JMP NEXT
4429 (fig-forth-auto680):04373 *
4430 (fig-forth-auto680):04374 * ======>> 160 <<
4431 (fig-forth-auto680):04375 * ( dividend divisor --- remainder quotient )
4432 (fig-forth-auto680):04376 * M/ in word-only form, i. e., signed division of 2nd word by top word,
4433 (fig-forth-auto680):04377 * yielding signed word quotient and remainder.
4434 230E 84 (fig-forth-auto680):04378 FCB $84
4435 230F 2F4D4F (fig-forth-auto680):04379 FCC '/MO' ; '/MOD'
4436 2312 C4 (fig-forth-auto680):04380 FCB $C4
4437 2313 2302 (fig-forth-auto680):04381 FDB STAR-4
4438 2315 17B9168122F81690 (fig-forth-auto680):04382 SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
4440 231F 1667 (fig-forth-auto680):04383 FDB SEMIS
4441 (fig-forth-auto680):04384 *
4442 (fig-forth-auto680):04385 * ======>> 161 <<
4443 (fig-forth-auto680):04386 * ( dividend divisor --- quotient )
4444 (fig-forth-auto680):04387 * Signed word divide without remainder.
4445 2321 81 (fig-forth-auto680):04388 FCB $81 ; /
4446 2322 AF (fig-forth-auto680):04389 FCB $AF
4447 2323 230E (fig-forth-auto680):04390 FDB SLMOD-7
4448 2325 17B923151736172A (fig-forth-auto680):04391 SLASH FDB DOCOL,SLMOD,SWAP,DROP
4449 232D 1667 (fig-forth-auto680):04392 FDB SEMIS
4450 (fig-forth-auto680):04393 *
4451 (fig-forth-auto680):04394 * ======>> 162 <<
4452 (fig-forth-auto680):04395 * ( dividend divisor --- remainder )
4453 (fig-forth-auto680):04396 * Remainder function, result takes sign of dividend.
4454 232F 83 (fig-forth-auto680):04397 FCB $83
4455 2330 4D4F (fig-forth-auto680):04398 FCC 'MO' ; 'MOD'
4456 2332 C4 (fig-forth-auto680):04399 FCB $C4
4457 2333 2321 (fig-forth-auto680):04400 FDB SLASH-4
4458 2335 17B92315172A (fig-forth-auto680):04401 MOD FDB DOCOL,SLMOD,DROP
4459 233B 1667 (fig-forth-auto680):04402 FDB SEMIS
4460 (fig-forth-auto680):04403 *
4461 (fig-forth-auto680):04404 * ======>> 163 <<
4462 (fig-forth-auto680):04405 * ( multiplier multiplicand divisor --- remainder quotient )
4463 (fig-forth-auto680):04406 * Signed precise division of product:
4464 (fig-forth-auto680):04407 * multiply 2nd and 3rd words on stack
4465 (fig-forth-auto680):04408 * and divide the 31-bit product by the top word,
4466 (fig-forth-auto680):04409 * leaving both quotient and remainder.
4467 (fig-forth-auto680):04410 * Remainder takes sign of product.
4468 (fig-forth-auto680):04411 * Guaranteed not to lose significant bits in 16 bit integer math.
4469 233D 85 (fig-forth-auto680):04412 FCB $85
4470 233E 2A2F4D4F (fig-forth-auto680):04413 FCC '*/MO' ; '*/MOD'
4471 2342 C4 (fig-forth-auto680):04414 FCB $C4
4472 2343 232F (fig-forth-auto680):04415 FDB MOD-6
4473 2345 17B9168115A51690 (fig-forth-auto680):04416 SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
4475 234F 1667 (fig-forth-auto680):04417 FDB SEMIS
4476 (fig-forth-auto680):04418 *
4477 (fig-forth-auto680):04419 * ======>> 164 <<
4478 (fig-forth-auto680):04420 * ( multiplier multiplicand divisor --- quotient )
4479 (fig-forth-auto680):04421 * */MOD without remainder.
4480 2351 82 (fig-forth-auto680):04422 FCB $82
4481 2352 2A (fig-forth-auto680):04423 FCC '*' ; '*/'
4482 2353 AF (fig-forth-auto680):04424 FCB $AF
4483 2354 233D (fig-forth-auto680):04425 FDB SSMOD-8
4484 2356 17B923451736172A (fig-forth-auto680):04426 SSLASH FDB DOCOL,SSMOD,SWAP,DROP
4485 235E 1667 (fig-forth-auto680):04427 FDB SEMIS
4486 (fig-forth-auto680):04428 *
4487 (fig-forth-auto680):04429 * ======>> 165 <<
4488 (fig-forth-auto680):04430 * ( ud1 u1 --- u2 ud2 )
4489 (fig-forth-auto680):04431 * U/ with an (unsigned) double quotient.
4490 (fig-forth-auto680):04432 * Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
4491 (fig-forth-auto680):04433 * if you are prepared to deal with the extra 16 bits of result.
4492 2360 85 (fig-forth-auto680):04434 FCB $85
4493 2361 4D2F4D4F (fig-forth-auto680):04435 FCC 'M/MO' ; 'M/MOD'
4494 2365 C4 (fig-forth-auto680):04436 FCB $C4
4495 2366 2351 (fig-forth-auto680):04437 FDB SSLASH-5
4496 2368 17B91681183D169C (fig-forth-auto680):04438 MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
4498 2372 16901736168115DB (fig-forth-auto680):04439 FDB FROMR,SWAP,TOR,USLASH,FROMR
4500 237C 1667 (fig-forth-auto680):04440 FDB SEMIS
4501 (fig-forth-auto680):04441 *
4502 (fig-forth-auto680):04442 * ======>> 166 <<
4503 (fig-forth-auto680):04443 * ( n>=0 --- n )
4504 (fig-forth-auto680):04444 * ( n<0 --- -n )
4505 (fig-forth-auto680):04445 * Convert the top of stack to its absolute value.
4506 237E 83 (fig-forth-auto680):04446 FCB $83
4507 237F 4142 (fig-forth-auto680):04447 FCC 'AB' ; 'ABS'
4508 2381 D3 (fig-forth-auto680):04448 FCB $D3
4509 2382 2360 (fig-forth-auto680):04449 FDB MSMOD-8
4510 2384 17B9174516B51409 (fig-forth-auto680):04450 ABS FDB DOCOL,DUP,ZLESS,ZBRAN
4511 238C 0002 (fig-forth-auto680):04451 FDB ABS2-*-NATWID
4512 238E 16EF (fig-forth-auto680):04452 FDB MINUS
4513 2390 1667 (fig-forth-auto680):04453 ABS2 FDB SEMIS
4514 (fig-forth-auto680):04454 *
4515 (fig-forth-auto680):04455 * ======>> 167 <<
4516 (fig-forth-auto680):04456 * ( d>=0 --- d )
4517 (fig-forth-auto680):04457 * ( d<0 --- -d )
4518 (fig-forth-auto680):04458 * Convert the top double to its absolute value.
4519 2392 84 (fig-forth-auto680):04459 FCB $84
4520 2393 444142 (fig-forth-auto680):04460 FCC 'DAB' ; 'DABS'
4521 2396 D3 (fig-forth-auto680):04461 FCB $D3
4522 2397 237E (fig-forth-auto680):04462 FDB ABS-6
4523 2399 17B9174516B51409 (fig-forth-auto680):04463 DABS FDB DOCOL,DUP,ZLESS,ZBRAN
4524 23A1 0002 (fig-forth-auto680):04464 FDB DABS2-*-NATWID
4525 23A3 1702 (fig-forth-auto680):04465 FDB DMINUS
4526 23A5 1667 (fig-forth-auto680):04466 DABS2 FDB SEMIS
4527 (fig-forth-auto680):04467 *
4528 (fig-forth-auto680):04468 * ######>> screen 58 <<
4529 (fig-forth-auto680):04469 * Disc primitives :
4530 (fig-forth-auto680):04470 * ======>> 168 <<
4531 (fig-forth-auto680):04471 * ( --- vadr )
4532 (fig-forth-auto680):04472 * Least Recently Used buffer.
4533 (fig-forth-auto680):04473 * Really should be with FIRST and LIMIT in the per-task table.
4534 23A7 83 (fig-forth-auto680):04474 FCB $83
4535 23A8 5553 (fig-forth-auto680):04475 FCC 'US' ; 'USE'
4536 23AA C5 (fig-forth-auto680):04476 FCB $C5
4537 23AB 2392 (fig-forth-auto680):04477 FDB DABS-7
4538 23AD 17E9 (fig-forth-auto680):04478 USE FDB DOCON
4539 23AF 7C58 (fig-forth-auto680):04479 FDB XUSE
4540 (fig-forth-auto680):04480 * ======>> 169 <<
4541 (fig-forth-auto680):04481 * ( --- vadr )
4542 (fig-forth-auto680):04482 * Most Recently Used buffer.
4543 (fig-forth-auto680):04483 * Really should be with FIRST and LIMIT in the per-task table.
4544 23B1 84 (fig-forth-auto680):04484 FCB $84
4545 23B2 505245 (fig-forth-auto680):04485 FCC 'PRE' ; 'PREV'
4546 23B5 D6 (fig-forth-auto680):04486 FCB $D6
4547 23B6 23A7 (fig-forth-auto680):04487 FDB USE-6
4548 23B8 17E9 (fig-forth-auto680):04488 PREV FDB DOCON
4549 23BA 7C5A (fig-forth-auto680):04489 FDB XPREV
4550 (fig-forth-auto680):04490 * ======>> 170 <<
4551 (fig-forth-auto680):04491 * ( buffer1 --- buffer2 f )
4552 (fig-forth-auto680):04492 * Bump to next buffer,
4553 (fig-forth-auto680):04493 * flag false if result is PREVious buffer,
4554 (fig-forth-auto680):04494 * otherwise flag true.
4555 (fig-forth-auto680):04495 * Used in the LRU allocation routines.
4556 23BC 84 (fig-forth-auto680):04496 FCB $84
4557 23BD 2B4255 (fig-forth-auto680):04497 FCC '+BU' ; '+BUF'
4558 23C0 C6 (fig-forth-auto680):04498 FCB $C6
4559 23C1 23B1 (fig-forth-auto680):04499 FDB PREV-7
4560 23C3 17B913A7 (fig-forth-auto680):04500 PBUF FDB DOCOL,LIT8
4561 23C7 84 (fig-forth-auto680):04501 FCB $84
4562 23C8 16C6174518761A11 (fig-forth-auto680):04502 FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
4564 23D2 0004 (fig-forth-auto680):04503 FDB PBUF2-*-NATWID
4565 23D4 172A186A (fig-forth-auto680):04504 FDB DROP,FIRST
4566 23D8 174523B817721A04 (fig-forth-auto680):04505 PBUF2 FDB DUP,PREV,AT,SUB
4567 23E0 1667 (fig-forth-auto680):04506 FDB SEMIS
4568 (fig-forth-auto680):04507 *
4569 (fig-forth-auto680):04508 * ======>> 171 <<
4570 (fig-forth-auto680):04509 * ( --- )
4571 (fig-forth-auto680):04510 * Mark PREVious buffer dirty, in need of being written out.
4572 23E2 86 (fig-forth-auto680):04511 FCB $86
4573 23E3 5550444154 (fig-forth-auto680):04512 FCC 'UPDAT' ; 'UPDATE'
4574 23E8 C5 (fig-forth-auto680):04513 FCB $C5
4575 23E9 23BC (fig-forth-auto680):04514 FDB PBUF-7
4576 23EB 17B923B817721772 (fig-forth-auto680):04515 UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
4579 23FF 1667 (fig-forth-auto680):04516 FDB SEMIS
4580 (fig-forth-auto680):04517 *
4581 (fig-forth-auto680):04518 * ======>> 172 <<
4582 (fig-forth-auto680):04519 * ( --- )
4583 (fig-forth-auto680):04520 * Mark all buffers empty.
4584 (fig-forth-auto680):04521 * Standard method of discarding changes.
4585 2401 8D (fig-forth-auto680):04522 FCB $8D
4586 2402 454D5054592D4255 (fig-forth-auto680):04523 FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
4588 240E D3 (fig-forth-auto680):04524 FCB $D3
4589 240F 23E2 (fig-forth-auto680):04525 FDB UPDATE-9
4590 2411 17B9186A1876171C (fig-forth-auto680):04526 MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
4592 241D 1667 (fig-forth-auto680):04527 FDB SEMIS
4593 (fig-forth-auto680):04528 *
4594 (fig-forth-auto680):04529 * ======>> 173 <<
4595 (fig-forth-auto680):04530 * ( --- )
4596 (fig-forth-auto680):04531 * Clear the current offset to the block numbers in the drive interface.
4597 (fig-forth-auto680):04532 * The drives need to be re-architected.
4598 (fig-forth-auto680):04533 * Would be cool to have RAM and ROM drives supported
4599 (fig-forth-auto680):04534 * in addition to regular physical persistent store.
4600 241F 83 (fig-forth-auto680):04535 FCB $83
4601 2420 4452 (fig-forth-auto680):04536 FCC 'DR' ; 'DR0'
4602 2422 B0 (fig-forth-auto680):04537 FCB $B0
4603 2423 2401 (fig-forth-auto680):04538 FDB MTBUF-16
4604 2425 17B9183D1930178A (fig-forth-auto680):04539 DRZERO FDB DOCOL,ZERO,OFSET,STORE
4605 242D 1667 (fig-forth-auto680):04540 FDB SEMIS
4606 (fig-forth-auto680):04541 *
4607 (fig-forth-auto680):04542 * ======>> 174 <<== system dependant word
4608 (fig-forth-auto680):04543 * ( --- )
4609 (fig-forth-auto680):04544 * Set the current offset in the drive interface to reference the second drive.
4610 (fig-forth-auto680):04545 * The hard-coded number in there needs to be in a table.
4611 242F 83 (fig-forth-auto680):04546 FCB $83
4612 2430 4452 (fig-forth-auto680):04547 FCC 'DR' ; 'DR1'
4613 2432 B1 (fig-forth-auto680):04548 FCB $B1
4614 2433 241F (fig-forth-auto680):04549 FDB DRZERO-6
4615 2435 17B9139907D01930 (fig-forth-auto680):04550 DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
4617 243F 1667 (fig-forth-auto680):04551 FDB SEMIS
4618 (fig-forth-auto680):04552 *
4619 (fig-forth-auto680):04553 * ######>> screen 59 <<
4620 (fig-forth-auto680):04554 * ======>> 175 <<
4621 (fig-forth-auto680):04555 * ( n --- buffer )
4622 (fig-forth-auto680):04556 * Get a free buffer,
4623 (fig-forth-auto680):04557 * assign it to block n,
4624 (fig-forth-auto680):04558 * return buffer address.
4625 (fig-forth-auto680):04559 * Will free a buffer by writing it, if necessary.
4626 (fig-forth-auto680):04560 * Does not actually read the block.
4627 (fig-forth-auto680):04561 * A bug in the fig LRU algorithm, which I have not fixed,
4628 (fig-forth-auto680):04562 * gives the PREVious buffer if USE gets set to PREVious.
4629 (fig-forth-auto680):04563 * (The bug is that USE sometimes gets set to PREVious.)
4630 (fig-forth-auto680):04564 * This bug sometimes causes sector moves to become sector fills.
4631 2441 86 (fig-forth-auto680):04565 FCB $86
4632 2442 4255464645 (fig-forth-auto680):04566 FCC 'BUFFE' ; 'BUFFER'
4633 2447 D2 (fig-forth-auto680):04567 FCB $D2
4634 2448 242F (fig-forth-auto680):04568 FDB DRONE-6
4635 244A 17B923AD17721745 (fig-forth-auto680):04569 BUFFER FDB DOCOL,USE,AT,DUP,TOR
4637 2454 23C31409 (fig-forth-auto680):04570 BUFFR2 FDB PBUF,ZBRAN
4638 2458 FFFA (fig-forth-auto680):04571 FDB BUFFR2-*-NATWID
4639 245A 23AD178A169C1772 (fig-forth-auto680):04572 FDB USE,STORE,R,AT,ZLESS
4641 2464 1409 (fig-forth-auto680):04573 FDB ZBRAN
4642 2466 0012 (fig-forth-auto680):04574 FDB BUFFR3-*-NATWID
4643 (fig-forth-auto680):04575 * FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
4644 2468 169C1802169C1772 (fig-forth-auto680):04576 FDB R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
4647 (fig-forth-auto680):04577 * BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
4648 247A 169C178A169C23B8 (fig-forth-auto680):04578 BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
4650 2488 1667 (fig-forth-auto680):04579 FDB SEMIS
4651 (fig-forth-auto680):04580 *
4652 (fig-forth-auto680):04581 * ######>> screen 60 <<
4653 (fig-forth-auto680):04582 * ======>> 176 <<
4654 (fig-forth-auto680):04583 * ( n --- buffer )
4655 (fig-forth-auto680):04584 * Get BUFFER containing block n, relative to OFFSET.
4656 (fig-forth-auto680):04585 * If block n is not in a buffer, bring it in.
4657 (fig-forth-auto680):04586 * Returns buffer address.
4658 248A 85 (fig-forth-auto680):04587 FCB $85
4659 248B 424C4F43 (fig-forth-auto680):04588 FCC 'BLOC' ; 'BLOCK'
4660 248F CB (fig-forth-auto680):04589 FCB $CB
4661 2490 2441 (fig-forth-auto680):04590 FDB BUFFER-9
4662 2492 17B91930177216C6 (fig-forth-auto680):04591 BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
4664 249C 23B8177217451772 (fig-forth-auto680):04592 FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
4667 24AE 0032 (fig-forth-auto680):04593 FDB BLOCK5-*-NATWID
4668 24B0 23C316A31409 (fig-forth-auto680):04594 BLOCK3 FDB PBUF,ZEQU,ZBRAN
4669 24B6 0012 (fig-forth-auto680):04595 FDB BLOCK4-*-NATWID
4670 (fig-forth-auto680):04596 * FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
4671 24B8 172A169C244A1745 (fig-forth-auto680):04597 FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
4674 24CA 17451772169C1A04 (fig-forth-auto680):04598 BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
4676 24DA FFD4 (fig-forth-auto680):04599 FDB BLOCK3-*-NATWID
4677 24DC 174523B8178A (fig-forth-auto680):04600 FDB DUP,PREV,STORE
4678 (fig-forth-auto680):04601 * BLOCK5 FDB FROMR,DROP,TWOP
4679 24E2 1690172A1802 (fig-forth-auto680):04602 BLOCK5 FDB FROMR,DROP,NATP
4680 24E8 1667 (fig-forth-auto680):04603 FDB SEMIS
4681 (fig-forth-auto680):04604 *
4682 (fig-forth-auto680):04605 * ######>> screen 61 <<
4683 (fig-forth-auto680):04606 * ======>> 177 <<
4684 (fig-forth-auto680):04607 * ( line screen --- buffer C/L)
4685 (fig-forth-auto680):04608 * Bring in the sector containing the specified line of the specified screen.
4686 (fig-forth-auto680):04609 * Returns the buffer address and the width of the screen.
4687 (fig-forth-auto680):04610 * Screen number is relative to OFFSET.
4688 (fig-forth-auto680):04611 * The line number may be beyond screen 4,
4689 (fig-forth-auto680):04612 * (LINE) will get the appropriate screen.
4690 24EA 86 (fig-forth-auto680):04613 FCB $86
4691 24EB 284C494E45 (fig-forth-auto680):04614 FCC '(LINE' ; '(LINE)'
4692 24F0 A9 (fig-forth-auto680):04615 FCB $A9
4693 24F1 248A (fig-forth-auto680):04616 FDB BLOCK-8
4694 24F3 17B9168113A7 (fig-forth-auto680):04617 PLINE FDB DOCOL,TOR,LIT8
4695 24F9 40 (fig-forth-auto680):04618 FCB $40
4696 24FA 188223451690188E (fig-forth-auto680):04619 FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
4699 250C 40 (fig-forth-auto680):04620 FCB $40
4700 250D 1667 (fig-forth-auto680):04621 FDB SEMIS
4701 (fig-forth-auto680):04622 *
4702 (fig-forth-auto680):04623 * ======>> 178 <<
4703 (fig-forth-auto680):04624 * ( line screen --- )
4704 (fig-forth-auto680):04625 * Print the line of the screen as found by (LINE), suppress trailing BLANKS.
4705 250F 85 (fig-forth-auto680):04626 FCB $85
4706 2510 2E4C494E (fig-forth-auto680):04627 FCC '.LIN' ; '.LINE'
4707 2514 C5 (fig-forth-auto680):04628 FCB $C5
4708 2515 24EA (fig-forth-auto680):04629 FDB PLINE-9
4709 2517 17B924F31CDD1CAF (fig-forth-auto680):04630 DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
4710 251F 1667 (fig-forth-auto680):04631 FDB SEMIS
4711 (fig-forth-auto680):04632 *
4712 (fig-forth-auto680):04633 * ======>> 179 <<
4713 (fig-forth-auto680):04634 * ( n --- )
4714 (fig-forth-auto680):04635 * If WARNING is 0, print "MESSAGE #n";
4715 (fig-forth-auto680):04636 * otherwise, print line n relative to screen 4,
4716 (fig-forth-auto680):04637 * the line number may be negative.
4717 (fig-forth-auto680):04638 * Uses .LINE, but counter-adjusts to be relative to the real drive 0.
4718 2521 87 (fig-forth-auto680):04639 FCB $87
4719 2522 4D4553534147 (fig-forth-auto680):04640 FCC 'MESSAG' ; 'MESSAGE'
4720 2528 C5 (fig-forth-auto680):04641 FCB $C5
4721 2529 250F (fig-forth-auto680):04642 FDB DLINE-8
4722 252B 17B918D817721409 (fig-forth-auto680):04643 MESS FDB DOCOL,WARN,AT,ZBRAN
4723 2533 0019 (fig-forth-auto680):04644 FDB MESS3-*-NATWID
4724 2535 1A8A1409 (fig-forth-auto680):04645 FDB DDUP,ZBRAN
4725 2539 0013 (fig-forth-auto680):04646 FDB MESS3-*-NATWID
4726 253B 13A7 (fig-forth-auto680):04647 FDB LIT8
4727 253D 04 (fig-forth-auto680):04648 FCB 4
4728 253E 19301772188E2325 (fig-forth-auto680):04649 FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
4730 254C 000B (fig-forth-auto680):04650 FDB MESS4-*-NATWID
4731 254E 1D10 (fig-forth-auto680):04651 MESS3 FDB PDOTQ
4732 2550 06 (fig-forth-auto680):04652 FCB 6
4733 2551 657272202320 (fig-forth-auto680):04653 FCC 'err # ' ; 'err # '
4734 2557 28D6 (fig-forth-auto680):04654 FDB DOT
4735 2559 1667 (fig-forth-auto680):04655 MESS4 FDB SEMIS
4736 (fig-forth-auto680):04656 *
4737 (fig-forth-auto680):04657 * ======>> 180 <<
4738 (fig-forth-auto680):04658 * ( n --- )
4739 (fig-forth-auto680):04659 * Begin interpretation of screen (block) n.
4740 (fig-forth-auto680):04660 * See also ARROW, SEMIS, and NULL.
4741 255B 84 (fig-forth-auto680):04661 FCB $84
4742 255C 4C4F41 (fig-forth-auto680):04662 FCC 'LOA' ; 'LOAD' : input:scr #
4743 255F C4 (fig-forth-auto680):04663 FCB $C4
4744 2560 2521 (fig-forth-auto680):04664 FDB MESS-10
4745 2562 17B9190617721681 (fig-forth-auto680):04665 LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
4748 2576 188E23061906178A (fig-forth-auto680):04666 FDB BSCR,STAR,BLK,STORE
4749 257E 211D1690190F178A (fig-forth-auto680):04667 FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
4751 258C 1667 (fig-forth-auto680):04668 FDB SEMIS
4752 (fig-forth-auto680):04669 *
4753 (fig-forth-auto680):04670 * ======>> 181 <<
4754 (fig-forth-auto680):04671 * ( --- ) P
4755 (fig-forth-auto680):04672 * Continue interpreting source code on the next screen.
4756 258E C3 (fig-forth-auto680):04673 FCB $C3
4757 258F 2D2D (fig-forth-auto680):04674 FCC '--' ; '-->'
4758 2591 BE (fig-forth-auto680):04675 FCB $BE
4759 2592 255B (fig-forth-auto680):04676 FDB LOAD-7
4760 2594 17B91BAE183D190F (fig-forth-auto680):04677 ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
4762 25A0 19061772171C2335 (fig-forth-auto680):04678 FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
4764 25AE 1667 (fig-forth-auto680):04679 FDB SEMIS
4765 (fig-forth-auto680):04680 PAGE
4766 (fig-forth-auto680):04681 *
4767 (fig-forth-auto680):04682 *
4768 (fig-forth-auto680):04683 * ######>> screen 63 <<
4769 (fig-forth-auto680):04684 * The next 4 subroutines are machine dependent, and are
4770 (fig-forth-auto680):04685 * called by words 13 through 16 in the dictionary.
4771 (fig-forth-auto680):04686 *
4772 (fig-forth-auto680):04687 * ======>> 182 << code for EMIT
4773 (fig-forth-auto680):04688 * ( --- ) No parameter stack effect.
4774 (fig-forth-auto680):04689 * Interfaces directly with ROM. Expects output character in D (therefore, B).
4775 (fig-forth-auto680):04690 * Output using rom CHROUT: redirectable to a printer on Coco.
4776 (fig-forth-auto680):04691 * Outputs the character on stack (low byte of 1 bit word/cell).
4777 25B0 3468 (fig-forth-auto680):04692 PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
4778 25B2 1F98 (fig-forth-auto680):04693 TFR B,A ; Coco ROM wants it in A.
4779 25B4 5F (fig-forth-auto680):04694 CLRB
4780 25B5 1F9B (fig-forth-auto680):04695 TFR B,DP ; Give the ROM its direct page.
4781 25B7 AD9FA002 (fig-forth-auto680):04696 JSR [$A002] ; Output the character in A.
4782 25BB 35E8 (fig-forth-auto680):04697 PULS Y,U,DP,PC
4783 (fig-forth-auto680):04698 * PEMIT STB N save B
4784 (fig-forth-auto680):04699 * STX N+1 save X
4785 (fig-forth-auto680):04700 * LDB ACIAC
4786 (fig-forth-auto680):04701 * BITB #2 check ready bit
4787 (fig-forth-auto680):04702 * BEQ PEMIT+4 if not ready for more data
4788 (fig-forth-auto680):04703 * STA ACIAD
4789 (fig-forth-auto680):04704 * LDX UP
4790 (fig-forth-auto680):04705 * STB IOSTAT-UORIG,X
4791 (fig-forth-auto680):04706 * LDB N recover B & X
4792 (fig-forth-auto680):04707 * LDX N+1
4793 (fig-forth-auto680):04708 * RTS only A register may change
4794 (fig-forth-auto680):04709 * PEMIT JMP $E1D1 for MIKBUG
4795 (fig-forth-auto680):04710 * PEMIT FCB $3F,$11,$39 for PROTO
4796 (fig-forth-auto680):04711 * PEMIT JMP $D286 for Smoke Signal DOS
4797 (fig-forth-auto680):04712 *
4798 (fig-forth-auto680):04713 * ======>> 183 << code for KEY
4799 (fig-forth-auto680):04714 * ( --- ) No parameter stack effect.
4800 (fig-forth-auto680):04715 * Returns character or break flag in D, since this interfaces with Coco ROM.
4801 (fig-forth-auto680):04716 * Wait for key from POLCAT on Coco.
4802 (fig-forth-auto680):04717 * Returns the character code for the key pressed.
4803 25BD 3468 (fig-forth-auto680):04718 PKEY PSHS Y,U,DP ; Must save everything important for this one.
4804 25BF 86CF (fig-forth-auto680):04719 LDA #$CF ; a cursor of sorts
4805 25C1 5F (fig-forth-auto680):04720 CLRB
4806 25C2 1F9B (fig-forth-auto680):04721 TFR B,DP
4807 00 (fig-forth-auto680):04722 SETDP 0
4808 25C4 9E88 (fig-forth-auto680):04723 LDX <$88 ; location
4809 25C6 E684 (fig-forth-auto680):04724 LDB ,X ; save glyph
4810 25C8 A784 (fig-forth-auto680):04725 STA ,X
4811 25CA AD9FA000 (fig-forth-auto680):04726 PKEYLP JSR [$A000]
4812 25CE B7041A (fig-forth-auto680):04727 STA $41A ; DBG!
4813 25D1 27F7 (fig-forth-auto680):04728 BEQ PKEYLP
4814 25D3 FD0418 (fig-forth-auto680):04729 STD $418 ; DBG!
4815 25D6 E784 (fig-forth-auto680):04730 STB ,X ; restore
4816 25D8 5F (fig-forth-auto680):04731 PKEYR CLRB ; for the break flag, shares code with PQTER
4817 25D9 8103 (fig-forth-auto680):04732 CMPA #3 ; break key
4818 25DB 2601 (fig-forth-auto680):04733 BNE PKEYGT
4819 25DD 53 (fig-forth-auto680):04734 COMB ; for the break flag
4820 25DE 1E89 (fig-forth-auto680):04735 PKEYGT EXG A,B ; Leave it in D for return.
4821 25E0 35E8 (fig-forth-auto680):04736 PULS Y,U,DP,PC ; Shares exit with PQTER
4822 7C (fig-forth-auto680):04737 SETDP IUPDP
4823 (fig-forth-auto680):04738 * PKEY STB N
4824 (fig-forth-auto680):04739 * STX N+1
4825 (fig-forth-auto680):04740 * LDB ACIAC
4826 (fig-forth-auto680):04741 * ASRB ;
4827 (fig-forth-auto680):04742 * BCC PKEY+4 no incoming data yet
4828 (fig-forth-auto680):04743 * LDA ACIAD
4829 (fig-forth-auto680):04744 * ANDA #$7F strip parity bit
4830 (fig-forth-auto680):04745 * LDX UP
4831 (fig-forth-auto680):04746 * STB IOSTAT+1-UORIG,X
4832 (fig-forth-auto680):04747 * LDB N
4833 (fig-forth-auto680):04748 * LDX N+1
4834 (fig-forth-auto680):04749 * RTS
4835 (fig-forth-auto680):04750 * PKEY JMP $E1AC for MIKBUG
4836 (fig-forth-auto680):04751 * PKEY FCB $3F,$14,$39 for PROTO
4837 (fig-forth-auto680):04752 * PKEY JMP $D289 for Smoke Signal DOS
4838 (fig-forth-auto680):04753 *
4839 (fig-forth-auto680):04754 * ######>> screen 64 <<
4840 (fig-forth-auto680):04755 * ======>> 184 << code for ?TERMINAL
4841 (fig-forth-auto680):04756 * ( --- f ) Should change this to no stack effect.
4842 (fig-forth-auto680):04757 * check break key using POLCAT
4843 (fig-forth-auto680):04758 * Returns a flag to tell whether the break key was pressed or not.
4844 25E2 3468 (fig-forth-auto680):04759 PQTER PSHS Y,U,DP
4845 25E4 5F (fig-forth-auto680):04760 CLRB
4846 25E5 1F9B (fig-forth-auto680):04761 TFR B,DP
4847 25E7 AD9FA000 (fig-forth-auto680):04762 JSR [$A000] ; Look but don't wait.
4848 25EB 20EB (fig-forth-auto680):04763 BRA PKEYR
4849 (fig-forth-auto680):04764 * PQTER LDA ACIAC Test for 'break' condition
4850 (fig-forth-auto680):04765 * ANDA #$11 mask framing error bit and
4851 (fig-forth-auto680):04766 * input buffer full
4852 (fig-forth-auto680):04767 * BEQ PQTER2
4853 (fig-forth-auto680):04768 * LDA ACIAD clear input buffer
4854 (fig-forth-auto680):04769 * LDA #01
4855 (fig-forth-auto680):04770 * PQTER2 RTS
4856 (fig-forth-auto680):04771
4857 (fig-forth-auto680):04772
4858 (fig-forth-auto680):04773 PAGE
4859 (fig-forth-auto680):04774 *
4860 (fig-forth-auto680):04775 * ======>> 185 << code for CR
4861 (fig-forth-auto680):04776 * ( --- ) No stack effect.
4862 (fig-forth-auto680):04777 * Interfaces directly with ROM.
4863 (fig-forth-auto680):04778 * For Coco just output a CR.
4864 (fig-forth-auto680):04779 * Also subject to redirection in Coco BASIC ROM.
4865 25ED C60D (fig-forth-auto680):04780 PCR LDB #$0D
4866 25EF 20BF (fig-forth-auto680):04781 BRA PEMIT ; Just steal the code.
4867 (fig-forth-auto680):04782 * PCR LDA #$D carriage return
4868 (fig-forth-auto680):04783 * BSR PEMIT
4869 (fig-forth-auto680):04784 * LDA #$A line feed
4870 (fig-forth-auto680):04785 * BSR PEMIT
4871 (fig-forth-auto680):04786 * LDA #$7F rubout
4872 (fig-forth-auto680):04787 * LDX UP
4873 (fig-forth-auto680):04788 * LDB XDELAY+1-UORIG,X
4874 (fig-forth-auto680):04789 * PCR2 DECB ;
4875 (fig-forth-auto680):04790 * BMI PQTER2 return if minus
4876 (fig-forth-auto680):04791 * PSHS B ; save counter
4877 (fig-forth-auto680):04792 * BSR PEMIT print RUBOUTs to delay.....
4878 (fig-forth-auto680):04793 * PULS B ;
4879 (fig-forth-auto680):04794 * BRA PCR2 repeat
4880 (fig-forth-auto680):04795
4881 (fig-forth-auto680):04796
4882 (fig-forth-auto680):04797 PAGE
4883 (fig-forth-auto680):04798 *
4884 (fig-forth-auto680):04799 * ######>> screen 66 <<
4885 (fig-forth-auto680):04800 * ======>> 187 <<
4886 (fig-forth-auto680):04801 * ( ??? )
4887 (fig-forth-auto680):04802 * Query the disk, I suppose.
4888 (fig-forth-auto680):04803 * Not sure what the model had in mind for this stub.
4889 25F1 85 (fig-forth-auto680):04804 FCB $85
4890 25F2 3F444953 (fig-forth-auto680):04805 FCC '?DIS' ; '?DISC'
4891 25F6 C3 (fig-forth-auto680):04806 FCB $C3
4892 25F7 258E (fig-forth-auto680):04807 FDB ARROW-6
4893 25F9 25FB (fig-forth-auto680):04808 QDISC FDB *+NATWID
4894 25FB 7E1228 (fig-forth-auto680):04809 JMP NEXT
4895 (fig-forth-auto680):04810 *
4896 (fig-forth-auto680):04811 * ######>> screen 67 <<
4897 (fig-forth-auto680):04812 * ======>> 189 <<
4898 (fig-forth-auto680):04813 * ( ??? )
4899 (fig-forth-auto680):04814 * Write one block of data to disk.
4900 (fig-forth-auto680):04815 * Parameters unspecified in model. Stub in model.
4901 25FE 8B (fig-forth-auto680):04816 FCB $8B
4902 25FF 424C4F434B2D5752 (fig-forth-auto680):04817 FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
4904 2609 C5 (fig-forth-auto680):04818 FCB $C5
4905 260A 25F1 (fig-forth-auto680):04819 FDB QDISC-8
4906 260C 260E (fig-forth-auto680):04820 BWRITE FDB *+NATWID
4907 260E 7E1228 (fig-forth-auto680):04821 JMP NEXT
4908 (fig-forth-auto680):04822 *
4909 (fig-forth-auto680):04823 * ######>> screen 68 <<
4910 (fig-forth-auto680):04824 * ======>> 190 <<
4911 (fig-forth-auto680):04825 * ( ??? )
4912 (fig-forth-auto680):04826 * Read one block of data from disk.
4913 (fig-forth-auto680):04827 * Parameters unspecified in model. Stub in model.
4914 2611 8A (fig-forth-auto680):04828 FCB $8A
4915 2612 424C4F434B2D5245 (fig-forth-auto680):04829 FCC 'BLOCK-REA' ; 'BLOCK-READ'
4917 261B C4 (fig-forth-auto680):04830 FCB $C4
4918 261C 25FE (fig-forth-auto680):04831 FDB BWRITE-14
4919 261E 2620 (fig-forth-auto680):04832 BREAD FDB *+NATWID
4920 2620 7E1228 (fig-forth-auto680):04833 JMP NEXT
4921 (fig-forth-auto680):04834 *
4922 (fig-forth-auto680):04835 *The next 3 words are written to create a substitute for disc
4923 (fig-forth-auto680):04836 * mass memory,located between $3210 & $3FFF in ram.
4924 (fig-forth-auto680):04837 * ======>> 190.1 <<
4925 2623 82 (fig-forth-auto680):04838 FCB $82
4926 2624 4C (fig-forth-auto680):04839 FCC 'L' ; 'LO'
4927 2625 CF (fig-forth-auto680):04840 FCB $CF
4928 2626 2611 (fig-forth-auto680):04841 FDB BREAD-13
4929 2628 17E9 (fig-forth-auto680):04842 LO FDB DOCON
4930 262A 7000 (fig-forth-auto680):04843 FDB MEMEND a system dependent equate at front
4931 (fig-forth-auto680):04844 *
4932 (fig-forth-auto680):04845 * ======>> 190.2 <<
4933 262C 82 (fig-forth-auto680):04846 FCB $82
4934 262D 48 (fig-forth-auto680):04847 FCC 'H' ; 'HI'
4935 262E C9 (fig-forth-auto680):04848 FCB $C9
4936 262F 2623 (fig-forth-auto680):04849 FDB LO-5
4937 2631 17E9 (fig-forth-auto680):04850 HI FDB DOCON
4938 2633 7FFF (fig-forth-auto680):04851 FDB MEMTOP ( $3FFF or $7FFF in this version )
4939 (fig-forth-auto680):04852 *
4940 (fig-forth-auto680):04853 * ######>> screen 69 <<
4941 (fig-forth-auto680):04854 * ======>> 191 <<
4942 (fig-forth-auto680):04855 * ( buffer sector f --- )
4943 (fig-forth-auto680):04856 * Read or Write the specified (absolute -- ignores OFFSET) sector
4944 (fig-forth-auto680):04857 * from or to the specified buffer.
4945 (fig-forth-auto680):04858 * A zero flag specifies write,
4946 (fig-forth-auto680):04859 * non-zero specifies read.
4947 (fig-forth-auto680):04860 * Sector is an unsigned integer,
4948 (fig-forth-auto680):04861 * buffer is the buffer's address.
4949 (fig-forth-auto680):04862 * Will need to use the CoCo ROM disk routines.
4950 (fig-forth-auto680):04863 * For now, provides a virtual disk in RAM.
4951 2635 83 (fig-forth-auto680):04864 FCB $83
4952 2636 522F (fig-forth-auto680):04865 FCC 'R/' ; 'R/W'
4953 2638 D7 (fig-forth-auto680):04866 FCB $D7
4954 2639 262C (fig-forth-auto680):04867 FDB HI-5
4955 263B 17B9168118822306 (fig-forth-auto680):04868 RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
4958 264F 000D (fig-forth-auto680):04869 FDB RW2-*-NATWID
4959 2651 1D10 (fig-forth-auto680):04870 FDB PDOTQ
4960 2653 08 (fig-forth-auto680):04871 FCB 8
4961 2654 2052616E6765203F (fig-forth-auto680):04872 FCC ' Range ?' ; ' Range ?'
4962 265C 21D7 (fig-forth-auto680):04873 FDB QUIT
4963 265E 16901409 (fig-forth-auto680):04874 RW2 FDB FROMR,ZBRAN
4964 2662 0002 (fig-forth-auto680):04875 FDB RW3-*-NATWID
4965 2664 1736 (fig-forth-auto680):04876 FDB SWAP
4966 2666 18821584 (fig-forth-auto680):04877 RW3 FDB BBUF,CMOVE
4967 266A 1667 (fig-forth-auto680):04878 FDB SEMIS
4968 (fig-forth-auto680):04879 *
4969 (fig-forth-auto680):04880 * From BIF-6809:
4970 (fig-forth-auto680):04881 * RW PSHS Y,U,DP
4971 (fig-forth-auto680):04882 * LDY $C006 control table
4972 (fig-forth-auto680):04883 * LDX #DROFFS+7 ; This is BIF's table of drive sizes.
4973 (fig-forth-auto680):04884 * LDD 2,U
4974 (fig-forth-auto680):04885 * RWD SUBD ,X++ sectors
4975 (fig-forth-auto680):04886 * BHS RWD
4976 (fig-forth-auto680):04887 * BVC RWR table end?
4977 (fig-forth-auto680):04888 * LDD #6
4978 (fig-forth-auto680):04889 * PSHU D
4979 (fig-forth-auto680):04890 * JMP ERROR
4980 (fig-forth-auto680):04891 * RWR ADDD ,--X back one
4981 (fig-forth-auto680):04892 * PSHS X
4982 (fig-forth-auto680):04893 * PSHU D
4983 (fig-forth-auto680):04894 * LDD #18 sectors/track
4984 (fig-forth-auto680):04895 * PSHU D
4985 (fig-forth-auto680):04896 * DOCOL
4986 (fig-forth-auto680):04897 * FDB SLAMOD
4987 (fig-forth-auto680):04898 * FDB XMACH
4988 (fig-forth-auto680):04899 * PULU D
4989 (fig-forth-auto680):04900 * STB 2,Y track
4990 (fig-forth-auto680):04901 * PULU D
4991 (fig-forth-auto680):04902 * INCB
4992 (fig-forth-auto680):04903 * STB 3,Y sector
4993 (fig-forth-auto680):04904 * PULS D table entry
4994 (fig-forth-auto680):04905 * SUBD #DROFFS+7
4995 (fig-forth-auto680):04906 * ASRB drive #
4996 (fig-forth-auto680):04907 * STB 1,Y
4997 (fig-forth-auto680):04908 * LDD 4,U buffer
4998 (fig-forth-auto680):04909 * STD 4,Y
4999 (fig-forth-auto680):04910 * LDB #2 coco READ
5000 (fig-forth-auto680):04911 * LDX ,U 0?
5001 (fig-forth-auto680):04912 * BNE *+3
5002 (fig-forth-auto680):04913 * INCB coco WRITE
5003 (fig-forth-auto680):04914 * STB ,Y op code
5004 (fig-forth-auto680):04915 * CLRA
5005 (fig-forth-auto680):04916 * TFR A,DP
5006 (fig-forth-auto680):04917 * JSR [$C004] ROM handles timeout
5007 (fig-forth-auto680):04918 * PULS Y,U,DP if IRQ enabled
5008 (fig-forth-auto680):04919 * LEAU 6,U
5009 (fig-forth-auto680):04920 * LDX $C006
5010 (fig-forth-auto680):04921 * LDB 6,X coco status
5011 (fig-forth-auto680):04922 * BEQ RWE
5012 (fig-forth-auto680):04923 * LDX <UP
5013 (fig-forth-auto680):04924 * LDD #0 no disc
5014 (fig-forth-auto680):04925 * STD UWARN,X
5015 (fig-forth-auto680):04926 * LDD #8
5016 (fig-forth-auto680):04927 * PSHU D
5017 (fig-forth-auto680):04928 * JMP ERROR
5018 (fig-forth-auto680):04929 * RWE NEXT
5019 (fig-forth-auto680):04930 *
5020 (fig-forth-auto680):04931 * ######>> screen 72 <<
5021 (fig-forth-auto680):04932 * ======>> 192 <<
5022 (fig-forth-auto680):04933 * ( --- ) compiling P
5023 (fig-forth-auto680):04934 * ( --- adr ) interpreting
5024 (fig-forth-auto680):04935 * { ' name } input
5025 (fig-forth-auto680):04936 * Parse a symbol name from input and search the dictionary for it, per -FIND;
5026 (fig-forth-auto680):04937 * compile the address as a literal if compiling,
5027 (fig-forth-auto680):04938 * otherwise just push it.
5028 266C C1 (fig-forth-auto680):04939 FCB $C1 immediate
5029 266D A7 (fig-forth-auto680):04940 FCB $A7 ' ( tick )
5030 266E 2635 (fig-forth-auto680):04941 FDB RW-6
5031 2670 17B91FAD16A3183D (fig-forth-auto680):04942 TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
5033 267E 1667 (fig-forth-auto680):04943 FDB SEMIS
5034 (fig-forth-auto680):04944 *
5035 (fig-forth-auto680):04945 * ======>> 193 <<
5036 (fig-forth-auto680):04946 * ( --- ) { FORGET name } input
5037 (fig-forth-auto680):04947 * Parse out name of definition to FORGET to, -DFIND it,
5038 (fig-forth-auto680):04948 * then lop it and everything that follows out of the dictionary.
5039 (fig-forth-auto680):04949 * In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
5040 2680 86 (fig-forth-auto680):04950 FCB $86
5041 2681 464F524745 (fig-forth-auto680):04951 FCC 'FORGE' ; 'FORGET'
5042 2686 D4 (fig-forth-auto680):04952 FCB $D4
5043 2687 266C (fig-forth-auto680):04953 FDB TICK-4
5044 2689 17B9194C1772193E (fig-forth-auto680):04954 FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
5046 2697 18 (fig-forth-auto680):04955 FCB $18
5047 2698 1B392670174518E4 (fig-forth-auto680):04956 FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
5049 26A6 15 (fig-forth-auto680):04957 FCB $15
5050 26A7 1B391745183D189C (fig-forth-auto680):04958 FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
5052 26B3 15 (fig-forth-auto680):04959 FCB $15
5053 26B4 1B3917451AFD18ED (fig-forth-auto680):04960 FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
5056 26C8 1667 (fig-forth-auto680):04961 FDB SEMIS
5057 (fig-forth-auto680):04962 *
5058 (fig-forth-auto680):04963 * ######>> screen 73 <<
5059 (fig-forth-auto680):04964 * ======>> 194 <<
5060 (fig-forth-auto680):04965 * ( adr --- ) C
5061 (fig-forth-auto680):04966 * Calculate a back reference from HERE and compile it.
5062 26CA 84 (fig-forth-auto680):04967 FCB $84
5063 26CB 424143 (fig-forth-auto680):04968 FCC 'BAC' ; 'BACK'
5064 26CE CB (fig-forth-auto680):04969 FCB $CB
5065 26CF 2680 (fig-forth-auto680):04970 FDB FORGET-9
5066 (fig-forth-auto680):04971 * BACK FDB DOCOL,HERE,SUB,COMMA
5067 26D1 17B919C718021A04 (fig-forth-auto680):04972 BACK FDB DOCOL,HERE,NATP,SUB,COMMA
5069 26DB 1667 (fig-forth-auto680):04973 FDB SEMIS
5070 (fig-forth-auto680):04974 *
5071 (fig-forth-auto680):04975 * ======>> 195 <<
5072 (fig-forth-auto680):04976 * ( --- ) runtime
5073 (fig-forth-auto680):04977 * typical use: BEGIN code-loop test UNTIL
5074 (fig-forth-auto680):04978 * typical use: BEGIN code-loop AGAIN
5075 (fig-forth-auto680):04979 * typical use: BEGIN code-loop test WHILE code-true REPEAT
5076 (fig-forth-auto680):04980 * ( --- adr n ) compile time P,C
5077 (fig-forth-auto680):04981 * Push HERE for BACK reference for general (non-counting) loops,
5078 (fig-forth-auto680):04982 * with BEGIN construct flag.
5079 (fig-forth-auto680):04983 * A better flag: $4245 (ASCII for 'BE').
5080 26DD C5 (fig-forth-auto680):04984 FCB $C5
5081 26DE 42454749 (fig-forth-auto680):04985 FCC 'BEGI' ; 'BEGIN'
5082 26E2 CE (fig-forth-auto680):04986 FCB $CE
5083 26E3 26CA (fig-forth-auto680):04987 FDB BACK-7
5084 26E5 17B91B5319C71845 (fig-forth-auto680):04988 BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
5085 26ED 1667 (fig-forth-auto680):04989 FDB SEMIS
5086 (fig-forth-auto680):04990 *
5087 (fig-forth-auto680):04991 * ======>> 196 <<
5088 (fig-forth-auto680):04992 * ( --- ) runtime
5089 (fig-forth-auto680):04993 * typical use: test IF code-true ELSE code-false ENDIF
5090 (fig-forth-auto680):04994 * ENDIF is just a sort of intersection piece,
5091 (fig-forth-auto680):04995 * marking where execution resumes after both branches.
5092 (fig-forth-auto680):04996 * ( adr n --- ) compile time
5093 (fig-forth-auto680):04997 * Check the mark and resolve the IF.
5094 (fig-forth-auto680):04998 * A better flag: $4846 (ASCII for 'IF').
5095 26EF C5 (fig-forth-auto680):04999 FCB $C5
5096 26F0 454E4449 (fig-forth-auto680):05000 FCC 'ENDI' ; 'ENDIF'
5097 26F4 C6 (fig-forth-auto680):05001 FCB $C6
5098 26F5 26DD (fig-forth-auto680):05002 FDB BEGIN-8
5099 26F7 17B91B53184D1B80 (fig-forth-auto680):05003 ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
5101 2701 171C18021A041736 (fig-forth-auto680):05004 FDB OVER,NATP,SUB,SWAP,STORE
5103 270B 1667 (fig-forth-auto680):05005 FDB SEMIS
5104 (fig-forth-auto680):05006 *
5105 (fig-forth-auto680):05007 * ======>> 197 <<
5106 (fig-forth-auto680):05008 * ( --- ) runtime
5107 (fig-forth-auto680):05009 * typical use: test IF code-true ELSE code-false ENDIF
5108 (fig-forth-auto680):05010 * ( adr n --- )
5109 (fig-forth-auto680):05011 * Alias for ENDIF .
5110 270D C4 (fig-forth-auto680):05012 FCB $C4
5111 270E 544845 (fig-forth-auto680):05013 FCC 'THE' ; 'THEN'
5112 2711 CE (fig-forth-auto680):05014 FCB $CE
5113 2712 26EF (fig-forth-auto680):05015 FDB ENDIF-8
5114 2714 17B926F7 (fig-forth-auto680):05016 THEN FDB DOCOL,ENDIF
5115 2718 1667 (fig-forth-auto680):05017 FDB SEMIS
5116 (fig-forth-auto680):05018 *
5117 (fig-forth-auto680):05019 * ======>> 198 <<
5118 (fig-forth-auto680):05020 * ( limit index --- ) runtime
5119 (fig-forth-auto680):05021 * typical use: DO code-loop LOOP
5120 (fig-forth-auto680):05022 * typical use: DO code-loop increment +LOOP
5121 (fig-forth-auto680):05023 * Counted loop, index is initial value of index.
5122 (fig-forth-auto680):05024 * Will loop until index equals (positive going)
5123 (fig-forth-auto680):05025 * or passes (negative going) limit.
5124 (fig-forth-auto680):05026 * ( --- adr n ) compile time P,C
5125 (fig-forth-auto680):05027 * Compile (DO), push HERE for BACK reference,
5126 (fig-forth-auto680):05028 * and push DO control construct flag.
5127 (fig-forth-auto680):05029 * A better flag: $444F (ASCII for 'DO').
5128 271A C2 (fig-forth-auto680):05030 FCB $C2
5129 271B 44 (fig-forth-auto680):05031 FCC 'D' ; 'DO'
5130 271C CF (fig-forth-auto680):05032 FCB $CF
5131 271D 270D (fig-forth-auto680):05033 FDB THEN-7
5132 271F 17B91BC7145319C7 (fig-forth-auto680):05034 DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
5134 2729 1667 (fig-forth-auto680):05035 FDB SEMIS
5135 (fig-forth-auto680):05036 *
5136 (fig-forth-auto680):05037 * ======>> 199 <<
5137 (fig-forth-auto680):05038 * ( --- ) runtime
5138 (fig-forth-auto680):05039 * typical use: DO code-loop LOOP
5139 (fig-forth-auto680):05040 * Increments the index by one and branches back to beginning of loop.
5140 (fig-forth-auto680):05041 * Will loop until index equals limit.
5141 (fig-forth-auto680):05042 * ( adr n --- ) compile time P,C
5142 (fig-forth-auto680):05043 * Check the mark and compile (LOOP), fill in BACK reference.
5143 (fig-forth-auto680):05044 * A better flag: $444F (ASCII for 'DO').
5144 272B C4 (fig-forth-auto680):05045 FCB $C4
5145 272C 4C4F4F (fig-forth-auto680):05046 FCC 'LOO' ; 'LOOP'
5146 272F D0 (fig-forth-auto680):05047 FCB $D0
5147 2730 271A (fig-forth-auto680):05048 FDB DO-5
5148 2732 17B918551B801BC7 (fig-forth-auto680):05049 LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
5150 273E 1667 (fig-forth-auto680):05050 FDB SEMIS
5151 (fig-forth-auto680):05051 *
5152 (fig-forth-auto680):05052 * ======>> 200 <<
5153 (fig-forth-auto680):05053 * ( n --- ) runtime
5154 (fig-forth-auto680):05054 * typical use: DO code-loop increment +LOOP
5155 (fig-forth-auto680):05055 * Increments the index by n and branches back to beginning of loop.
5156 (fig-forth-auto680):05056 * Will loop until index equals (positive going)
5157 (fig-forth-auto680):05057 * or passes (negative going) limit.
5158 (fig-forth-auto680):05058 * ( adr n --- ) compile time P,C
5159 (fig-forth-auto680):05059 * Check the mark and compile (+LOOP), fill in BACK reference.
5160 (fig-forth-auto680):05060 * A better flag: $444F (ASCII for 'DO').
5161 2740 C5 (fig-forth-auto680):05061 FCB $C5
5162 2741 2B4C4F4F (fig-forth-auto680):05062 FCC '+LOO' ; '+LOOP'
5163 2745 D0 (fig-forth-auto680):05063 FCB $D0
5164 2746 272B (fig-forth-auto680):05064 FDB LOOP-7
5165 2748 17B918551B801BC7 (fig-forth-auto680):05065 PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
5167 2754 1667 (fig-forth-auto680):05066 FDB SEMIS
5168 (fig-forth-auto680):05067 *
5169 (fig-forth-auto680):05068 * ======>> 201 <<
5170 (fig-forth-auto680):05069 * ( n --- ) runtime
5171 (fig-forth-auto680):05070 * typical use: BEGIN code-loop test UNTIL
5172 (fig-forth-auto680):05071 * Will loop until UNTIL tests true.
5173 (fig-forth-auto680):05072 * ( adr n --- ) compile time P,C
5174 (fig-forth-auto680):05073 * Check the mark and compile (0BRANCH), fill in BACK reference.
5175 (fig-forth-auto680):05074 * A better flag: $4245 (ASCII for 'BE').
5176 2756 C5 (fig-forth-auto680):05075 FCB $C5
5177 2757 554E5449 (fig-forth-auto680):05076 FCC 'UNTI' ; 'UNTIL' : ( same as END )
5178 275B CC (fig-forth-auto680):05077 FCB $CC
5179 275C 2740 (fig-forth-auto680):05078 FDB PLOOP-8
5180 275E 17B918451B801BC7 (fig-forth-auto680):05079 UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
5182 276A 1667 (fig-forth-auto680):05080 FDB SEMIS
5183 (fig-forth-auto680):05081 *
5184 (fig-forth-auto680):05082 * ######>> screen 74 <<
5185 (fig-forth-auto680):05083 * ======>> 202 <<
5186 (fig-forth-auto680):05084 * ( n --- ) runtime
5187 (fig-forth-auto680):05085 * typical use: BEGIN code-loop test END
5188 (fig-forth-auto680):05086 * ( adr n --- )
5189 (fig-forth-auto680):05087 * Alias for UNTIL .
5190 276C C3 (fig-forth-auto680):05088 FCB $C3
5191 276D 454E (fig-forth-auto680):05089 FCC 'EN' ; 'END'
5192 276F C4 (fig-forth-auto680):05090 FCB $C4
5193 2770 2756 (fig-forth-auto680):05091 FDB UNTIL-8
5194 2772 17B9275E (fig-forth-auto680):05092 END FDB DOCOL,UNTIL
5195 2776 1667 (fig-forth-auto680):05093 FDB SEMIS
5196 (fig-forth-auto680):05094 *
5197 (fig-forth-auto680):05095 * ======>> 203 <<
5198 (fig-forth-auto680):05096 * ( --- ) runtime
5199 (fig-forth-auto680):05097 * typical use: BEGIN code-loop AGAIN
5200 (fig-forth-auto680):05098 * Will loop forever
5201 (fig-forth-auto680):05099 * (or until something uses R> DROP to force the current definition to die,
5202 (fig-forth-auto680):05100 * or perhaps ABORT or ERROR or some such other drastic means stops things).
5203 (fig-forth-auto680):05101 * ( adr n --- ) compile time P,C
5204 (fig-forth-auto680):05102 * Check the mark and compile (0BRANCH), fill in BACK reference.
5205 (fig-forth-auto680):05103 * A better flag: $4245 (ASCII for 'BE').
5206 2778 C5 (fig-forth-auto680):05104 FCB $C5
5207 2779 41474149 (fig-forth-auto680):05105 FCC 'AGAI' ; 'AGAIN'
5208 277D CE (fig-forth-auto680):05106 FCB $CE
5209 277E 276C (fig-forth-auto680):05107 FDB END-6
5210 2780 17B918451B801BC7 (fig-forth-auto680):05108 AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
5212 278C 1667 (fig-forth-auto680):05109 FDB SEMIS
5213 (fig-forth-auto680):05110 *
5214 (fig-forth-auto680):05111 * ======>> 204 <<
5215 (fig-forth-auto680):05112 * ( --- ) runtime
5216 (fig-forth-auto680):05113 * typical use: BEGIN code-loop test WHILE code-true REPEAT
5217 (fig-forth-auto680):05114 * Will loop until WHILE tests false, skipping code-true on end.
5218 (fig-forth-auto680):05115 * REPEAT marks where execution resumes after the WHILE find a false flag.
5219 (fig-forth-auto680):05116 * ( aadr1 n1 adr2 n2 --- ) compile time P,C
5220 (fig-forth-auto680):05117 * Check the marks for WHILE and BEGIN,
5221 (fig-forth-auto680):05118 * compile BRANCH and BACK fill adr1 reference,
5222 (fig-forth-auto680):05119 * FILL-IN 0BRANCH reference at adr2.
5223 (fig-forth-auto680):05120 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
5224 278E C6 (fig-forth-auto680):05121 FCB $C6
5225 278F 5245504541 (fig-forth-auto680):05122 FCC 'REPEA' ; 'REPEAT'
5226 2794 D4 (fig-forth-auto680):05123 FCB $D4
5227 2795 2778 (fig-forth-auto680):05124 FDB AGAIN-8
5228 2797 17B9168116812780 (fig-forth-auto680):05125 REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
5230 27A3 184D1A0426F7 (fig-forth-auto680):05126 FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
5231 27A9 1667 (fig-forth-auto680):05127 FDB SEMIS
5232 (fig-forth-auto680):05128 *
5233 (fig-forth-auto680):05129 * ======>> 205 <<
5234 (fig-forth-auto680):05130 * ( n --- ) runtime
5235 (fig-forth-auto680):05131 * typical use: test IF code-true ELSE code-false ENDIF
5236 (fig-forth-auto680):05132 * Will pass execution to the true part on a true flag
5237 (fig-forth-auto680):05133 * and to the false part on a false flag.
5238 (fig-forth-auto680):05134 * ( --- adr n ) compile time P,C
5239 (fig-forth-auto680):05135 * Compile a 0BRANCH and dummy offset
5240 (fig-forth-auto680):05136 * and push IF reference to fill in and
5241 (fig-forth-auto680):05137 * IF control construct flag.
5242 (fig-forth-auto680):05138 * A better flag: $4946 (ASCII for 'IF').
5243 27AB C2 (fig-forth-auto680):05139 FCB $C2
5244 27AC 49 (fig-forth-auto680):05140 FCC 'I' ; 'IF'
5245 27AD C6 (fig-forth-auto680):05141 FCB $C6
5246 27AE 278E (fig-forth-auto680):05142 FDB REPEAT-9
5247 27B0 17B91BC7140919C7 (fig-forth-auto680):05143 IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
5249 27BE 1667 (fig-forth-auto680):05144 FDB SEMIS
5250 (fig-forth-auto680):05145 *
5251 (fig-forth-auto680):05146 * ======>> 206 <<
5252 (fig-forth-auto680):05147 * ( --- ) runtime
5253 (fig-forth-auto680):05148 * typical use: test IF code-true ELSE code-false ENDIF
5254 (fig-forth-auto680):05149 * ELSE is just a sort of intersection piece,
5255 (fig-forth-auto680):05150 * marking where execution resumes on a false branch.
5256 (fig-forth-auto680):05151 * ( adr1 n --- adr2 n ) compile time P,C
5257 (fig-forth-auto680):05152 * Check the marks,
5258 (fig-forth-auto680):05153 * compile BRANCH with dummy offset,
5259 (fig-forth-auto680):05154 * resolve IF reference,
5260 (fig-forth-auto680):05155 * and leave reference to BRANCH for ELSE.
5261 (fig-forth-auto680):05156 * A better flag: $4946 (ASCII for 'IF').
5262 27C0 C4 (fig-forth-auto680):05157 FCB $C4
5263 27C1 454C53 (fig-forth-auto680):05158 FCC 'ELS' ; 'ELSE'
5264 27C4 C5 (fig-forth-auto680):05159 FCB $C5
5265 27C5 27AB (fig-forth-auto680):05160 FDB IF-5
5266 27C7 17B9184D1B801BC7 (fig-forth-auto680):05161 ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
5268 27D3 183D19E31736184D (fig-forth-auto680):05162 FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
5270 27DF 1667 (fig-forth-auto680):05163 FDB SEMIS
5271 (fig-forth-auto680):05164 *
5272 (fig-forth-auto680):05165 * ======>> 207 <<
5273 (fig-forth-auto680):05166 * ( n --- ) runtime
5274 (fig-forth-auto680):05167 * typical use: BEGIN code-loop test WHILE code-true REPEAT
5275 (fig-forth-auto680):05168 * Will loop until WHILE tests false, skipping code-true on end.
5276 (fig-forth-auto680):05169 * ( --- adr n ) compile time P,C
5277 (fig-forth-auto680):05170 * Compile 0BRANCH with dummy offset (using IF),
5278 (fig-forth-auto680):05171 * push WHILE reference.
5279 (fig-forth-auto680):05172 * BEGIN flag will sit underneath this.
5280 (fig-forth-auto680):05173 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
5281 27E1 C5 (fig-forth-auto680):05174 FCB $C5
5282 27E2 5748494C (fig-forth-auto680):05175 FCC 'WHIL' ; 'WHILE'
5283 27E6 C5 (fig-forth-auto680):05176 FCB $C5
5284 27E7 27C0 (fig-forth-auto680):05177 FDB ELSE-7
5285 27E9 17B927B019B8 (fig-forth-auto680):05178 WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
5286 27EF 1667 (fig-forth-auto680):05179 FDB SEMIS
5287 (fig-forth-auto680):05180 *
5288 (fig-forth-auto680):05181 * ######>> screen 75 <<
5289 (fig-forth-auto680):05182 * ======>> 208 <<
5290 (fig-forth-auto680):05183 * ( count --- )
5291 (fig-forth-auto680):05184 * EMIT count spaces, for non-zero, non-negative counts.
5292 27F1 86 (fig-forth-auto680):05185 FCB $86
5293 27F2 5350414345 (fig-forth-auto680):05186 FCC 'SPACE' ; 'SPACES'
5294 27F7 D3 (fig-forth-auto680):05187 FCB $D3
5295 27F8 27E1 (fig-forth-auto680):05188 FDB WHILE-8
5296 27FA 17B9183D1A771A8A (fig-forth-auto680):05189 SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
5298 2804 000A (fig-forth-auto680):05190 FDB SPACE3-*-NATWID
5299 2806 183D1453 (fig-forth-auto680):05191 FDB ZERO,XDO
5300 280A 1A57141D (fig-forth-auto680):05192 SPACE2 FDB SPACE,XLOOP
5301 280E FFFA (fig-forth-auto680):05193 FDB SPACE2-*-NATWID
5302 2810 1667 (fig-forth-auto680):05194 SPACE3 FDB SEMIS
5303 (fig-forth-auto680):05195 *
5304 (fig-forth-auto680):05196 * ======>> 209 <<
5305 (fig-forth-auto680):05197 * ( --- )
5306 (fig-forth-auto680):05198 * Initialize HLD for converting a double integer.
5307 (fig-forth-auto680):05199 * Stores the PAD address in HLD.
5308 2812 82 (fig-forth-auto680):05200 FCB $82
5309 2813 3C (fig-forth-auto680):05201 FCC '<' ; '<#'
5310 2814 A3 (fig-forth-auto680):05202 FCB $A3
5311 2815 27F1 (fig-forth-auto680):05203 FDB SPACES-9
5312 2817 17B91EAA1994178A (fig-forth-auto680):05204 BDIGS FDB DOCOL,PAD,HLD,STORE
5313 281F 1667 (fig-forth-auto680):05205 FDB SEMIS
5314 (fig-forth-auto680):05206 *
5315 (fig-forth-auto680):05207 * ======>> 210 <<
5316 (fig-forth-auto680):05208 * ( d --- string length )
5317 (fig-forth-auto680):05209 * Terminate numeric conversion,
5318 (fig-forth-auto680):05210 * drop the number being converted,
5319 (fig-forth-auto680):05211 * leave the address of the conversion string and the length, ready for TYPE.
5320 2821 82 (fig-forth-auto680):05212 FCB $82
5321 2822 23 (fig-forth-auto680):05213 FCC '#' ; '#>'
5322 2823 BE (fig-forth-auto680):05214 FCB $BE
5323 2824 2812 (fig-forth-auto680):05215 FDB BDIGS-5
5324 2826 17B9172A172A1994 (fig-forth-auto680):05216 EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
5326 2836 1667 (fig-forth-auto680):05217 FDB SEMIS
5327 (fig-forth-auto680):05218 *
5328 (fig-forth-auto680):05219 * ======>> 211 <<
5329 (fig-forth-auto680):05220 * ( n d --- d )
5330 (fig-forth-auto680):05221 * Put sign of n (as a flag) at the head of the conversion string.
5331 (fig-forth-auto680):05222 * Drop the sign flag.
5332 2838 84 (fig-forth-auto680):05223 FCB $84
5333 2839 534947 (fig-forth-auto680):05224 FCC 'SIG' ; 'SIGN'
5334 283C CE (fig-forth-auto680):05225 FCB $CE
5335 283D 2821 (fig-forth-auto680):05226 FDB EDIGS-5
5336 283F 17B91A4316B51409 (fig-forth-auto680):05227 SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
5337 2847 0005 (fig-forth-auto680):05228 FDB SIGN2-*-NATWID
5338 2849 13A7 (fig-forth-auto680):05229 FDB LIT8
5339 284B 2D (fig-forth-auto680):05230 FCC "-"
5340 284C 1E92 (fig-forth-auto680):05231 FDB HOLD
5341 284E 1667 (fig-forth-auto680):05232 SIGN2 FDB SEMIS
5342 (fig-forth-auto680):05233 *
5343 (fig-forth-auto680):05234 * ======>> 212 <<
5344 (fig-forth-auto680):05235 * ( d --- d/base )
5345 (fig-forth-auto680):05236 * Generate next most significant digit in the conversion BASE,
5346 (fig-forth-auto680):05237 * putting the digit at the head of the conversion string.
5347 2850 81 (fig-forth-auto680):05238 FCB $81 #
5348 2851 A3 (fig-forth-auto680):05239 FCB $A3
5349 2852 2838 (fig-forth-auto680):05240 FDB SIGN-7
5350 2854 17B9196317722368 (fig-forth-auto680):05241 DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
5352 2860 09 (fig-forth-auto680):05242 FCB 9
5353 2861 171C1A1D1409 (fig-forth-auto680):05243 FDB OVER,LESS,ZBRAN
5354 2867 0005 (fig-forth-auto680):05244 FDB DIG2-*-NATWID
5355 2869 13A7 (fig-forth-auto680):05245 FDB LIT8
5356 286B 07 (fig-forth-auto680):05246 FCB 7
5357 286C 16C6 (fig-forth-auto680):05247 FDB PLUS
5358 286E 13A7 (fig-forth-auto680):05248 DIG2 FDB LIT8
5359 2870 30 (fig-forth-auto680):05249 FCC "0" ascii zero
5360 2871 16C61E92 (fig-forth-auto680):05250 FDB PLUS,HOLD
5361 2875 1667 (fig-forth-auto680):05251 FDB SEMIS
5362 (fig-forth-auto680):05252 *
5363 (fig-forth-auto680):05253 * ======>> 213 <<
5364 (fig-forth-auto680):05254 * ( d --- dzero )
5365 (fig-forth-auto680):05255 * Convert d to a numeric string using # until the result is zero.
5366 (fig-forth-auto680):05256 * Leave the double result on the stack for #> to drop.
5367 2877 82 (fig-forth-auto680):05257 FCB $82
5368 2878 23 (fig-forth-auto680):05258 FCC '#' ; '#S'
5369 2879 D3 (fig-forth-auto680):05259 FCB $D3
5370 287A 2850 (fig-forth-auto680):05260 FDB DIG-4
5371 287C 17B9 (fig-forth-auto680):05261 DIGS FDB DOCOL
5372 287E 2854171C171C161E (fig-forth-auto680):05262 DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
5374 288A FFF2 (fig-forth-auto680):05263 FDB DIGS2-*-NATWID
5375 288C 1667 (fig-forth-auto680):05264 FDB SEMIS
5376 (fig-forth-auto680):05265 *
5377 (fig-forth-auto680):05266 * ######>> screen 76 <<
5378 (fig-forth-auto680):05267 * ======>> 214 <<
5379 (fig-forth-auto680):05268 * ( n width --- )
5380 (fig-forth-auto680):05269 * Print n on the output device in the current conversion base,
5381 (fig-forth-auto680):05270 * with sign,
5382 (fig-forth-auto680):05271 * right aligned in a field at least width wide.
5383 288E 82 (fig-forth-auto680):05272 FCB $82
5384 288F 2E (fig-forth-auto680):05273 FCC '.' ; '.R'
5385 2890 D2 (fig-forth-auto680):05274 FCB $D2
5386 2891 2877 (fig-forth-auto680):05275 FDB DIGS-5
5387 2893 17B9168122F81690 (fig-forth-auto680):05276 DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
5389 289D 1667 (fig-forth-auto680):05277 FDB SEMIS
5390 (fig-forth-auto680):05278 *
5391 (fig-forth-auto680):05279 * ======>> 215 <<
5392 (fig-forth-auto680):05280 * ( d width --- )
5393 (fig-forth-auto680):05281 * Print d on the output device in the current conversion base,
5394 (fig-forth-auto680):05282 * with sign,
5395 (fig-forth-auto680):05283 * right aligned in a field at least width wide.
5396 289F 83 (fig-forth-auto680):05284 FCB $83
5397 28A0 442E (fig-forth-auto680):05285 FCC 'D.' ; 'D.R'
5398 28A2 D2 (fig-forth-auto680):05286 FCB $D2
5399 28A3 288E (fig-forth-auto680):05287 FDB DOTR-5
5400 28A5 17B916811736171C (fig-forth-auto680):05288 DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
5402 28B5 28261690171C1A04 (fig-forth-auto680):05289 FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
5404 28C1 1667 (fig-forth-auto680):05290 FDB SEMIS
5405 (fig-forth-auto680):05291 *
5406 (fig-forth-auto680):05292 * ======>> 216 <<
5407 (fig-forth-auto680):05293 * D. ( d --- )
5408 (fig-forth-auto680):05294 * Print d on the output device in the current conversion base,
5409 (fig-forth-auto680):05295 * with sign,
5410 (fig-forth-auto680):05296 * in free format with trailing space.
5411 28C3 82 (fig-forth-auto680):05297 FCB $82
5412 28C4 44 (fig-forth-auto680):05298 FCC 'D' ; 'D.'
5413 28C5 AE (fig-forth-auto680):05299 FCB $AE
5414 28C6 289F (fig-forth-auto680):05300 FDB DDOTR-6
5415 28C8 17B9183D28A51A57 (fig-forth-auto680):05301 DDOT FDB DOCOL,ZERO,DDOTR,SPACE
5416 28D0 1667 (fig-forth-auto680):05302 FDB SEMIS
5417 (fig-forth-auto680):05303 *
5418 (fig-forth-auto680):05304 * ======>> 217 <<
5419 (fig-forth-auto680):05305 * ( n --- )
5420 (fig-forth-auto680):05306 * Print n on the output device in the current conversion base,
5421 (fig-forth-auto680):05307 * with sign,
5422 (fig-forth-auto680):05308 * in free format with trailing space.
5423 28D2 81 (fig-forth-auto680):05309 FCB $81 .
5424 28D3 AE (fig-forth-auto680):05310 FCB $AE
5425 28D4 28C3 (fig-forth-auto680):05311 FDB DDOT-5
5426 28D6 17B922F828C8 (fig-forth-auto680):05312 DOT FDB DOCOL,STOD,DDOT
5427 28DC 1667 (fig-forth-auto680):05313 FDB SEMIS
5428 (fig-forth-auto680):05314 *
5429 (fig-forth-auto680):05315 * ======>> 218 <<
5430 (fig-forth-auto680):05316 * ( adr --- )
5431 (fig-forth-auto680):05317 * Print signed word at adr, per DOT.
5432 28DE 81 (fig-forth-auto680):05318 FCB $81 ?
5433 28DF BF (fig-forth-auto680):05319 FCB $BF
5434 28E0 28D2 (fig-forth-auto680):05320 FDB DOT-4
5435 28E2 17B9177228D6 (fig-forth-auto680):05321 QUEST FDB DOCOL,AT,DOT
5436 28E8 1667 (fig-forth-auto680):05322 FDB SEMIS
5437 (fig-forth-auto680):05323 *
5438 (fig-forth-auto680):05324 * ######>> screen 77 <<
5439 (fig-forth-auto680):05325 * ======>> 219 <<
5440 (fig-forth-auto680):05326 * ( n --- )
5441 (fig-forth-auto680):05327 * Print out screen n as a field of ASCII,
5442 (fig-forth-auto680):05328 * with line numbers in decimal.
5443 (fig-forth-auto680):05329 * Needs a console more than 70 characters wide.
5444 28EA 84 (fig-forth-auto680):05330 FCB $84
5445 28EB 4C4953 (fig-forth-auto680):05331 FCC 'LIS' ; 'LIST'
5446 28EE D4 (fig-forth-auto680):05332 FCB $D4
5447 28EF 28DE (fig-forth-auto680):05333 FDB QUEST-4
5448 28F1 17B91C2515771745 (fig-forth-auto680):05334 LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
5450 28FF 06 (fig-forth-auto680):05335 FCB 6
5451 2900 534352202320 (fig-forth-auto680):05336 FCC "SCR # "
5452 2906 28D613A7 (fig-forth-auto680):05337 FDB DOT,LIT8
5453 290A 10 (fig-forth-auto680):05338 FCB $10
5454 290B 183D1453 (fig-forth-auto680):05339 FDB ZERO,XDO
5455 290F 157714651855 (fig-forth-auto680):05340 LIST2 FDB CR,I,THREE
5456 2915 28931A5714651923 (fig-forth-auto680):05341 FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
5458 2923 FFEA (fig-forth-auto680):05342 FDB LIST2-*-NATWID
5459 2925 1577 (fig-forth-auto680):05343 FDB CR
5460 2927 1667 (fig-forth-auto680):05344 FDB SEMIS
5461 (fig-forth-auto680):05345 *
5462 (fig-forth-auto680):05346 * ======>> 220 <<
5463 (fig-forth-auto680):05347 * ( start end --- )
5464 (fig-forth-auto680):05348 * Print comment lines (line 0, and line 1 if C/L < 41) of screens
5465 (fig-forth-auto680):05349 * from start to end.
5466 (fig-forth-auto680):05350 * Needs a console more than 70 characters wide.
5467 2929 85 (fig-forth-auto680):05351 FCB $85
5468 292A 494E4445 (fig-forth-auto680):05352 FCC 'INDE' ; 'INDEX'
5469 292E D8 (fig-forth-auto680):05353 FCB $D8
5470 292F 28EA (fig-forth-auto680):05354 FDB LIST-7
5471 2931 17B9157719AB1736 (fig-forth-auto680):05355 INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
5473 293B 157714651855 (fig-forth-auto680):05356 INDEX2 FDB CR,I,THREE
5474 2941 28931A57183D1465 (fig-forth-auto680):05357 FDB DOTR,SPACE,ZERO,I,DLINE
5476 294B 156A1409 (fig-forth-auto680):05358 FDB QTERM,ZBRAN
5477 294F 0002 (fig-forth-auto680):05359 FDB INDEX3-*-NATWID
5478 2951 1675 (fig-forth-auto680):05360 FDB LEAVE
5479 2953 141D (fig-forth-auto680):05361 INDEX3 FDB XLOOP
5480 2955 FFE4 (fig-forth-auto680):05362 FDB INDEX2-*-NATWID
5481 2957 1667 (fig-forth-auto680):05363 FDB SEMIS
5482 (fig-forth-auto680):05364 *
5483 (fig-forth-auto680):05365 * ======>> 221 <<
5484 (fig-forth-auto680):05366 * ( n --- )
5485 (fig-forth-auto680):05367 * List a printer page full of screens.
5486 (fig-forth-auto680):05368 * Line and screen number are in current base.
5487 (fig-forth-auto680):05369 * Needs a console more than 70 characters wide.
5488 2959 85 (fig-forth-auto680):05370 FCB $85
5489 295A 54524941 (fig-forth-auto680):05371 FCC 'TRIA' ; 'TRIAD'
5490 295E C4 (fig-forth-auto680):05372 FCB $C4
5491 295F 2929 (fig-forth-auto680):05373 FDB INDEX-8
5492 2961 17B9185523251855 (fig-forth-auto680):05374 TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
5494 296B 1855171C16C61736 (fig-forth-auto680):05375 FDB THREE,OVER,PLUS,SWAP,XDO
5496 2975 15771465 (fig-forth-auto680):05376 TRIAD2 FDB CR,I
5497 2979 28F1156A1409 (fig-forth-auto680):05377 FDB LIST,QTERM,ZBRAN
5498 297F 0002 (fig-forth-auto680):05378 FDB TRIAD3-*-NATWID
5499 2981 1675 (fig-forth-auto680):05379 FDB LEAVE
5500 2983 141D (fig-forth-auto680):05380 TRIAD3 FDB XLOOP
5501 2985 FFEE (fig-forth-auto680):05381 FDB TRIAD2-*-NATWID
5502 2987 157713A7 (fig-forth-auto680):05382 FDB CR,LIT8
5503 298B 0F (fig-forth-auto680):05383 FCB $0F
5504 298C 252B1577 (fig-forth-auto680):05384 FDB MESS,CR
5505 2990 1667 (fig-forth-auto680):05385 FDB SEMIS
5506 (fig-forth-auto680):05386 *
5507 (fig-forth-auto680):05387 * ######>> screen 78 <<
5508 (fig-forth-auto680):05388 * ======>> 222 <<
5509 (fig-forth-auto680):05389 * ( --- )
5510 (fig-forth-auto680):05390 * Alphabetically list the definitions in the current vocabulary.
5511 (fig-forth-auto680):05391 * Expects to output to printer, not TRS80 Color Computer screen.
5512 2992 85 (fig-forth-auto680):05392 FCB $85
5513 2993 564C4953 (fig-forth-auto680):05393 FCC 'VLIS' ; 'VLIST'
5514 2997 D4 (fig-forth-auto680):05394 FCB $D4
5515 2998 2959 (fig-forth-auto680):05395 FDB TRIAD-8
5516 299A 17B913A7 (fig-forth-auto680):05396 VLIST FDB DOCOL,LIT8
5517 299E 80 (fig-forth-auto680):05397 FCB $80
5518 299F 1919178A193E1772 (fig-forth-auto680):05398 FDB OUT,STORE,CONTXT,AT,AT
5520 29A9 1919177219A21772 (fig-forth-auto680):05399 VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
5522 29B3 20 (fig-forth-auto680):05400 FCB 32
5523 29B4 1A041A351409 (fig-forth-auto680):05401 FDB SUB,GREAT,ZBRAN
5524 29BA 0008 (fig-forth-auto680):05402 FDB VLIST2-*-NATWID
5525 29BC 1577183D1919178A (fig-forth-auto680):05403 FDB CR,ZERO,OUT,STORE
5526 29C4 174520301A571A57 (fig-forth-auto680):05404 VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
5528 29D2 174516A3156A161E (fig-forth-auto680):05405 FDB DUP,ZEQU,QTERM,OR,ZBRAN
5530 29DC FFCB (fig-forth-auto680):05406 FDB VLIST1-*-NATWID
5531 29DE 172A (fig-forth-auto680):05407 FDB DROP
5532 29E0 1667 (fig-forth-auto680):05408 FDB SEMIS
5533 (fig-forth-auto680):05409 *
5534 (fig-forth-auto680):05410 * Need some utility stuff that isn't in the fig FORTH:
5535 (fig-forth-auto680):05411 * ( c --- )
5536 (fig-forth-auto680):05412 * Emit dot if c is less than blank, else emit c
5537 29E2 85 (fig-forth-auto680):05413 FCB $85
5538 29E3 42454D49 (fig-forth-auto680):05414 FCC 'BEMI' ; 'BEMIT'
5539 29E7 D4 (fig-forth-auto680):05415 FCB $D4 ; 'T'
5540 29E8 2992 (fig-forth-auto680):05416 FDB VLIST-8
5541 29EA 17B9 (fig-forth-auto680):05417 BEMIT FDB DOCOL
5542 29EC 1745185E1A1D1409 (fig-forth-auto680):05418 FDB DUP,BL,LESS,ZBRAN
5543 29F4 0005 (fig-forth-auto680):05419 FDB BEMITO-*-NATWID
5544 29F6 172A13A7 (fig-forth-auto680):05420 FDB DROP,LIT8
5545 29FA 2E (fig-forth-auto680):05421 FCB $2e ; '.'
5546 29FB 1542 (fig-forth-auto680):05422 BEMITO FDB EMIT
5547 29FD 1667 (fig-forth-auto680):05423 FDB SEMIS
5548 (fig-forth-auto680):05424 *
5549 (fig-forth-auto680):05425 * ( n width --- )
5550 (fig-forth-auto680):05426 * Output n in hexadecimal field width.
5551 29FF 83 (fig-forth-auto680):05427 FCB $83
5552 2A00 582E (fig-forth-auto680):05428 FCC 'X.' ; 'X.R'
5553 2A02 D2 (fig-forth-auto680):05429 FCB $D2 ; 'R'
5554 2A03 29E2 (fig-forth-auto680):05430 FDB BEMIT-8
5555 2A05 17B9 (fig-forth-auto680):05431 XDOTR FDB DOCOL
5556 2A07 1963177216811C10 (fig-forth-auto680):05432 FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
5558 2A17 1667 (fig-forth-auto680):05433 FDB SEMIS
5559 (fig-forth-auto680):05434 *
5560 (fig-forth-auto680):05435 * ( adr --- )
5561 (fig-forth-auto680):05436 * Dump a line of 4 bytes in memory, in hex and as characters.
5562 2A19 85 (fig-forth-auto680):05437 FCB $85
5563 2A1A 424C494E (fig-forth-auto680):05438 FCC 'BLIN' ; 'BLINE'
5564 2A1E C5 (fig-forth-auto680):05439 FCB $C5 ; 'E'
5565 2A1F 29FF (fig-forth-auto680):05440 FDB XDOTR-6
5566 2A21 17B9 (fig-forth-auto680):05441 BLINE FDB DOCOL
5567 2A23 174513A7 (fig-forth-auto680):05442 FDB DUP,LIT8
5568 2A27 04 (fig-forth-auto680):05443 FCB 4
5569 2A28 16C6171C1453 (fig-forth-auto680):05444 FDB PLUS,OVER,XDO
5570 2A2E 1465177E18552A05 (fig-forth-auto680):05445 BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
5572 2A38 FFF4 (fig-forth-auto680):05446 FDB BLINEX-*-NATWID
5573 2A3A 1A571A57 (fig-forth-auto680):05447 FDB SPACE,SPACE
5574 2A3E 174513A7 (fig-forth-auto680):05448 FDB DUP,LIT8
5575 2A42 04 (fig-forth-auto680):05449 FCB 4
5576 2A43 17361453 (fig-forth-auto680):05450 FDB SWAP,XDO
5577 2A47 1465177E29EA141D (fig-forth-auto680):05451 BLINEC FDB I,CAT,BEMIT,XLOOP
5578 2A4F FFF6 (fig-forth-auto680):05452 FDB BLINEC-*-NATWID
5579 2A51 1667 (fig-forth-auto680):05453 FDB SEMIS
5580 (fig-forth-auto680):05454 *
5581 (fig-forth-auto680):05455 * ( start end --- )
5582 (fig-forth-auto680):05456 * Dump 4 byte lines from start to end.
5583 2A53 85 (fig-forth-auto680):05457 FCB $85
5584 2A54 4244554D (fig-forth-auto680):05458 FCC 'BDUM' ; 'BDUMP'
5585 2A58 D0 (fig-forth-auto680):05459 FCB $D0 ; '5'
5586 2A59 2A19 (fig-forth-auto680):05460 FDB BLINE-8
5587 2A5B 17B9 (fig-forth-auto680):05461 BDUMP FDB DOCOL
5588 2A5D 1453 (fig-forth-auto680):05462 FDB XDO
5589 2A5F 146513A7 (fig-forth-auto680):05463 BDUMPL FDB I,LIT8
5590 2A63 04 (fig-forth-auto680):05464 FCB 4
5591 2A64 2A0513A7 (fig-forth-auto680):05465 FDB XDOTR,LIT8
5592 2A68 3A (fig-forth-auto680):05466 FCB $3A
5593 2A69 15421A57 (fig-forth-auto680):05467 FDB EMIT,SPACE
5594 2A6D 14652A21157713A7 (fig-forth-auto680):05468 FDB I,BLINE,CR,LIT8
5595 2A75 04 (fig-forth-auto680):05469 FCB 4
5596 2A76 143C (fig-forth-auto680):05470 FDB XPLOOP
5597 2A78 FFE5 (fig-forth-auto680):05471 FDB BDUMPL-*-NATWID
5598 2A7A 1667 (fig-forth-auto680):05472 FDB SEMIS
5599 (fig-forth-auto680):05473 *
5600 (fig-forth-auto680):05474 * ======>> XX <<
5601 (fig-forth-auto680):05475 * ( --- )
5602 (fig-forth-auto680):05476 * Mostly for place holding (fig Forth).
5603 2A7C 84 (fig-forth-auto680):05477 FCB $84
5604 2A7D 4E4F4F (fig-forth-auto680):05478 FCC 'NOO' ; 'NOOP'
5605 2A80 D0 (fig-forth-auto680):05479 FCB $D0
5606 2A81 2A53 (fig-forth-auto680):05480 FDB BDUMP-8
5607 2A83 1228 (fig-forth-auto680):05481 NOOP FDB NEXT a useful no-op
5608 2A85 0000000000000000 (fig-forth-auto680):05482 ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
5610 (fig-forth-auto680):05483
5611 (fig-forth-auto680):05484 PAGE
5612 (fig-forth-auto680):05485 * These things, up through the lable 'REND', are overwritten
5613 (fig-forth-auto680):05486 * at time of cold load and should have the same contents
5614 (fig-forth-auto680):05487 * as shown here:
5615 (fig-forth-auto680):05488 *
5616 (fig-forth-auto680):05489 * This can be moved whereever the bottom of the
5617 (fig-forth-auto680):05490 * user's dictionary is going to be put.
5618 (fig-forth-auto680):05491 *
5619 2A95 C5 (fig-forth-auto680):05492 FCB $C5 immediate
5620 2A96 464F5254 (fig-forth-auto680):05493 FCC 'FORT' ; 'FORTH'
5621 2A9A C8 (fig-forth-auto680):05494 FCB $C8
5622 2A9B 2A7C (fig-forth-auto680):05495 FDB NOOP-7
5623 2A9D 1C8621A181A02AC5 (fig-forth-auto680):05496 FORTH FDB DODOES,DOVOC,$81A0,TASK-7
5624 2AA5 0000 (fig-forth-auto680):05497 FDB 0
5625 (fig-forth-auto680):05498 *
5626 2AA7 28432920466F7274 (fig-forth-auto680):05499 FCC "(C) Forth Interest Group, 1979"
5630 (fig-forth-auto680):05500
5631 2AC5 84 (fig-forth-auto680):05501 FCB $84
5632 2AC6 544153 (fig-forth-auto680):05502 FCC 'TAS' ; 'TASK'
5633 2AC9 CB (fig-forth-auto680):05503 FCB $CB
5634 2ACA 2A95 (fig-forth-auto680):05504 FDB FORTH-8
5635 2ACC 17B91667 (fig-forth-auto680):05505 TASK FDB DOCOL,SEMIS
5636 (fig-forth-auto680):05506 *
5637 2AD0 (fig-forth-auto680):05507 REND EQU * ( first empty location in dictionary )
5638 (fig-forth-auto680):05508
5639 (fig-forth-auto680):05509
5640 (fig-forth-auto680):05510
5641 (fig-forth-auto680):05511
5642 (fig-forth-auto680):05512
5643 (fig-forth-auto680):05513
5644 (fig-forth-auto680):05514
5645 (fig-forth-auto680):05515 PAGE
5646 (fig-forth-auto680):05516 OPT L
5647 (fig-forth-auto680):05517 END
OSDN Git Service
