|
57
|
1 ;TITLE 6809 eForth
|
|
|
2
|
|
|
3 ; $Id: ef09.asm,v 1.1 1997/11/24 02:56:01 root Exp $
|
|
|
4 ;
|
|
|
5 ;===============================================================
|
|
|
6 ;
|
|
|
7 ; eForth 1.0 by Bill Muench and C. H. Ting, 1990
|
|
|
8 ; Much of the code is derived from the following sources:
|
|
|
9 ; 8086 figForth by Thomas Newman, 1981 and Joe smith, 1983
|
|
|
10 ; aFORTH by John Rible
|
|
|
11 ; bFORTH by Bill Muench
|
|
|
12 ;
|
|
|
13 ; The goal of this implementation is to provide a simple eForth Model
|
|
|
14 ; which can be ported easily to many 8, 16, 24 and 32 bit CPU's.
|
|
|
15 ; The following attributes make it suitable for CPU's of the '90:
|
|
|
16 ;
|
|
|
17 ; small machine dependent kernel and portable high level code
|
|
|
18 ; source code in the MASM format
|
|
|
19 ; direct threaded code
|
|
|
20 ; separated code and name dictionaries
|
|
|
21 ; simple vectored terminal and file interface to host computer
|
|
|
22 ; aligned with the proposed ANS Forth Standard
|
|
|
23 ; easy upgrade path to optimize for specific CPU
|
|
|
24 ;
|
|
|
25 ; You are invited to implement this Model on your favorite CPU and
|
|
|
26 ; contribute it to the eForth Library for public use. You may use
|
|
|
27 ; a portable implementation to advertise more sophisticated and
|
|
|
28 ; optimized version for commercial purposes. However, you are
|
|
|
29 ; expected to implement the Model faithfully. The eForth Working
|
|
|
30 ; Group reserves the right to reject implementation which deviates
|
|
|
31 ; significantly from this Model.
|
|
|
32 ;
|
|
|
33 ; As the ANS Forth Standard is still evolving, this Model will
|
|
|
34 ; change accordingly. Implementations must state clearly the
|
|
|
35 ; version number of the Model being tracked.
|
|
|
36 ;
|
|
|
37 ; Representing the eForth Working Group in the Silicon Valley FIG Chapter.
|
|
|
38 ; Send contributions to:
|
|
|
39 ;
|
|
|
40 ; Dr. C. H. Ting
|
|
|
41 ; 156 14th Avenue
|
|
|
42 ; San Mateo, CA 94402
|
|
|
43 ; (415) 571-7639
|
|
|
44 ;
|
|
|
45 ;===============================================================
|
|
|
46 ; $Log: ef09.asm,v $
|
|
|
47 ; Revision 1.1 1997/11/24 02:56:01 root
|
|
|
48 ; Initial revision
|
|
|
49 ;
|
|
|
50 ;===============================================================
|
|
|
51 ;; Version control
|
|
|
52
|
|
|
53 VER EQU 1 ;major release version
|
|
|
54 EXT EQU 0 ;minor extension
|
|
|
55
|
|
|
56 ;; Constants
|
|
|
57
|
|
|
58 TRUEE EQU -1 ;true flag
|
|
|
59
|
|
|
60 COMPO EQU $40 ;lexicon compile only bit
|
|
|
61 IMEDD EQU $80 ;lexicon immediate bit
|
|
|
62 MASKK EQU $1F7F ;lexicon bit mask
|
|
|
63
|
|
|
64 CFAOFF EQU 3 ;offset from word entry to code field area
|
|
|
65 ; (length of JSR)
|
|
|
66 CELLL EQU 2 ;size of a cell
|
|
|
67 BASEE EQU 10 ;default radix
|
|
|
68 VOCSS EQU 8 ;depth of vocabulary stack
|
|
|
69
|
|
|
70 BKSPP EQU 8 ;back space
|
|
|
71 BKSPP2 EQU 127 ;back space
|
|
|
72 LF EQU 10 ;line feed
|
|
|
73 CRR EQU 13 ;carriage return
|
|
|
74 ERR EQU 27 ;error escape
|
|
|
75 TIC EQU 39 ;tick
|
|
|
76
|
|
|
77 CALLL EQU $12BD ;NOP CALL opcodes
|
|
|
78
|
|
|
79 ;; Memory allocation
|
|
|
80
|
|
|
81 EM EQU $4000 ;top of memory
|
|
|
82 US EQU 64*CELLL ;user area size in cells
|
|
|
83 RTS EQU 128*CELLL ;return stack/TIB size
|
|
|
84
|
|
|
85 UPP EQU EM-US ;start of user area (UP0)
|
|
|
86 RPP EQU UPP-8*CELLL ;start of return stack (RP0)
|
|
|
87 TIBB EQU RPP-RTS ;terminal input buffer (TIB)
|
|
|
88 SPP EQU TIBB-8*CELLL ;start of data stack (SP0)
|
|
|
89
|
|
|
90 COLDD EQU $100 ;cold start vector
|
|
|
91 CODEE EQU COLDD+US ;code dictionary
|
|
|
92 NAMEE EQU EM-$0400 ;name dictionary
|
|
|
93
|
|
|
94 ;; Initialize assembly variables
|
|
|
95
|
|
|
96
|
|
|
97 ;; Main entry points and COLD start data
|
|
|
98
|
|
|
99
|
|
|
100 ORG COLDD ;beginning of cold boot area
|
|
|
101 SETDP 0
|
|
|
102
|
|
|
103 ORIG lds #SPP ;Init stack pointer.
|
|
|
104 ldy #RPP ;Init return stack pointer
|
|
|
105 ldu #COLD1 ;Init Instr pointer.
|
|
|
106 pulu pc ;next.
|
|
|
107
|
|
|
108 ; COLD start moves the following to USER variables.
|
|
|
109 ; MUST BE IN SAME ORDER AS USER VARIABLES.
|
|
|
110
|
|
|
111
|
|
|
112 UZERO RMB 8 ;reserved space in user area
|
|
|
113 FDB SPP ;SP0
|
|
|
114 FDB RPP ;RP0
|
|
|
115 FDB QRX ;'?KEY
|
|
|
116 FDB TXSTO ;'EMIT
|
|
|
117 FDB ACCEP ;'EXPECT
|
|
|
118 FDB KTAP ;'TAP
|
|
|
119 FDB TXSTO ;'ECHO
|
|
|
120 FDB DOTOK ;'PROMPT
|
|
|
121 FDB BASEE ;BASE
|
|
|
122 FDB 0 ;tmp
|
|
|
123 FDB 0 ;SPAN
|
|
|
124 FDB 0 ;>IN
|
|
|
125 FDB 0 ;#TIB
|
|
|
126 FDB TIBB ;TIB
|
|
|
127 FDB 0 ;CSP
|
|
|
128 FDB INTER ;'EVAL
|
|
|
129 FDB NUMBQ ;'NUMBER
|
|
|
130 FDB 0 ;HLD
|
|
|
131 FDB 0 ;HANDLER
|
|
|
132 FDB 0 ;CONTEXT pointer
|
|
|
133 RMB VOCSS*2 ;vocabulary stack
|
|
|
134 FDB 0 ;CURRENT pointer
|
|
|
135 FDB 0 ;vocabulary link pointer
|
|
|
136 FDB CTOP ;CP
|
|
|
137 FDB NTOP ;NP
|
|
|
138 FDB LASTN ;LAST
|
|
|
139 ULAST
|
|
|
140
|
|
|
141 ORG CODEE ;beginning of the code dictionary
|
|
|
142
|
|
|
143 ;; Device dependent I/O
|
|
|
144
|
|
|
145 ; BYE ( -- )
|
|
|
146 ; Exit eForth.
|
|
|
147
|
|
|
148 FDB BYE,0
|
|
|
149 L100 FCB 3,"BYE"
|
|
|
150 BYE sync
|
|
|
151
|
|
|
152 ; ?RX ( -- c T | F )
|
|
|
153 ; Return input character and true, or a false if no input.
|
|
|
154
|
|
|
155 FDB QRX,L100
|
|
|
156 L110 FCB 3,"?RX"
|
|
|
157 QRX ldx #0
|
|
|
158 swi3
|
|
|
159 bcc qrx1
|
|
|
160 stx ,--s
|
|
|
161 pulu pc
|
|
|
162 qrx1 clra
|
|
|
163 std ,--s
|
|
|
164 leax -1,x
|
|
|
165 stx ,--s
|
|
|
166 pulu pc
|
|
|
167
|
|
|
168 ; TX! ( c -- )
|
|
|
169 ; Send character c to the output device.
|
|
|
170 FDB TXSTO,L110
|
|
|
171 L120 FCB 3,"TX!"
|
|
|
172 TXSTO ldd ,s++
|
|
|
173 cmpb #$ff
|
|
|
174 bne tx1
|
|
|
175 ldb #32
|
|
|
176 tx1 swi2
|
|
|
177 pulu pc
|
|
|
178
|
|
|
179
|
|
|
180 ; !IO ( -- )
|
|
|
181 ; Initialize the serial I/O devices.
|
|
|
182
|
|
|
183 FDB STOIO,L120
|
|
|
184 L130 FCB 3,"!IO"
|
|
|
185 STOIO pulu pc
|
|
|
186
|
|
|
187 ;; The kernel
|
|
|
188
|
|
|
189 ; doLIT ( -- w )
|
|
|
190 ; Push an inline literal.
|
|
|
191
|
|
|
192 FDB DOLIT,L130
|
|
|
193 L140 FCB COMPO+5,"doLIT"
|
|
|
194 DOLIT
|
|
|
195 ;;;; ldd ,u++
|
|
|
196 pulu d
|
|
|
197 ; 7 cycles
|
|
|
198 pshs d
|
|
|
199 ;;;; 8 cycles
|
|
|
200 ;;;; std ,--s
|
|
|
201 pulu pc
|
|
|
202
|
|
|
203 ; doCLIT ( -- w )
|
|
|
204 ; Push an inline 8-bit literal.
|
|
|
205
|
|
|
206 FDB DOCLIT,L140
|
|
|
207 L141 FCB COMPO+6,"doCLIT"
|
|
|
208 DOCLIT
|
|
|
209 pulu b
|
|
|
210 sex ; sign extended
|
|
|
211 pshs d
|
|
|
212 pulu pc
|
|
|
213
|
|
|
214 ; doLIST ( a -- )
|
|
|
215 ; Process colon list.
|
|
|
216
|
|
|
217 FDB DOLST,L141
|
|
|
218 L150 FCB COMPO+6,"doLIST"
|
|
|
219 DOLST stu ,--y ; IP on return stack
|
|
|
220 puls u ; JSR left new IP on parameter stack
|
|
|
221 ;;;; ldu ,s++
|
|
|
222 pulu pc ; FORTH NEXT IP
|
|
|
223
|
|
|
224 ; next ( -- )
|
|
|
225 ; Run time code for the single index loop.
|
|
|
226 ; : next ( -- ) \ hilevel model
|
|
|
227 ; r> r> dup if 1 - >r @ >r exit then drop cell+ >r ;
|
|
|
228
|
|
|
229 FDB DONXT,L150
|
|
|
230 L160 FCB COMPO+4,"next"
|
|
|
231 DONXT ldd ,y ; counter on return stack
|
|
|
232 subd #1 ; decrement
|
|
|
233 bcs next1 ; < -> exit loop
|
|
|
234 std ,y ; decremented value back on stack
|
|
|
235 ldu ,u ; branch to begin of loop
|
|
|
236 pulu pc
|
|
|
237 next1 leay 2,y ; remove counter from stack
|
|
|
238 leau 2,u ; skip branch destination
|
|
|
239 pulu pc
|
|
|
240
|
|
|
241
|
|
|
242 ; ?branch ( f -- )
|
|
|
243 ; Branch if flag is zero.
|
|
|
244
|
|
|
245 FDB QBRAN,L160
|
|
|
246 L170 FCB COMPO+7,"?branch"
|
|
|
247 QBRAN ;$CODE COMPO+7,'?branch',QBRAN
|
|
|
248 ldd ,s++
|
|
|
249 beq bran1
|
|
|
250 leau 2,u ; skip new IP, no branch
|
|
|
251 pulu pc
|
|
|
252 bran1 ldu ,u ; go to new IP
|
|
|
253 pulu pc
|
|
|
254
|
|
|
255 ; branch ( -- )
|
|
|
256 ; Branch to an inline address.
|
|
|
257
|
|
|
258 FDB BRAN,L170
|
|
|
259 L180 FCB COMPO+6,"branch"
|
|
|
260 BRAN ldu ,u ; destination immediate after BRANCH
|
|
|
261 pulu pc
|
|
|
262
|
|
|
263 ; EXECUTE ( ca -- )
|
|
|
264 ; Execute the word at ca.
|
|
|
265
|
|
|
266 FDB EXECU,L180
|
|
|
267 L190 FCB 7,"EXECUTE"
|
|
|
268 EXECU rts ; code pointer on parameter stack
|
|
|
269
|
|
|
270 ; EXIT ( -- )
|
|
|
271 ; SEMIS
|
|
|
272 ; Terminate a colon definition.
|
|
|
273
|
|
|
274 FDB EXIT,L190
|
|
|
275 L200 FCB 4,"EXIT"
|
|
|
276 EXIT ldu ,y++ ; get calling IP from return stack
|
|
|
277 pulu pc
|
|
|
278
|
|
|
279 ; ! ( w a -- )
|
|
|
280 ; Pop the data stack to memory.
|
|
|
281
|
|
|
282 FDB STORE,L200
|
|
|
283 L210 FCB 1,"!"
|
|
|
284 STORE
|
|
|
285 ;;;; ldx ,s++
|
|
|
286 ;;;; ldd ,s++
|
|
|
287 ;;;; faster ...
|
|
|
288 puls x
|
|
|
289 puls d
|
|
|
290 ; we cannot use puls x,d because the order fetched would be wrong :(
|
|
|
291 std ,x
|
|
|
292 pulu pc
|
|
|
293
|
|
|
294 ; @ ( a -- w )
|
|
|
295 ; Push memory location to the data stack.
|
|
|
296
|
|
|
297 FDB AT,L210
|
|
|
298 L220 FCB 1,"@"
|
|
|
299 AT ldd [,s]
|
|
|
300 std ,s
|
|
|
301 pulu pc
|
|
|
302
|
|
|
303 ; C! ( c b -- )
|
|
|
304 ; Pop the data stack to byte memory.
|
|
|
305
|
|
|
306 FDB CSTOR,L220
|
|
|
307 L230 FCB 2,"C!"
|
|
|
308 CSTOR
|
|
|
309 ;;;; ldx ,s++
|
|
|
310 ;;;; ldd ,s++
|
|
|
311 ;;;; faster ...
|
|
|
312 puls x
|
|
|
313 puls d
|
|
|
314 ; we cannot use puls x,d because the order fetched would be wrong :(
|
|
|
315 stb ,x
|
|
|
316 pulu pc
|
|
|
317
|
|
|
318
|
|
|
319 ; C@ ( b -- c )
|
|
|
320 ; Push byte memory location to the data stack.
|
|
|
321
|
|
|
322 FDB CAT,L230
|
|
|
323 L240 FCB 2,"C@"
|
|
|
324 CAT ldb [,s]
|
|
|
325 clra
|
|
|
326 std ,s
|
|
|
327 pulu pc
|
|
|
328
|
|
|
329 ; RP@ ( -- a )
|
|
|
330 ; Push the current RP to the data stack.
|
|
|
331
|
|
|
332 FDB RPAT,L240
|
|
|
333 L250 FCB 3,"RP@"
|
|
|
334 RPAT pshs y
|
|
|
335 pulu pc
|
|
|
336
|
|
|
337 ; RP! ( a -- )
|
|
|
338 ; Set the return stack pointer.
|
|
|
339
|
|
|
340 FDB RPSTO,L250
|
|
|
341 L260 FCB 3,"RP!"
|
|
|
342 RPSTO puls y
|
|
|
343 pulu pc
|
|
|
344
|
|
|
345 ; R> ( -- w )
|
|
|
346 ; Pop the return stack to the data stack.
|
|
|
347
|
|
|
348 FDB RFROM,L260
|
|
|
349 L270 FCB 2,"R>"
|
|
|
350 RFROM ldd ,y++
|
|
|
351 ;;;; std ,--s
|
|
|
352 pshs d
|
|
|
353 pulu pc
|
|
|
354
|
|
|
355 ; I ( -- w )
|
|
|
356 ; Copy top of return stack (current index from DO/LOOP) to the data stack.
|
|
|
357
|
|
|
358 FDB RAT,L270
|
|
|
359 L279 FCB 1,"I"
|
|
|
360
|
|
|
361 ; R@ ( -- w )
|
|
|
362 ; Copy top of return stack to the data stack.
|
|
|
363
|
|
|
364 FDB RAT,L279
|
|
|
365 L280 FCB 2,"R@"
|
|
|
366 RAT
|
|
|
367 I
|
|
|
368 ldd ,y
|
|
|
369 ;;;; std ,--s
|
|
|
370 pshs d
|
|
|
371 pulu pc
|
|
|
372
|
|
|
373 ; >R ( w -- )
|
|
|
374 ; Push the data stack to the return stack.
|
|
|
375
|
|
|
376 FDB TOR,L280
|
|
|
377 L290 FCB 2,">R"
|
|
|
378 TOR
|
|
|
379 ;;;; ldd ,s++
|
|
|
380 puls d
|
|
|
381 std ,--y
|
|
|
382 pulu pc
|
|
|
383
|
|
|
384 ; SP@ ( -- a )
|
|
|
385 ; Push the current data stack pointer.
|
|
|
386
|
|
|
387 FDB SPAT,L290
|
|
|
388 L300 FCB 3,"SP@"
|
|
|
389 SPAT
|
|
|
390 tfr s,d
|
|
|
391 std ,--s
|
|
|
392 ;;;; alternatively
|
|
|
393 ;;;; sts ,--s ; does this work?
|
|
|
394 pulu pc
|
|
|
395
|
|
|
396 ; SP! ( a -- )
|
|
|
397 ; Set the data stack pointer.
|
|
|
398
|
|
|
399 FDB SPSTO,L300
|
|
|
400 L310 FCB 3,"SP!"
|
|
|
401 SPSTO lds ,s
|
|
|
402 pulu pc
|
|
|
403
|
|
|
404 ; DROP ( w -- )
|
|
|
405 ; Discard top stack item.
|
|
|
406
|
|
|
407 FDB DROP,L310
|
|
|
408 L320 FCB 4,"DROP"
|
|
|
409 DROP leas 2,s
|
|
|
410 pulu pc
|
|
|
411
|
|
|
412 ; DUP ( w -- w w )
|
|
|
413 ; Duplicate the top stack item.
|
|
|
414
|
|
|
415 FDB DUPP,L320
|
|
|
416 L330 FCB 3,"DUP"
|
|
|
417 DUPP ldd ,s
|
|
|
418 ;;;; std ,--s
|
|
|
419 pshs d
|
|
|
420 pulu pc
|
|
|
421
|
|
|
422 ; SWAP ( w1 w2 -- w2 w1 )
|
|
|
423 ; Exchange top two stack items.
|
|
|
424
|
|
|
425 FDB SWAP,L330
|
|
|
426 L340 FCB 4,"SWAP"
|
|
|
427 SWAP
|
|
|
428 ;;;;OLD 1: slow
|
|
|
429 ;;;; ldx ,s++
|
|
|
430 ;;;; ldd ,s++
|
|
|
431 ;;;;OLD 2: faster
|
|
|
432 ;;;; puls x
|
|
|
433 ;;;; puls d
|
|
|
434 ;;;; pshs d,x
|
|
|
435 ;more efficient, without unnecessary stack pointer manipulations
|
|
|
436 ldd ,s
|
|
|
437 ldx 2,s
|
|
|
438 std 2,s
|
|
|
439 stx ,s
|
|
|
440 pulu pc
|
|
|
441
|
|
|
442 ; OVER ( w1 w2 -- w1 w2 w1 )
|
|
|
443 ; Copy second stack item to top.
|
|
|
444
|
|
|
445 FDB OVER,L340
|
|
|
446 L350 FCB 4,"OVER"
|
|
|
447 OVER ldd 2,s
|
|
|
448 ;;;; std ,--s
|
|
|
449 pshs d
|
|
|
450 pulu pc
|
|
|
451
|
|
|
452 ; 0< ( n -- t )
|
|
|
453 ; Return true if n is negative.
|
|
|
454
|
|
|
455 FDB ZLESS,L350
|
|
|
456 L360 FCB 2,"0<"
|
|
|
457 ZLESS ldb ,s ; input high byte, as D low
|
|
|
458 sex ; sign extend to b to a/b
|
|
|
459 tfr a,b ; high byte: 0 or FF copy to D low
|
|
|
460 std ,s ; D: 0000 or FFFF (= -1)
|
|
|
461 pulu pc
|
|
|
462
|
|
|
463 ; 0= ( n -- t )
|
|
|
464 ; Return true if n is zero
|
|
|
465
|
|
|
466 FDB ZEQUAL,L360
|
|
|
467 L365 FCB 2,"0="
|
|
|
468 ZEQUAL
|
|
|
469 ldx #TRUEE ; true
|
|
|
470 ldd ,s ; TOS
|
|
|
471 beq ZEQUAL1 ; -> true
|
|
|
472 ldx #0 ; false
|
|
|
473 ZEQUAL1 stx ,s ; D: 0000 or FFFF (= -1)
|
|
|
474 pulu pc
|
|
|
475
|
|
|
476 ; AND ( w w -- w )
|
|
|
477 ; Bitwise AND.
|
|
|
478
|
|
|
479 FDB ANDD,L365
|
|
|
480 L370 FCB 3,"AND"
|
|
|
481 ANDD ldd ,s++
|
|
|
482 anda ,s
|
|
|
483 andb 1,s
|
|
|
484 std ,s
|
|
|
485 pulu pc
|
|
|
486
|
|
|
487 ; OR ( w w -- w )
|
|
|
488 ; Bitwise inclusive OR.
|
|
|
489
|
|
|
490 FDB ORR,L370
|
|
|
491 L380 FCB 2,"OR"
|
|
|
492 ORR ldd ,s++
|
|
|
493 ora ,s
|
|
|
494 orb 1,s
|
|
|
495 std ,s
|
|
|
496 pulu pc
|
|
|
497
|
|
|
498 ; XOR ( w w -- w )
|
|
|
499 ; Bitwise exclusive OR.
|
|
|
500
|
|
|
501 FDB XORR,L380
|
|
|
502 L390 FCB 3,"XOR"
|
|
|
503 XORR ldd ,s++
|
|
|
504 eora ,s
|
|
|
505 eorb 1,s
|
|
|
506 std ,s
|
|
|
507 pulu pc
|
|
|
508
|
|
|
509 ; D+ ( ud ud -- udsum )
|
|
|
510 ; Add two unsigned double numbers and return a double sum.
|
|
|
511
|
|
|
512 FDB DPLUS,L390
|
|
|
513 L391 FCB 2,"D+"
|
|
|
514 DPLUS ldd 2,s ; add low words
|
|
|
515 addd 6,s
|
|
|
516 std 6,s
|
|
|
517 ldd ,s ; add hig words
|
|
|
518 adcb 5,s
|
|
|
519 adca 4,s
|
|
|
520 std 4,s
|
|
|
521 leas 4,s ; drop one double
|
|
|
522 pulu pc
|
|
|
523
|
|
|
524 ; D- ( ud ud -- uddiff )
|
|
|
525 ; Subtract two unsigned double numbers and return a double sum.
|
|
|
526
|
|
|
527 FDB DSUB,L391
|
|
|
528 L392 FCB 2,"D-"
|
|
|
529 DSUB jsr DOLST
|
|
|
530 FDB DNEGA,DPLUS,EXIT
|
|
|
531
|
|
|
532
|
|
|
533 ; UM+ ( u u -- udsum )
|
|
|
534 ; Add two unsigned single numbers and return a double sum.
|
|
|
535
|
|
|
536 FDB UPLUS,L392
|
|
|
537 L400 FCB 3,"UM+"
|
|
|
538 UPLUS ldd ,s
|
|
|
539 addd 2,s
|
|
|
540 std 2,s
|
|
|
541 ldd #0
|
|
|
542 adcb #0
|
|
|
543 std ,s
|
|
|
544 pulu pc
|
|
|
545
|
|
|
546 ;; Constants
|
|
|
547
|
|
|
548 ; doCONST ( -- w )
|
|
|
549 ; Run time routine for CONSTANT
|
|
|
550
|
|
|
551 FDB DOCONST,L400
|
|
|
552 L401 FCB COMPO+7,"doCONST"
|
|
|
553 DOCONST
|
|
|
554 FDOCONST
|
|
|
555 ldd [,s] ; contents of W (on TOS because of JSR)
|
|
|
556 std ,s ; to TOS (replacing W)
|
|
|
557 pulu pc
|
|
|
558
|
|
|
559 ; 0 ( -- 0 )
|
|
|
560 ; Constant 0
|
|
|
561
|
|
|
562 FDB ZERO,L401
|
|
|
563 L402 FCB 1,"0"
|
|
|
564 ZERO jsr FDOCONST
|
|
|
565 FDB 0
|
|
|
566
|
|
|
567 ; 1 ( -- 1 )
|
|
|
568 ; Constant 1
|
|
|
569
|
|
|
570 FDB ONE,L402
|
|
|
571 L403 FCB 1,"1"
|
|
|
572 ONE jsr FDOCONST
|
|
|
573 FDB 1
|
|
|
574
|
|
|
575 ; 2 ( -- 2 )
|
|
|
576 ; Constant 2
|
|
|
577
|
|
|
578 FDB TWO,L403
|
|
|
579 L404 FCB 1,"2"
|
|
|
580 TWO jsr FDOCONST
|
|
|
581 FDB 2
|
|
|
582
|
|
|
583
|
|
|
584 ; -1 ( -- -1 )
|
|
|
585 ; Constant -1
|
|
|
586
|
|
|
587 FDB MONE,L404
|
|
|
588 L405 FCB 2,"-1"
|
|
|
589 MONE jsr FDOCONST
|
|
|
590 FDB -1
|
|
|
591
|
|
|
592 ;; System and user variables
|
|
|
593
|
|
|
594 ; doVAR ( -- a )
|
|
|
595 ; Run time routine for VARIABLE and CREATE.
|
|
|
596
|
|
|
597 FDB DOVAR,L405
|
|
|
598 L410 FCB COMPO+5,"doVAR"
|
|
|
599 DOVAR
|
|
|
600 jsr DOLST
|
|
|
601 FDB RFROM,EXIT
|
|
|
602
|
|
|
603 ;; fast native DOVAR implementation
|
|
|
604 FDOVAR pulu pc
|
|
|
605
|
|
|
606
|
|
|
607 ; UP ( -- a )
|
|
|
608 ; Pointer to the user area.
|
|
|
609
|
|
|
610 FDB UP,L410
|
|
|
611 L420 FCB 2,"UP"
|
|
|
612 UP
|
|
|
613 ;; jsr DOLST
|
|
|
614 ;; FDB DOVAR
|
|
|
615 ;; fast (native) DOVAR
|
|
|
616 jsr FDOVAR
|
|
|
617 FDB UPP
|
|
|
618
|
|
|
619 ; doUSER ( -- a )
|
|
|
620 ; Run time routine for user variables.
|
|
|
621
|
|
|
622 FDB DOUSE,L420
|
|
|
623 L430 FCB COMPO+5,"doUSER"
|
|
|
624 DOUSE
|
|
|
625 jsr DOLST
|
|
|
626 FDB RFROM,AT,UP,AT,PLUS,EXIT
|
|
|
627
|
|
|
628 ;; fast (native) DOUSE implementation (*NOT COMPLETE*)
|
|
|
629 FDOUSE
|
|
|
630 ldd [,s] ; pointer to value (from JSR)
|
|
|
631 addd UP+CFAOFF ; dirty access to start of USER area:
|
|
|
632 ; var. UP value direct access (not
|
|
|
633 ; as a high level word)
|
|
|
634 std ,s ; resulting address returned on p-stack
|
|
|
635 pulu pc
|
|
|
636
|
|
|
637 ; SP0 ( -- a )
|
|
|
638 ; Pointer to bottom of the data stack.
|
|
|
639
|
|
|
640 FDB SZERO,L430
|
|
|
641 L440 FCB 3,"SP0"
|
|
|
642 SZERO
|
|
|
643 jsr FDOUSE
|
|
|
644 FDB 8
|
|
|
645 ;;;; jsr DOLST
|
|
|
646 ;;;; FDB DOUSE,8
|
|
|
647
|
|
|
648 ; RP0 ( -- a )
|
|
|
649 ; Pointer to bottom of the return stack.
|
|
|
650
|
|
|
651 FDB RZERO,L440
|
|
|
652 L450 FCB 3,"RP0"
|
|
|
653 RZERO
|
|
|
654 jsr FDOUSE
|
|
|
655 FDB 10
|
|
|
656 ;;;; jsr DOLST
|
|
|
657 ;;;; FDB DOUSE,10
|
|
|
658
|
|
|
659 ; '?KEY ( -- a )
|
|
|
660 ; Execution vector of ?KEY.
|
|
|
661
|
|
|
662 FDB TQKEY,L450
|
|
|
663 L460 FCB 5,"'?KEY"
|
|
|
664 TQKEY
|
|
|
665 jsr FDOUSE
|
|
|
666 FDB 12
|
|
|
667 ;;;; jsr DOLST
|
|
|
668 ;;;; FDB DOUSE,12
|
|
|
669
|
|
|
670 ; 'EMIT ( -- a )
|
|
|
671 ; Execution vector of EMIT.
|
|
|
672
|
|
|
673 FDB TEMIT,L460
|
|
|
674 L470 FCB 5,"'EMIT"
|
|
|
675 TEMIT
|
|
|
676 jsr FDOUSE
|
|
|
677 FDB 14
|
|
|
678 ;; jsr DOLST
|
|
|
679 ;; FDB DOUSE,14
|
|
|
680
|
|
|
681 ; 'EXPECT ( -- a )
|
|
|
682 ; Execution vector of EXPECT.
|
|
|
683
|
|
|
684 FDB TEXPE,L470
|
|
|
685 L480 FCB 7,"'EXPECT"
|
|
|
686 TEXPE
|
|
|
687 jsr FDOUSE
|
|
|
688 FDB 16
|
|
|
689 ;;;; jsr DOLST
|
|
|
690 ;;;; FDB DOUSE,16
|
|
|
691
|
|
|
692 ; 'TAP ( -- a )
|
|
|
693 ; Execution vector of TAP.
|
|
|
694
|
|
|
695 FDB TTAP,L480
|
|
|
696 L490 FCB 4,"'TAP"
|
|
|
697 TTAP
|
|
|
698 jsr FDOUSE
|
|
|
699 FDB 18
|
|
|
700 ;;;; jsr DOLST
|
|
|
701 ;;;; FDB DOUSE,18
|
|
|
702
|
|
|
703 ; 'ECHO ( -- a )
|
|
|
704 ; Execution vector of ECHO.
|
|
|
705
|
|
|
706 FDB TECHO,L490
|
|
|
707 L500 FCB 5,"'ECHO"
|
|
|
708 TECHO
|
|
|
709 jsr FDOUSE
|
|
|
710 FDB 20
|
|
|
711 ;;;; jsr DOLST
|
|
|
712 ;;;; FDB DOUSE,20
|
|
|
713
|
|
|
714 ; 'PROMPT ( -- a )
|
|
|
715 ; Execution vector of PROMPT.
|
|
|
716
|
|
|
717 FDB TPROM,L500
|
|
|
718 L510 FCB 7,"'PROMPT"
|
|
|
719 TPROM
|
|
|
720 jsr FDOUSE
|
|
|
721 FDB 22
|
|
|
722 ;;;; jsr DOLST
|
|
|
723 ;;;; FDB DOUSE,22
|
|
|
724
|
|
|
725
|
|
|
726 ; BASE ( -- a )
|
|
|
727 ; Storage of the radix base for numeric I/O.
|
|
|
728
|
|
|
729 FDB BASE,L510
|
|
|
730 L520 FCB 4,"BASE"
|
|
|
731 BASE
|
|
|
732 jsr FDOUSE
|
|
|
733 FDB 24
|
|
|
734 ;;;; jsr DOLST
|
|
|
735 ;;;; FDB DOUSE,24
|
|
|
736
|
|
|
737 ; tmp ( -- a )
|
|
|
738 ; A temporary storage location used in parse and find.
|
|
|
739
|
|
|
740 FDB TEMP,L520
|
|
|
741 L530 FCB COMPO+3,"tmp"
|
|
|
742 TEMP
|
|
|
743 jsr FDOUSE
|
|
|
744 FDB 26
|
|
|
745 ;;;; jsr DOLST
|
|
|
746 ;;;; FDB DOUSE,26
|
|
|
747
|
|
|
748 ; SPAN ( -- a )
|
|
|
749 ; Hold character count received by EXPECT.
|
|
|
750
|
|
|
751 FDB SPAN,L530
|
|
|
752 L540 FCB 4,"SPAN"
|
|
|
753 SPAN
|
|
|
754 jsr FDOUSE
|
|
|
755 FDB 28
|
|
|
756 ;;;; jsr DOLST
|
|
|
757 ;;;; FDB DOUSE,28
|
|
|
758
|
|
|
759 ; >IN ( -- a )
|
|
|
760 ; Hold the character pointer while parsing input stream.
|
|
|
761
|
|
|
762 FDB INN,L540
|
|
|
763 L550 FCB 3,">IN"
|
|
|
764 INN
|
|
|
765 jsr FDOUSE
|
|
|
766 FDB 30
|
|
|
767 ;;;; jsr DOLST
|
|
|
768 ;;;; FDB DOUSE,30
|
|
|
769
|
|
|
770 ; #TIB ( -- a )
|
|
|
771 ; Hold the current count in and address of the terminal input buffer.
|
|
|
772
|
|
|
773 FDB NTIB,L550
|
|
|
774 L560 FCB 4,"#TIB"
|
|
|
775 NTIB
|
|
|
776 jsr FDOUSE
|
|
|
777 FDB 32
|
|
|
778 ;;;; jsr DOLST
|
|
|
779 ;;;; FDB DOUSE,32 ;It contains TWO cells!!!!
|
|
|
780
|
|
|
781 ; CSP ( -- a )
|
|
|
782 ; Hold the stack pointer for error checking.
|
|
|
783
|
|
|
784 FDB CSP,L560
|
|
|
785 L570 FCB 3,"CSP"
|
|
|
786 CSP
|
|
|
787 jsr FDOUSE
|
|
|
788 FDB 36
|
|
|
789 ;;;; jsr DOLST
|
|
|
790 ;;;; FDB DOUSE 36
|
|
|
791
|
|
|
792 ; 'EVAL ( -- a )
|
|
|
793 ; Execution vector of EVAL.
|
|
|
794
|
|
|
795 FDB TEVAL,L570
|
|
|
796 L580 FCB 5,"'EVAL"
|
|
|
797 TEVAL
|
|
|
798 jsr FDOUSE
|
|
|
799 FDB 38
|
|
|
800 ;;;; jsr DOLST
|
|
|
801 ;;;; FDB DOUSE,38
|
|
|
802
|
|
|
803 ; 'NUMBER ( -- a )
|
|
|
804 ; Execution vector of NUMBER?.
|
|
|
805
|
|
|
806 FDB TNUMB,L580
|
|
|
807 L590 FCB 7,"'NUMBER"
|
|
|
808 TNUMB
|
|
|
809 jsr FDOUSE
|
|
|
810 FDB 40
|
|
|
811 ;;;; jsr DOLST
|
|
|
812 ;;;; FDB DOUSE,40
|
|
|
813
|
|
|
814 ; HLD ( -- a )
|
|
|
815 ; Hold a pointer in building a numeric output string.
|
|
|
816
|
|
|
817 FDB HLD,L590
|
|
|
818 L600 FCB 3,"HLD"
|
|
|
819 HLD
|
|
|
820 jsr FDOUSE
|
|
|
821 FDB 42
|
|
|
822 ;;;; jsr DOLST
|
|
|
823 ;;;; FDB DOUSE,42
|
|
|
824
|
|
|
825 ; HANDLER ( -- a )
|
|
|
826 ; Hold the return stack pointer for error handling.
|
|
|
827
|
|
|
828 FDB HANDL,L600
|
|
|
829 L610 FCB 7,"HANDLER"
|
|
|
830 HANDL
|
|
|
831 jsr FDOUSE
|
|
|
832 FDB 44
|
|
|
833 ;;;; jsr DOLST
|
|
|
834 ;;;; FDB DOUSE,44
|
|
|
835
|
|
|
836 ; CONTEXT ( -- a )
|
|
|
837 ; A area to specify vocabulary search order.
|
|
|
838
|
|
|
839 FDB CNTXT,L610
|
|
|
840 L620 FCB 7,"CONTEXT"
|
|
|
841 CNTXT
|
|
|
842 jsr FDOUSE
|
|
|
843 FDB 46
|
|
|
844 ;;;; jsr DOLST
|
|
|
845 ;;;; FDB DOUSE,46 ;plus space for voc stack.
|
|
|
846
|
|
|
847 ; CURRENT ( -- a )
|
|
|
848 ; Point to the vocabulary to be extended.
|
|
|
849
|
|
|
850 FDB CRRNT,L620
|
|
|
851 L630 FCB 7,"CURRENT"
|
|
|
852 CRRNT
|
|
|
853 jsr FDOUSE
|
|
|
854 FDB 48+VOCSS*2 ;Extra cell
|
|
|
855 ;;;; jsr DOLST
|
|
|
856 ;;;; FDB DOUSE,48+VOCSS*2 ;Extra cell
|
|
|
857
|
|
|
858 ; CP ( -- a )
|
|
|
859 ; Point to the top of the code dictionary.
|
|
|
860
|
|
|
861 FDB CP,L630
|
|
|
862 L640 FCB 2,"CP"
|
|
|
863 CP
|
|
|
864 jsr FDOUSE
|
|
|
865 FDB 52+VOCSS*2
|
|
|
866 ;;;; jsr DOLST
|
|
|
867 ;;;; FDB DOUSE,52+VOCSS*2
|
|
|
868
|
|
|
869 ; NP ( -- a )
|
|
|
870 ; Point to the bottom of the name dictionary.
|
|
|
871
|
|
|
872 FDB NP,L640
|
|
|
873 L650 FCB 2,"NP"
|
|
|
874 NP
|
|
|
875 jsr FDOUSE
|
|
|
876 FDB 54+VOCSS*2
|
|
|
877 ;;;; jsr DOLST
|
|
|
878 ;;;; FDB DOUSE,54+VOCSS*2
|
|
|
879
|
|
|
880 ; LAST ( -- a )
|
|
|
881 ; Point to the last name in the name dictionary.
|
|
|
882
|
|
|
883 FDB LAST,L650
|
|
|
884 L660 FCB 4,"LAST"
|
|
|
885 LAST
|
|
|
886 jsr FDOUSE
|
|
|
887 FDB 56+VOCSS*2
|
|
|
888 ;;;; jsr DOLST
|
|
|
889 ;;;; FDB DOUSE,56+VOCSS*2
|
|
|
890
|
|
|
891 ;; Common functions
|
|
|
892
|
|
|
893 ; doVOC ( -- )
|
|
|
894 ; Run time action of VOCABULARY's.
|
|
|
895
|
|
|
896 FDB DOVOC,L660
|
|
|
897 L670 FCB COMPO+5,"doVOC"
|
|
|
898 DOVOC
|
|
|
899 jsr DOLST
|
|
|
900 FDB RFROM,CNTXT,STORE,EXIT
|
|
|
901
|
|
|
902 ; FORTH ( -- )
|
|
|
903 ; Make FORTH the context vocabulary.
|
|
|
904
|
|
|
905 FDB FORTH,L670
|
|
|
906 L680 FCB 5,"FORTH"
|
|
|
907 FORTH
|
|
|
908 jsr DOLST
|
|
|
909 FDB DOVOC
|
|
|
910 FDB 0 ;vocabulary head pointer
|
|
|
911 FDB 0 ;vocabulary link pointer
|
|
|
912
|
|
|
913 ; ?DUP ( w -- w w | 0 )
|
|
|
914 ; Dup tos if its is not zero.
|
|
|
915
|
|
|
916 FDB QDUP,L680
|
|
|
917 L690 FCB 4,"?DUP"
|
|
|
918 QDUP
|
|
|
919 jsr DOLST
|
|
|
920 FDB DUPP
|
|
|
921 FDB QBRAN,QDUP1
|
|
|
922 FDB DUPP
|
|
|
923 QDUP1 FDB EXIT
|
|
|
924
|
|
|
925 ; ROT ( w1 w2 w3 -- w2 w3 w1 )
|
|
|
926 ; Rot 3rd item to top.
|
|
|
927
|
|
|
928 FDB ROT,L690
|
|
|
929 L700 FCB 3,"ROT"
|
|
|
930 ROT
|
|
|
931 jsr DOLST
|
|
|
932 FDB TOR,SWAP,RFROM,SWAP,EXIT
|
|
|
933
|
|
|
934 ; 2DROP ( w w -- )
|
|
|
935 ; Discard two items on stack.
|
|
|
936
|
|
|
937 FDB DDROP,L700
|
|
|
938 L710 FCB 5,"2DROP"
|
|
|
939 DDROP
|
|
|
940 jsr DOLST
|
|
|
941 FDB DROP,DROP,EXIT
|
|
|
942
|
|
|
943 ; 2DUP ( w1 w2 -- w1 w2 w1 w2 )
|
|
|
944 ; Duplicate top two items.
|
|
|
945
|
|
|
946 FDB DDUP,L710
|
|
|
947 L720 FCB 4,"2DUP"
|
|
|
948 DDUP
|
|
|
949 jsr DOLST
|
|
|
950 FDB OVER,OVER,EXIT
|
|
|
951
|
|
|
952 ; LSHIFT ( w n -- w )
|
|
|
953 ; Shift word left n times.
|
|
|
954 FDB LSHIFT,L720
|
|
|
955 L721 FCB 6,"LSHIFT"
|
|
|
956 LSHIFT ldx ,s++ ;shift count
|
|
|
957 beq LSHIFT2
|
|
|
958 ldd ,s ;value to shift
|
|
|
959 LSHIFT1 aslb ;low
|
|
|
960 rola ;high
|
|
|
961 leax -1,x ;count down
|
|
|
962 bne LSHIFT1
|
|
|
963 std ,s
|
|
|
964 LSHIFT2
|
|
|
965 pulu pc
|
|
|
966
|
|
|
967 ; RSHIFT ( w n -- w )
|
|
|
968 ; Shift word right n times.
|
|
|
969 FDB RSHIFT,L721
|
|
|
970 L721A FCB 6,"RSHIFT"
|
|
|
971 RSHIFT ldx ,s++ ;shift count
|
|
|
972 beq RSHIFT2
|
|
|
973 ldd ,s ;value to shift
|
|
|
974 RSHIFT1 lsra ;high
|
|
|
975 rorb ;low
|
|
|
976 leax -1,x ;count down
|
|
|
977 bne RSHIFT1
|
|
|
978 std ,s
|
|
|
979 RSHIFT2
|
|
|
980 pulu pc
|
|
|
981
|
|
|
982 ; >< ( w -- w )
|
|
|
983 ; swap high and low byte
|
|
|
984 FDB SWAPHL,L721A
|
|
|
985 L722 FCB 2,"><"
|
|
|
986 SWAPHL ldb ,s ;high -> D low
|
|
|
987 lda 1,s ;low -> D high
|
|
|
988 std ,s
|
|
|
989 pulu pc
|
|
|
990
|
|
|
991 ; 256/ ( w -- w )
|
|
|
992 ; multiply with 256 (shift left 8 times)
|
|
|
993 FDB SLASH256,L722
|
|
|
994 L723 FCB 4,"256/"
|
|
|
995 SLASH256 ldb ,s ;high -> D low
|
|
|
996 clra ;D high = 0
|
|
|
997 std ,s
|
|
|
998 pulu pc
|
|
|
999
|
|
|
1000 ; 256* ( w -- w )
|
|
|
1001 ; multiply with 256 (shift left 8 times)
|
|
|
1002 FDB STAR256,L723
|
|
|
1003 L724 FCB 4,"256*"
|
|
|
1004 STAR256 lda 1,s ;low -> D high
|
|
|
1005 clrb ;D low = 0
|
|
|
1006 std ,s
|
|
|
1007 pulu pc
|
|
|
1008
|
|
|
1009 ; 1+ ( w -- w )
|
|
|
1010 ; Shortcut, quick add 1
|
|
|
1011 FDB PLUS1,L724
|
|
|
1012 L725 FCB 2,"1+"
|
|
|
1013 PLUS1 ldd ,s
|
|
|
1014 addd #1
|
|
|
1015 std ,s
|
|
|
1016 pulu pc
|
|
|
1017
|
|
|
1018 ; -+ ( w -- w )
|
|
|
1019 ; Shortcut, quick subtract 1
|
|
|
1020 FDB MINUS1,L725
|
|
|
1021 L726 FCB 2,"1-"
|
|
|
1022 MINUS1 ldd ,s
|
|
|
1023 subd #1
|
|
|
1024 std ,s
|
|
|
1025 pulu pc
|
|
|
1026
|
|
|
1027 ; 2* ( w -- w )
|
|
|
1028 ; multiply by 2 using shift operation
|
|
|
1029 FDB TWOSTAR,L726
|
|
|
1030 L727 FCB 2,"2*"
|
|
|
1031 TWOSTAR asl 1,s ;low
|
|
|
1032 rol 0,s ;high
|
|
|
1033 pulu pc
|
|
|
1034
|
|
|
1035 ; 2/ ( w -- w )
|
|
|
1036 ; divide by 2 using shift operation
|
|
|
1037 FDB TWOSLASH,L727
|
|
|
1038 L728 FCB 2,"2/"
|
|
|
1039 TWOSLASH asr 0,s ;high
|
|
|
1040 ror 1,s ;low
|
|
|
1041 pulu pc
|
|
|
1042
|
|
|
1043 ; + ( w w -- sum )
|
|
|
1044 ; Add top two items.
|
|
|
1045
|
|
|
1046 FDB PLUS,L728
|
|
|
1047 L730 FCB 1,"+"
|
|
|
1048 PLUS
|
|
|
1049 ldd ,s++
|
|
|
1050 addd ,s
|
|
|
1051 std ,s
|
|
|
1052 pulu pc
|
|
|
1053 ;;; HL with UPLUS!? Too inefficient ...
|
|
|
1054 ;;; jsr DOLST
|
|
|
1055 ;;; FDB UPLUS,DROP,EXIT
|
|
|
1056
|
|
|
1057 ; NOT ( w -- w )
|
|
|
1058 ; One's complement of tos.
|
|
|
1059
|
|
|
1060 FDB INVER,L730
|
|
|
1061 L740 FCB 3,"NOT"
|
|
|
1062 INVER
|
|
|
1063 ;;;; fastest ... (13T)
|
|
|
1064 com ,s ; 6T
|
|
|
1065 com 1,s ; 7T
|
|
|
1066 pulu pc
|
|
|
1067 ;;;; alternative ... (14T)
|
|
|
1068 ldd ,s ;TOS 5T
|
|
|
1069 coma ; 2T
|
|
|
1070 comb ; 2T
|
|
|
1071 std ,s ; 5T
|
|
|
1072 pulu pc
|
|
|
1073 ;;; slow HL ...
|
|
|
1074 ;;; jsr DOLST
|
|
|
1075 ;;; FDB DOLIT,-1,XORR,EXIT
|
|
|
1076
|
|
|
1077 ; NEGATE ( n -- -n )
|
|
|
1078 ; Two's complement of tos.
|
|
|
1079
|
|
|
1080 FDB NEGAT,L740
|
|
|
1081 L750 FCB 6,"NEGATE"
|
|
|
1082 NEGAT
|
|
|
1083 ;;;; fastest? .... (3+6+5 = 14T)
|
|
|
1084 ldd #0 ; 3T
|
|
|
1085 subd ,s ; 6T
|
|
|
1086 std ,s ; 5T
|
|
|
1087 pulu pc
|
|
|
1088 ;;;; alternate ... (7+3+6 = 16T)
|
|
|
1089 neg 1,s ; high 7T
|
|
|
1090 bne NEGAT1 ; 3T
|
|
|
1091 neg ,s ; low with 1+ carry 6T
|
|
|
1092 pulu pc
|
|
|
1093 NEGAT1 com ,s ; low, no 1+ carry 6T
|
|
|
1094 pulu pc
|
|
|
1095 ;;;; slow HL ...
|
|
|
1096 ;;;; jsr DOLST
|
|
|
1097 ;;;; FDB INVER,PLUS1,EXIT
|
|
|
1098
|
|
|
1099 ; DNEGATE ( d -- -d )
|
|
|
1100 ; Two's complement of top double.
|
|
|
1101
|
|
|
1102 FDB DNEGA,L750
|
|
|
1103 L760 FCB 7,"DNEGATE"
|
|
|
1104 DNEGA
|
|
|
1105 ldd #0
|
|
|
1106 subd 2,s ; low word
|
|
|
1107 std 2,s
|
|
|
1108 ldd #0
|
|
|
1109 sbcb 1,s ; high word low byte
|
|
|
1110 sbca ,s ; high word high byte
|
|
|
1111 std ,s
|
|
|
1112 pulu pc
|
|
|
1113 ;;;; slow HL ...
|
|
|
1114 ;;;; jsr DOLST
|
|
|
1115 ;;;; FDB INVER,TOR,INVER
|
|
|
1116 ;;;; FDB DOLIT,1,UPLUS
|
|
|
1117 ;;;; FDB RFROM,PLUS,EXIT
|
|
|
1118
|
|
|
1119 ; - ( n1 n2 -- n1-n2 )
|
|
|
1120 ; Subtraction.
|
|
|
1121
|
|
|
1122 FDB SUBB,L760
|
|
|
1123 L770 FCB 1,"-"
|
|
|
1124 SUBB ldd 2,s
|
|
|
1125 subd ,s++
|
|
|
1126 std ,s
|
|
|
1127 pulu pc
|
|
|
1128 ;;; slow HL ...
|
|
|
1129 ;;; jsr DOLST
|
|
|
1130 ;;; FDB NEGAT,PLUS,EXIT
|
|
|
1131
|
|
|
1132 ; ABS ( n -- n )
|
|
|
1133 ; Return the absolute value of n.
|
|
|
1134
|
|
|
1135 FDB ABSS,L770
|
|
|
1136 L780 FCB 3,"ABS"
|
|
|
1137 ABSS jsr DOLST
|
|
|
1138 FDB DUPP,ZLESS
|
|
|
1139 FDB QBRAN,ABS1
|
|
|
1140 FDB NEGAT
|
|
|
1141 ABS1 FDB EXIT
|
|
|
1142
|
|
|
1143 ; = ( w w -- t )
|
|
|
1144 ; Return true if top two are equal.
|
|
|
1145
|
|
|
1146 FDB EQUAL,L780
|
|
|
1147 L790 FCB 1,"="
|
|
|
1148 EQUAL
|
|
|
1149 ldx #TRUEE
|
|
|
1150 puls d ; first value
|
|
|
1151 cmpd ,s ; compare to 2nd value
|
|
|
1152 beq EQUAL1 ; equal -> true
|
|
|
1153 ldx #0 ; false (leax 1,x save 1 byte, but is slower)
|
|
|
1154 EQUAL1 stx ,s
|
|
|
1155 pulu pc
|
|
|
1156 ;;;; slow HL ...
|
|
|
1157 ;;;; jsr DOLST
|
|
|
1158 ;;;; FDB XORR
|
|
|
1159 ;;;; FDB QBRAN,EQU1
|
|
|
1160 ;;;; FDB DOLIT,0,EXIT
|
|
|
1161 ;;;;EQU1: FDB DOLIT,TRUEE,EXIT
|
|
|
1162
|
|
|
1163 ; U< ( u1 u2 -- t )
|
|
|
1164 ; Unsigned compare of top two items.
|
|
|
1165
|
|
|
1166 FDB ULESS,L790
|
|
|
1167 L800 FCB 2,"U<"
|
|
|
1168 ULESS
|
|
|
1169 ldx #TRUEE ; true
|
|
|
1170 puls d ; u2
|
|
|
1171 cmpd ,s ; u2 - u1
|
|
|
1172 bhi ULES1 ; unsigned: u2 higher u1
|
|
|
1173 ldx #0 ; false
|
|
|
1174 ULES1 stx ,s ; replace TOS with result
|
|
|
1175 pulu pc
|
|
|
1176 ;;;; slow HL ...
|
|
|
1177 ;;;; jsr DOLST
|
|
|
1178 ;;;; FDB DDUP,XORR,ZLESS
|
|
|
1179 ;;;; FDB QBRAN,ULES1
|
|
|
1180 ;;;; FDB SWAP,DROP,ZLESS,EXIT
|
|
|
1181 ;;;;ULES1: FDB SUBB,ZLESS,EXIT
|
|
|
1182
|
|
|
1183 ; < ( n1 n2 -- t )
|
|
|
1184 ; Signed compare of top two items.
|
|
|
1185
|
|
|
1186 FDB LESS,L800
|
|
|
1187 L810 FCB 1,"<"
|
|
|
1188 LESS
|
|
|
1189 ldx #TRUEE ; true
|
|
|
1190 puls d ; n2
|
|
|
1191 cmpd ,s ; n2 - n1
|
|
|
1192 bgt LESS1 ; signed: n2 greater than n1
|
|
|
1193 ldx #0 ; false
|
|
|
1194 LESS1 stx ,s ; replace TOS with result
|
|
|
1195 pulu pc
|
|
|
1196
|
|
|
1197 ;;;; slow HL ...
|
|
|
1198 ;;;; jsr DOLST
|
|
|
1199 ;;;; FDB DDUP,XORR,ZLESS
|
|
|
1200 ;;;; FDB QBRAN,LESS1
|
|
|
1201 ;;;; FDB DROP,ZLESS,EXIT
|
|
|
1202 ;;;;LESS1: FDB SUBB,ZLESS,EXIT
|
|
|
1203
|
|
|
1204 ; MAX ( n n -- n )
|
|
|
1205 ; Return the greater of two top stack items.
|
|
|
1206
|
|
|
1207 FDB MAX,L810
|
|
|
1208 L820 FCB 3,"MAX"
|
|
|
1209 MAX jsr DOLST
|
|
|
1210 FDB DDUP,LESS
|
|
|
1211 FDB QBRAN,MAX1
|
|
|
1212 FDB SWAP
|
|
|
1213 MAX1 FDB DROP,EXIT
|
|
|
1214
|
|
|
1215 ; MIN ( n n -- n )
|
|
|
1216 ; Return the smaller of top two stack items.
|
|
|
1217
|
|
|
1218 FDB MIN,L820
|
|
|
1219 L830 FCB 3,"MIN"
|
|
|
1220 MIN jsr DOLST
|
|
|
1221 FDB DDUP,SWAP,LESS
|
|
|
1222 FDB QBRAN,MIN1
|
|
|
1223 FDB SWAP
|
|
|
1224 MIN1 FDB DROP,EXIT
|
|
|
1225
|
|
|
1226 ; WITHIN ( u ul uh -- t )
|
|
|
1227 ; Return true if u is within the range of ul and uh. ( ul <= u < uh )
|
|
|
1228
|
|
|
1229 FDB WITHI,L830
|
|
|
1230 L840 FCB 6,"WITHIN"
|
|
|
1231 WITHI jsr DOLST
|
|
|
1232 FDB OVER,SUBB,TOR
|
|
|
1233 FDB SUBB,RFROM,ULESS,EXIT
|
|
|
1234
|
|
|
1235 ;; Divide
|
|
|
1236
|
|
|
1237 ; U/ ( udl udh un -- ur uq )
|
|
|
1238 ; Unsigned divide of a double by a single. Return mod and quotient.
|
|
|
1239 ;
|
|
|
1240 ; Special cases:
|
|
|
1241 ; 1. overflow: quotient overflow if dividend is to great (remainder = divisor),
|
|
|
1242 ; remainder is set to $FFFF -> special handling.
|
|
|
1243 ; This is checked also right before the main loop.
|
|
|
1244 ; 2. underflow: divisor does not fit into dividend -> remainder
|
|
|
1245 ; get the value of the dividend -> automatically covered.
|
|
|
1246 ;
|
|
|
1247 ; overflow: quotient = $FFFF, remainder = divisor
|
|
|
1248 ; underflow: quotient = $0000, remainder = dividend low
|
|
|
1249 ; division by zero: quotient = $FFFF, remainder = $0000
|
|
|
1250 ;
|
|
|
1251 ; Testvalues:
|
|
|
1252 ;
|
|
|
1253 ; DIVH DIVL DVSR QUOT REM comment
|
|
|
1254 ;
|
|
|
1255 ; 0100 0000 FFFF 0100 0100 maximum divisor
|
|
|
1256 ; 0000 0001 8000 0000 0001 underflow (REM = DIVL)
|
|
|
1257 ; 0000 5800 3000 0001 1800 normal divsion
|
|
|
1258 ; 5800 0000 3000 FFFF 3000 overflow
|
|
|
1259 ; 0000 0001 0000 FFFF 0000 overflow (division by zero)
|
|
|
1260
|
|
|
1261 FDB USLASH,L840
|
|
|
1262 L845 FCB 2,"U/"
|
|
|
1263
|
|
|
1264 USLASH
|
|
|
1265 ldx #16
|
|
|
1266 ldd 2,s ; udh
|
|
|
1267 cmpd ,s ; dividend to great?
|
|
|
1268 bhs UMMODOV ; quotient overflow!
|
|
|
1269 asl 5,s ; udl low
|
|
|
1270 rol 4,s ; udl high
|
|
|
1271
|
|
|
1272 UMMOD1 rolb ; got one bit from udl
|
|
|
1273 rola
|
|
|
1274 bcs UMMOD2 ; bit 16 means always greater as divisor
|
|
|
1275 cmpd ,s ; divide by un
|
|
|
1276 bhs UMMOD2 ; higher or same as divisor?
|
|
|
1277 andcc #$fe ; clc - clear carry flag
|
|
|
1278 bra UMMOD3
|
|
|
1279 UMMOD2 subd ,s
|
|
|
1280 orcc #$01 ; sec - set carry flag
|
|
|
1281 UMMOD3 rol 5,s ; udl, quotient shifted in
|
|
|
1282 rol 4,s
|
|
|
1283 leax -1,x
|
|
|
1284 bne UMMOD1
|
|
|
1285
|
|
|
1286 ldx 4,s ; quotient
|
|
|
1287 cmpd ,s ; remainder >= divisor -> overflow
|
|
|
1288 blo UMMOD4
|
|
|
1289 UMMODOV
|
|
|
1290 ldd ,s ; remainder set to divisor
|
|
|
1291 ldx #$FFFF ; quotient = FFFF (-1) marks overflow
|
|
|
1292 ; (case 1)
|
|
|
1293 UMMOD4
|
|
|
1294 leas 2,s ; un (divisor thrown away)
|
|
|
1295 stx ,s ; quotient to TOS
|
|
|
1296 std 2,s ; remainder 2nd
|
|
|
1297
|
|
|
1298 pulu pc ; NEXT
|
|
|
1299
|
|
|
1300
|
|
|
1301 ; UM/MOD ( udl udh un -- ur uq )
|
|
|
1302 ; Unsigned divide of a double by a single. Return mod and quotient.
|
|
|
1303
|
|
|
1304 FDB UMMOD,L845
|
|
|
1305 L850 FCB 6,"UM/MOD"
|
|
|
1306 UMMOD
|
|
|
1307 jmp USLASH
|
|
|
1308 ;;;; slow HL ...
|
|
|
1309 jsr DOLST
|
|
|
1310 FDB DDUP,ULESS
|
|
|
1311 FDB QBRAN,UMM4
|
|
|
1312 FDB NEGAT,DOLIT,15,TOR
|
|
|
1313 UMM1 FDB TOR,DUPP,UPLUS
|
|
|
1314 FDB TOR,TOR,DUPP,UPLUS
|
|
|
1315 FDB RFROM,PLUS,DUPP
|
|
|
1316 FDB RFROM,RAT,SWAP,TOR
|
|
|
1317 FDB UPLUS,RFROM,ORR
|
|
|
1318 FDB QBRAN,UMM2
|
|
|
1319 FDB TOR,DROP,PLUS1,RFROM
|
|
|
1320 FDB BRAN,UMM3
|
|
|
1321 UMM2 FDB DROP
|
|
|
1322 UMM3 FDB RFROM
|
|
|
1323 FDB DONXT,UMM1
|
|
|
1324 FDB DROP,SWAP,EXIT
|
|
|
1325 UMM4 FDB DROP,DDROP
|
|
|
1326 FDB DOLIT,-1,DUPP,EXIT
|
|
|
1327
|
|
|
1328 ; M/MOD ( d n -- r q )
|
|
|
1329 ; Signed floored divide of double by single. Return mod and quotient.
|
|
|
1330
|
|
|
1331 FDB MSMOD,L850
|
|
|
1332 L860 FCB 5,"M/MOD"
|
|
|
1333 MSMOD
|
|
|
1334 jsr DOLST
|
|
|
1335 FDB DUPP,ZLESS,DUPP,TOR
|
|
|
1336 FDB QBRAN,MMOD1
|
|
|
1337 FDB NEGAT,TOR,DNEGA,RFROM
|
|
|
1338 MMOD1 FDB TOR,DUPP,ZLESS
|
|
|
1339 FDB QBRAN,MMOD2
|
|
|
1340 FDB RAT,PLUS
|
|
|
1341 MMOD2 FDB RFROM,UMMOD,RFROM
|
|
|
1342 FDB QBRAN,MMOD3
|
|
|
1343 FDB SWAP,NEGAT,SWAP
|
|
|
1344 MMOD3 FDB EXIT
|
|
|
1345
|
|
|
1346 ; /MOD ( n n -- r q )
|
|
|
1347 ; Signed divide. Return mod and quotient.
|
|
|
1348
|
|
|
1349 FDB SLMOD,L860
|
|
|
1350 L870 FCB 4,"/MOD"
|
|
|
1351 SLMOD jsr DOLST
|
|
|
1352 FDB OVER,ZLESS,SWAP,MSMOD,EXIT
|
|
|
1353
|
|
|
1354 ; MOD ( n n -- r )
|
|
|
1355 ; Signed divide. Return mod only.
|
|
|
1356
|
|
|
1357 FDB MODD,L870
|
|
|
1358 L880 FCB 3,"MOD"
|
|
|
1359 MODD jsr DOLST
|
|
|
1360 FDB SLMOD,DROP,EXIT
|
|
|
1361
|
|
|
1362 ; / ( n n -- q )
|
|
|
1363 ; Signed divide. Return quotient only.
|
|
|
1364
|
|
|
1365 FDB SLASH,L880
|
|
|
1366 L890 FCB 1,"/"
|
|
|
1367 SLASH
|
|
|
1368 jsr DOLST
|
|
|
1369 FDB SLMOD,SWAP,DROP,EXIT
|
|
|
1370
|
|
|
1371 ;; Multiply
|
|
|
1372
|
|
|
1373 ; UM* ( u u -- ud )
|
|
|
1374 ; Unsigned multiply. Return double product.
|
|
|
1375
|
|
|
1376 FDB UMSTA,L890
|
|
|
1377 L900 FCB 3,"UM*"
|
|
|
1378 UMSTA
|
|
|
1379 ldx #17 ; 16 adds and 17 shifts ...
|
|
|
1380 clra ; result high word
|
|
|
1381 clrb
|
|
|
1382 bra UUMSTA3
|
|
|
1383 UUMSTA1 bcc UUMSTA2
|
|
|
1384 addd ,s
|
|
|
1385 UUMSTA2 rora ; high, result high word
|
|
|
1386 rorb ; low, result high word
|
|
|
1387 UUMSTA3 ror 2,s ; shift multiplier high, result low word
|
|
|
1388 ror 3,s ; shift multiplier low, result low word
|
|
|
1389 leax -1,x
|
|
|
1390 bne UUMSTA1
|
|
|
1391 std ,s
|
|
|
1392 pulu pc
|
|
|
1393 ;;;; slow HL ...
|
|
|
1394 ;;;; jsr DOLST
|
|
|
1395 ;;;; FDB DOLIT,0,SWAP,DOLIT,15,TOR
|
|
|
1396 ;;;;UMST1: FDB DUPP,UPLUS,TOR,TOR
|
|
|
1397 ;;;; FDB DUPP,UPLUS,RFROM,PLUS,RFROM
|
|
|
1398 ;;;; FDB QBRAN,UMST2
|
|
|
1399 ;;;; FDB TOR,OVER,UPLUS,RFROM,PLUS
|
|
|
1400 ;;;;UMST2: FDB DONXT,UMST1
|
|
|
1401 ;;;; FDB ROT,DROP,EXIT
|
|
|
1402
|
|
|
1403 ; _UM* ( u u -- ud )
|
|
|
1404 ; Unsigned multiply. Return double product.
|
|
|
1405
|
|
|
1406 FDB UUMSTA,L900
|
|
|
1407 L900A FCB 4,"_UM*"
|
|
|
1408 UUMSTA
|
|
|
1409 jsr DOLST
|
|
|
1410 FDB DOLIT,0,SWAP,DOLIT,15,TOR
|
|
|
1411 UMST1 FDB DUPP,UPLUS,TOR,TOR
|
|
|
1412 FDB DUPP,UPLUS,RFROM,PLUS,RFROM
|
|
|
1413 FDB QBRAN,UMST2
|
|
|
1414 FDB TOR,OVER,UPLUS,RFROM,PLUS
|
|
|
1415 UMST2 FDB DONXT,UMST1
|
|
|
1416 FDB ROT,DROP,EXIT
|
|
|
1417
|
|
|
1418 ; * ( n n -- n )
|
|
|
1419 ; Signed multiply. Return single product.
|
|
|
1420 ; XXX Not really signed, -200 -200 * -> -25536
|
|
|
1421
|
|
|
1422 FDB STAR,L900A
|
|
|
1423 L910 FCB 1,"*"
|
|
|
1424 STAR
|
|
|
1425 jsr DOLST
|
|
|
1426 FDB MSTAR,DROP,EXIT
|
|
|
1427
|
|
|
1428 ; M* ( n n -- d )
|
|
|
1429 ; Signed multiply. Return double product.
|
|
|
1430
|
|
|
1431 FDB MSTAR,L910
|
|
|
1432 L920 FCB 2,"M*"
|
|
|
1433 MSTAR
|
|
|
1434 jsr DOLST
|
|
|
1435 FDB DDUP,XORR,ZLESS,TOR
|
|
|
1436 FDB ABSS,SWAP,ABSS,UMSTA
|
|
|
1437 FDB RFROM
|
|
|
1438 FDB QBRAN,MSTA1
|
|
|
1439 FDB DNEGA
|
|
|
1440 MSTA1 FDB EXIT
|
|
|
1441
|
|
|
1442 ; */MOD ( n1 n2 n3 -- r q )
|
|
|
1443 ; Multiply n1 and n2, then divide by n3. Return mod and quotient.
|
|
|
1444
|
|
|
1445 FDB SSMOD,L920
|
|
|
1446 L930 FCB 5,"*/MOD"
|
|
|
1447 SSMOD jsr DOLST
|
|
|
1448 FDB TOR,MSTAR,RFROM,MSMOD,EXIT
|
|
|
1449
|
|
|
1450 ; */ ( n1 n2 n3 -- q )
|
|
|
1451 ; Multiply n1 by n2, then divide by n3. Return quotient only.
|
|
|
1452
|
|
|
1453 FDB STASL,L930
|
|
|
1454 L940 FCB 2,"*/"
|
|
|
1455 STASL jsr DOLST
|
|
|
1456 FDB SSMOD,SWAP,DROP,EXIT
|
|
|
1457
|
|
|
1458 ;; Miscellaneous
|
|
|
1459
|
|
|
1460 ; CELL+ ( a -- a )
|
|
|
1461 ; Add cell size in byte to address.
|
|
|
1462
|
|
|
1463 FDB CELLP,L940
|
|
|
1464 L950 FCB 5,"CELL+"
|
|
|
1465 CELLP jsr DOLST
|
|
|
1466 FDB DOCLIT
|
|
|
1467 FCB CELLL
|
|
|
1468 FDB PLUS,EXIT
|
|
|
1469
|
|
|
1470 ; CELL- ( a -- a )
|
|
|
1471 ; Subtract cell size in byte from address.
|
|
|
1472
|
|
|
1473 FDB CELLM,L950
|
|
|
1474 L960 FCB 5,"CELL-"
|
|
|
1475 CELLM jsr DOLST
|
|
|
1476 FDB DOCLIT
|
|
|
1477 FCB 0-CELLL
|
|
|
1478 FDB PLUS,EXIT
|
|
|
1479
|
|
|
1480 ; CELLS ( n -- n )
|
|
|
1481 ; Multiply tos by cell size in bytes.
|
|
|
1482
|
|
|
1483 FDB CELLS,L960
|
|
|
1484 L970 FCB 5,"CELLS"
|
|
|
1485 CELLS jsr DOLST
|
|
|
1486 FDB DOCLIT
|
|
|
1487 FCB CELLL
|
|
|
1488 FDB STAR,EXIT
|
|
|
1489
|
|
|
1490 ; ALIGNED ( b -- a )
|
|
|
1491 ; Align address to the cell boundary.
|
|
|
1492
|
|
|
1493 FDB ALGND,L970
|
|
|
1494 L975 FCB 7,"ALIGNED"
|
|
|
1495 ALGND jsr DOLST
|
|
|
1496 FDB EXIT
|
|
|
1497
|
|
|
1498 ; BL ( -- 32 )
|
|
|
1499 ; Return 32, the blank character.
|
|
|
1500
|
|
|
1501 FDB BLANK,L975
|
|
|
1502 L980 FCB 2,"BL"
|
|
|
1503 BLANK
|
|
|
1504 jsr DOCONST
|
|
|
1505 FDB ' '
|
|
|
1506 ;;; jsr DOLST
|
|
|
1507 ;;; FDB DOLIT,' ',EXIT
|
|
|
1508
|
|
|
1509 ; >CHAR ( c -- c )
|
|
|
1510 ; Filter non-printing characters.
|
|
|
1511
|
|
|
1512 FDB TCHAR,L980
|
|
|
1513 L990 FCB 5,">CHAR"
|
|
|
1514 TCHAR jsr DOLST
|
|
|
1515 FDB DOLIT,$7F,ANDD,DUPP ;mask msb
|
|
|
1516 FDB DOCLIT
|
|
|
1517 FCB 127
|
|
|
1518 FDB BLANK,WITHI ;check for printable
|
|
|
1519 FDB QBRAN,TCHA1
|
|
|
1520 FDB DROP,DOLIT,'_' ;replace non-printables
|
|
|
1521 TCHA1 FDB EXIT
|
|
|
1522
|
|
|
1523 ; DEPTH ( -- n )
|
|
|
1524 ; Return the depth of the data stack.
|
|
|
1525
|
|
|
1526 FDB DEPTH,L990
|
|
|
1527 L1000 FCB 5,"DEPTH"
|
|
|
1528 DEPTH jsr DOLST
|
|
|
1529 FDB SPAT,SZERO,AT,SWAP,SUBB
|
|
|
1530 FDB DOCLIT
|
|
|
1531 FCB CELLL
|
|
|
1532 FDB SLASH,EXIT
|
|
|
1533
|
|
|
1534 ; PICK ( ... +n -- ... w )
|
|
|
1535 ; Copy the nth stack item to tos.
|
|
|
1536
|
|
|
1537 FDB PICK,L1000
|
|
|
1538 L1010 FCB 4,"PICK"
|
|
|
1539 PICK
|
|
|
1540 ldd ,s
|
|
|
1541 addd #1 ; correct index
|
|
|
1542 aslb ; CELLL* (ASSERT: CELLL=2!!!)
|
|
|
1543 rola
|
|
|
1544 ldx d,s ; pick value
|
|
|
1545 stx ,s ; replace TOP
|
|
|
1546 pulu pc
|
|
|
1547 ;;;; slow HL ...
|
|
|
1548 ;;;; jsr DOLST
|
|
|
1549 ;;;; FDB PLUS1,CELLS
|
|
|
1550 ;;;; FDB SPAT,PLUS,AT,EXIT
|
|
|
1551
|
|
|
1552
|
|
|
1553 ; ROLL ( ... +n -- ... w )
|
|
|
1554 ; Copy the nth stack item to tos.
|
|
|
1555
|
|
|
1556 FDB ROLL,L1010
|
|
|
1557 L1015 FCB 4,"ROLL"
|
|
|
1558 ROLL
|
|
|
1559 ;;;; XXX als Primitive!
|
|
|
1560 ;;;; slow HL ...
|
|
|
1561 jsr DOLST
|
|
|
1562 FDB DUPP,TWO
|
|
|
1563 FDB LESS,QBRAN,ROL1
|
|
|
1564 FDB DROP,BRAN,ROL2
|
|
|
1565 ROL1 FDB SWAP,TOR,ONE
|
|
|
1566 FDB SUBB
|
|
|
1567 FDB ROLL,RFROM,SWAP
|
|
|
1568 ROL2 FDB EXIT
|
|
|
1569
|
|
|
1570 ;; Memory access
|
|
|
1571
|
|
|
1572 ; +! ( n a -- )
|
|
|
1573 ; Add n to the contents at address a.
|
|
|
1574
|
|
|
1575 FDB PSTOR,L1015
|
|
|
1576 L1020 FCB 2,"+!"
|
|
|
1577 PSTOR
|
|
|
1578 puls x ; address
|
|
|
1579 puls d ; value
|
|
|
1580 addd ,x ; add to value from address
|
|
|
1581 std ,x ; store back
|
|
|
1582 pulu pc
|
|
|
1583
|
|
|
1584 ;;;; XXX als Primitive!
|
|
|
1585 ;;;; slow HL ...
|
|
|
1586 ;;;; jsr DOLST
|
|
|
1587 ;;;; FDB SWAP,OVER,AT,PLUS
|
|
|
1588 ;;;; FDB SWAP,STORE,EXIT
|
|
|
1589
|
|
|
1590 ; 2! ( d a -- )
|
|
|
1591 ; Store the double integer to address a.
|
|
|
1592
|
|
|
1593 FDB DSTOR,L1020
|
|
|
1594 L1030 FCB 2,"2!"
|
|
|
1595 DSTOR
|
|
|
1596 ;;;; XXX als Primitive!
|
|
|
1597 ;;;; slow HL ...
|
|
|
1598 jsr DOLST
|
|
|
1599 FDB SWAP,OVER,STORE
|
|
|
1600 FDB CELLP,STORE,EXIT
|
|
|
1601
|
|
|
1602 ; 2@ ( a -- d )
|
|
|
1603 ; Fetch double integer from address a.
|
|
|
1604
|
|
|
1605 FDB DAT,L1030
|
|
|
1606 L1040 FCB 2,"2@"
|
|
|
1607 DAT
|
|
|
1608 ;;;; XXX als Primitive!
|
|
|
1609 ;;;; slow HL ...
|
|
|
1610 jsr DOLST
|
|
|
1611 FDB DUPP,CELLP,AT
|
|
|
1612 FDB SWAP,AT,EXIT
|
|
|
1613
|
|
|
1614 ; COUNT ( b -- b +n )
|
|
|
1615 ; Return count byte of a string and add 1 to byte address.
|
|
|
1616
|
|
|
1617 FDB COUNT,L1040
|
|
|
1618 L1050 FCB 5,"COUNT"
|
|
|
1619 COUNT jsr DOLST
|
|
|
1620 FDB DUPP,PLUS1
|
|
|
1621 FDB SWAP,CAT,EXIT
|
|
|
1622
|
|
|
1623 ; HERE ( -- a )
|
|
|
1624 ; Return the top of the code dictionary.
|
|
|
1625
|
|
|
1626 FDB HERE,L1050
|
|
|
1627 L1060 FCB 4,"HERE"
|
|
|
1628 HERE jsr DOLST
|
|
|
1629 FDB CP,AT,EXIT
|
|
|
1630
|
|
|
1631 ; PAD ( -- a )
|
|
|
1632 ; Return the address of the text buffer above the code dictionary.
|
|
|
1633
|
|
|
1634 FDB PAD,L1060
|
|
|
1635 L1070 FCB 3,"PAD"
|
|
|
1636 PAD jsr DOLST
|
|
|
1637 FDB HERE,DOLIT,80,PLUS,EXIT
|
|
|
1638
|
|
|
1639 ; TIB ( -- a )
|
|
|
1640 ; Return the address of the terminal input buffer.
|
|
|
1641
|
|
|
1642 FDB TIB,L1070
|
|
|
1643 L1080 FCB 3,"TIB"
|
|
|
1644 TIB jsr DOLST
|
|
|
1645 FDB NTIB,CELLP,AT,EXIT
|
|
|
1646
|
|
|
1647 ; @EXECUTE ( a -- )
|
|
|
1648 ; Execute vector stored in address a.
|
|
|
1649
|
|
|
1650 FDB ATEXE,L1080
|
|
|
1651 L1090 FCB 8,"@EXECUTE"
|
|
|
1652 ATEXE jsr DOLST
|
|
|
1653 FDB AT,QDUP ;?address or zero
|
|
|
1654 FDB QBRAN,EXE1
|
|
|
1655 FDB EXECU ;execute if non-zero
|
|
|
1656 EXE1 FDB EXIT ;do nothing if zero
|
|
|
1657
|
|
|
1658 ; CMOVE ( b1 b2 u -- )
|
|
|
1659 ; Copy u bytes from b1 to b2.
|
|
|
1660
|
|
|
1661 FDB CMOVE,L1090
|
|
|
1662 L1100 FCB 5,"CMOVE"
|
|
|
1663 CMOVE
|
|
|
1664 jmp CMOVEW
|
|
|
1665 ldd ,s ;count
|
|
|
1666 beq CMOVE3 ;zero -> leave
|
|
|
1667 tstb ;count low
|
|
|
1668 beq CMOVE1
|
|
|
1669 inc ,s ;ajust high for to-0 decrementation
|
|
|
1670 CMOVE1
|
|
|
1671 ldx 2,s ;to addr
|
|
|
1672 stu 2,s ;save reg on stack
|
|
|
1673 ldu 4,s ;from addr
|
|
|
1674 CMOVE2 lda ,u+ ;from ->
|
|
|
1675 sta ,x+ ;to
|
|
|
1676 decb ;low count
|
|
|
1677 bne CMOVE2
|
|
|
1678 dec ,s ;high count
|
|
|
1679 bne CMOVE2
|
|
|
1680 ldu 2,s
|
|
|
1681 CMOVE3 leas 6,s ;drop 3 parameters from stack
|
|
|
1682 pulu pc
|
|
|
1683 ;;;;
|
|
|
1684 ;;;; alternative, wordwise copy ...
|
|
|
1685 CMOVEW ldd ,s ; count
|
|
|
1686 ldx 2,s ; destination
|
|
|
1687 sty ,s ; save RP
|
|
|
1688 stu 2,s ; save IP
|
|
|
1689 ldy 4,s ; source
|
|
|
1690 lsra ; divide by 2, count words
|
|
|
1691 rorb ;
|
|
|
1692 pshs cc
|
|
|
1693 beq CMOVEW1 ; byte decrement correction
|
|
|
1694 inca ; byte decrement high byte correction
|
|
|
1695 CMOVEW1 subd #0 ; word count zero (=65536)?
|
|
|
1696 beq CMOVEW3
|
|
|
1697 CMOVEW2 ldu ,y++ ; source
|
|
|
1698 stu ,x++ ; destination
|
|
|
1699 decb ; count low
|
|
|
1700 bne CMOVEW2
|
|
|
1701 deca ; count high (count to 0 corrected)
|
|
|
1702 bne CMOVEW2
|
|
|
1703 CMOVEW3 puls CC ; check if odd count?
|
|
|
1704 bcc CMOVEW4
|
|
|
1705 lda ,y
|
|
|
1706 sta ,x
|
|
|
1707 CMOVEW4 puls y,u ; y first
|
|
|
1708 leas 2,s ; drop 3rd parameter
|
|
|
1709 pulu pc ; next
|
|
|
1710 ;;;;
|
|
|
1711 ;;;; slow HL ...
|
|
|
1712 ;;;; jsr DOLST
|
|
|
1713 ;;;; FDB TOR
|
|
|
1714 ;;;; FDB BRAN,CMOV2
|
|
|
1715 ;;;;CMOV1: FDB TOR,DUPP,CAT
|
|
|
1716 ;;;; FDB RAT,CSTOR
|
|
|
1717 ;;;; FDB PLUS1
|
|
|
1718 ;;;; FDB RFROM,PLUS1
|
|
|
1719 ;;;;CMOV2: FDB DONXT,CMOV1
|
|
|
1720 ;;;; FDB DDROP,EXIT
|
|
|
1721 ;;;;
|
|
|
1722
|
|
|
1723 ; FILL ( b u c -- )
|
|
|
1724 ; Fill u bytes of character c to area beginning at b.
|
|
|
1725
|
|
|
1726 FDB FILL,L1100
|
|
|
1727 L1110 FCB 4,"FILL"
|
|
|
1728 FILL
|
|
|
1729 ldd 2,s ;count
|
|
|
1730 beq NFILL3 ;zero -> leave
|
|
|
1731 tstb ;count low
|
|
|
1732 beq NFILL1
|
|
|
1733 inc 2,s ;ajust high for to-0 decrementation
|
|
|
1734 NFILL1
|
|
|
1735 ldx 4,s ;to addr
|
|
|
1736 lda 1,s ;fill byte, low byte from TOS
|
|
|
1737 NFILL2
|
|
|
1738 sta ,x+ ;to
|
|
|
1739 decb ;low count
|
|
|
1740 bne NFILL2
|
|
|
1741 dec 2,s ;high count
|
|
|
1742 bne NFILL2
|
|
|
1743 NFILL3 leas 6,s ;drop 3 parameters from stack
|
|
|
1744 pulu pc
|
|
|
1745 ;;;; slow HL ...
|
|
|
1746 ;;;; jsr DOLST
|
|
|
1747 ;;;; FDB SWAP,TOR,SWAP
|
|
|
1748 ;;;; FDB BRAN,FILL2
|
|
|
1749 ;;;;FILL1: FDB DDUP,CSTOR,PLUS1
|
|
|
1750 ;;;;FILL2: FDB DONXT,FILL1
|
|
|
1751 ;;;; FDB DDROP,EXIT
|
|
|
1752
|
|
|
1753 ; -TRAILING ( b u -- b u )
|
|
|
1754 ; Adjust the count to eliminate trailing white space.
|
|
|
1755
|
|
|
1756 FDB DTRAI,L1110
|
|
|
1757 L1120 FCB 9,"-TRAILING"
|
|
|
1758 DTRAI jsr DOLST
|
|
|
1759 FDB TOR
|
|
|
1760 FDB BRAN,DTRA2
|
|
|
1761 DTRA1 FDB BLANK,OVER,RAT,PLUS,CAT,LESS
|
|
|
1762 FDB QBRAN,DTRA2
|
|
|
1763 FDB RFROM,PLUS1,EXIT
|
|
|
1764 DTRA2 FDB DONXT,DTRA1
|
|
|
1765 FDB ZERO,EXIT
|
|
|
1766
|
|
|
1767 ; PACK$ ( b u a -- a )
|
|
|
1768 ; Build a counted string with u characters from b. Null fill.
|
|
|
1769
|
|
|
1770 FDB PACKS,L1120
|
|
|
1771 L1130 FCB 5,"PACK$"
|
|
|
1772 PACKS jsr DOLST
|
|
|
1773 FDB DUPP,TOR ;strings only on cell boundary
|
|
|
1774 FDB DDUP,CSTOR
|
|
|
1775 FDB PLUS1 ;count mod cell
|
|
|
1776 FDB DDUP,PLUS
|
|
|
1777 FDB ZERO,SWAP,CSTOR ;null fill cell
|
|
|
1778 FDB SWAP,CMOVE,RFROM,EXIT ;move string
|
|
|
1779
|
|
|
1780 ;; Numeric output, single precision
|
|
|
1781
|
|
|
1782 ; DIGIT ( u -- c )
|
|
|
1783 ; Convert digit u to a character.
|
|
|
1784
|
|
|
1785 FDB DIGIT,L1130
|
|
|
1786 L1140 FCB 5,"DIGIT"
|
|
|
1787 DIGIT jsr DOLST
|
|
|
1788 FDB DOCLIT
|
|
|
1789 FCB 9
|
|
|
1790 FDB OVER,LESS
|
|
|
1791 FDB DOCLIT
|
|
|
1792 FCB 7
|
|
|
1793 FDB ANDD,PLUS
|
|
|
1794 FDB DOLIT,'0',PLUS,EXIT
|
|
|
1795
|
|
|
1796 ; EXTRACT ( n base -- n c )
|
|
|
1797 ; Extract the least significant digit from n.
|
|
|
1798
|
|
|
1799 FDB EXTRC,L1140
|
|
|
1800 L1150 FCB 7,"EXTRACT"
|
|
|
1801 EXTRC jsr DOLST
|
|
|
1802 FDB ZERO,SWAP,UMMOD
|
|
|
1803 FDB SWAP,DIGIT,EXIT
|
|
|
1804
|
|
|
1805 ; <# ( -- )
|
|
|
1806 ; Initiate the numeric output process.
|
|
|
1807
|
|
|
1808 FDB BDIGS,L1150
|
|
|
1809 L1160 FCB 2,"<#"
|
|
|
1810 BDIGS jsr DOLST
|
|
|
1811 FDB PAD,HLD,STORE,EXIT
|
|
|
1812
|
|
|
1813 ; HOLD ( c -- )
|
|
|
1814 ; Insert a character into the numeric output string.
|
|
|
1815
|
|
|
1816
|
|
|
1817 FDB HOLD,L1160
|
|
|
1818 L1170 FCB 4,"HOLD"
|
|
|
1819 HOLD jsr DOLST
|
|
|
1820 FDB HLD,AT,MINUS1
|
|
|
1821 FDB DUPP,HLD,STORE,CSTOR,EXIT
|
|
|
1822
|
|
|
1823 ; # ( u -- u )
|
|
|
1824 ; Extract one digit from u and append the digit to output string.
|
|
|
1825
|
|
|
1826 FDB DIG,L1170
|
|
|
1827 L1180 FCB 1,"#"
|
|
|
1828 DIG jsr DOLST
|
|
|
1829 FDB BASE,AT,EXTRC,HOLD,EXIT
|
|
|
1830
|
|
|
1831 ; #S ( u -- 0 )
|
|
|
1832 ; Convert u until all digits are added to the output string.
|
|
|
1833
|
|
|
1834 FDB DIGS,L1180
|
|
|
1835 L1190 FCB 2,"#S"
|
|
|
1836 DIGS jsr DOLST
|
|
|
1837 DIGS1 FDB DIG,DUPP
|
|
|
1838 FDB QBRAN,DIGS2
|
|
|
1839 FDB BRAN,DIGS1
|
|
|
1840 DIGS2 FDB EXIT
|
|
|
1841
|
|
|
1842 ; SIGN ( n -- )
|
|
|
1843 ; Add a minus sign to the numeric output string.
|
|
|
1844
|
|
|
1845 FDB SIGN,L1190
|
|
|
1846 L1200 FCB 4,"SIGN"
|
|
|
1847 SIGN jsr DOLST
|
|
|
1848 FDB ZLESS
|
|
|
1849 FDB QBRAN,SIGN1
|
|
|
1850 FDB DOLIT,'-',HOLD
|
|
|
1851 SIGN1 FDB EXIT
|
|
|
1852
|
|
|
1853 ; #> ( w -- b u )
|
|
|
1854 ; Prepare the output string to be TYPE'd.
|
|
|
1855
|
|
|
1856 FDB EDIGS,L1200
|
|
|
1857 L1210 FCB 2,"#>"
|
|
|
1858 EDIGS jsr DOLST
|
|
|
1859 FDB DROP,HLD,AT
|
|
|
1860 FDB PAD,OVER,SUBB,EXIT
|
|
|
1861
|
|
|
1862 ; str ( w -- b u )
|
|
|
1863 ; Convert a signed integer to a numeric string.
|
|
|
1864
|
|
|
1865 FDB STR,L1210
|
|
|
1866 L1220 FCB 3,"str"
|
|
|
1867 STR jsr DOLST
|
|
|
1868 FDB DUPP,TOR,ABSS
|
|
|
1869 FDB BDIGS,DIGS,RFROM
|
|
|
1870 FDB SIGN,EDIGS,EXIT
|
|
|
1871
|
|
|
1872 ; HEX ( -- )
|
|
|
1873 ; Use radix 16 as base for numeric conversions.
|
|
|
1874
|
|
|
1875 FDB HEX,L1220
|
|
|
1876 L1230 FCB 3,"HEX"
|
|
|
1877 HEX jsr DOLST
|
|
|
1878 FDB DOCLIT
|
|
|
1879 FCB 16
|
|
|
1880 FDB BASE,STORE,EXIT
|
|
|
1881
|
|
|
1882 ; DECIMAL ( -- )
|
|
|
1883 ; Use radix 10 as base for numeric conversions.
|
|
|
1884
|
|
|
1885 FDB DECIM,L1230
|
|
|
1886 L1240 FCB 7,"DECIMAL"
|
|
|
1887 DECIM jsr DOLST
|
|
|
1888 FDB DOCLIT
|
|
|
1889 FCB 10
|
|
|
1890 FDB BASE,STORE,EXIT
|
|
|
1891
|
|
|
1892 ;; Numeric input, single precision
|
|
|
1893
|
|
|
1894 ; DIGIT? ( c base -- u t )
|
|
|
1895 ; Convert a character to its numeric value. A flag indicates success.
|
|
|
1896
|
|
|
1897 FDB DIGTQ,L1240
|
|
|
1898 L1250 FCB 6,"DIGIT?"
|
|
|
1899 DIGTQ jsr DOLST
|
|
|
1900 FDB TOR,DOLIT,'0',SUBB
|
|
|
1901 FDB DOCLIT
|
|
|
1902 FCB 9
|
|
|
1903 FDB OVER,LESS
|
|
|
1904 FDB QBRAN,DGTQ1
|
|
|
1905 FDB DOCLIT
|
|
|
1906 FCB 7
|
|
|
1907 FDB SUBB
|
|
|
1908 FDB DUPP,DOLIT,10,LESS,ORR
|
|
|
1909 DGTQ1 FDB DUPP,RFROM,ULESS,EXIT
|
|
|
1910
|
|
|
1911 ; NUMBER? ( a -- n T | a F )
|
|
|
1912 ; Convert a number string to integer. Push a flag on tos.
|
|
|
1913
|
|
|
1914 FDB NUMBQ,L1250
|
|
|
1915 L1260 FCB 7,"NUMBER?"
|
|
|
1916 NUMBQ jsr DOLST
|
|
|
1917 FDB BASE,AT,TOR,ZERO,OVER,COUNT
|
|
|
1918 FDB OVER,CAT,DOLIT,'$',EQUAL
|
|
|
1919 FDB QBRAN,NUMQ1
|
|
|
1920 FDB HEX,SWAP,PLUS1
|
|
|
1921 FDB SWAP,MINUS1
|
|
|
1922 NUMQ1 FDB OVER,CAT,DOLIT,'-',EQUAL,TOR
|
|
|
1923 FDB SWAP,RAT,SUBB,SWAP,RAT,PLUS,QDUP
|
|
|
1924 FDB QBRAN,NUMQ6
|
|
|
1925 FDB MINUS1,TOR
|
|
|
1926 NUMQ2 FDB DUPP,TOR,CAT,BASE,AT,DIGTQ
|
|
|
1927 FDB QBRAN,NUMQ4
|
|
|
1928 FDB SWAP,BASE,AT,STAR,PLUS,RFROM
|
|
|
1929 FDB PLUS1
|
|
|
1930 FDB DONXT,NUMQ2
|
|
|
1931 FDB RAT,SWAP,DROP
|
|
|
1932 FDB QBRAN,NUMQ3
|
|
|
1933 FDB NEGAT
|
|
|
1934 NUMQ3 FDB SWAP
|
|
|
1935 FDB BRAN,NUMQ5
|
|
|
1936 NUMQ4 FDB RFROM,RFROM,DDROP,DDROP,ZERO
|
|
|
1937 NUMQ5 FDB DUPP
|
|
|
1938 NUMQ6 FDB RFROM,DDROP
|
|
|
1939 FDB RFROM,BASE,STORE,EXIT
|
|
|
1940
|
|
|
1941 ;; Basic I/O
|
|
|
1942
|
|
|
1943 ; ?KEY ( -- c T | F )
|
|
|
1944 ; Return input character and true, or a false if no input.
|
|
|
1945
|
|
|
1946
|
|
|
1947 FDB QKEY,L1260
|
|
|
1948 L1270 FCB 4,"?KEY"
|
|
|
1949 QKEY jsr DOLST
|
|
|
1950 FDB TQKEY,ATEXE,EXIT
|
|
|
1951
|
|
|
1952 ; KEY ( -- c )
|
|
|
1953 ; Wait for and return an input character.
|
|
|
1954
|
|
|
1955 FDB KEY,L1270
|
|
|
1956 L1280 FCB 3,"KEY"
|
|
|
1957 KEY jsr DOLST
|
|
|
1958 KEY1 FDB QKEY
|
|
|
1959 FDB QBRAN,KEY1
|
|
|
1960 FDB EXIT
|
|
|
1961
|
|
|
1962 ; EMIT ( c -- )
|
|
|
1963 ; Send a character to the output device.
|
|
|
1964
|
|
|
1965 FDB EMIT,L1280
|
|
|
1966 L1290 FCB 4,"EMIT"
|
|
|
1967 EMIT jsr DOLST
|
|
|
1968 FDB TEMIT,ATEXE,EXIT
|
|
|
1969
|
|
|
1970 ; NUF? ( -- t )
|
|
|
1971 ; Return false if no input, else pause and if CR return true.
|
|
|
1972
|
|
|
1973 FDB NUFQ,L1290
|
|
|
1974 L1300 FCB 4,"NUF?"
|
|
|
1975 NUFQ jsr DOLST
|
|
|
1976 FDB QKEY,DUPP
|
|
|
1977 FDB QBRAN,NUFQ1
|
|
|
1978 FDB DDROP,KEY,DOCLIT
|
|
|
1979 FCB CRR
|
|
|
1980 FDB EQUAL
|
|
|
1981 NUFQ1 FDB EXIT
|
|
|
1982
|
|
|
1983 ; PACE ( -- )
|
|
|
1984 ; Send a pace character for the file downloading process.
|
|
|
1985
|
|
|
1986 FDB PACE,L1300
|
|
|
1987 L1310 FCB 4,"PACE"
|
|
|
1988 PACE jsr DOLST
|
|
|
1989 FDB DOCLIT
|
|
|
1990 FCB 11
|
|
|
1991 FDB EMIT,EXIT
|
|
|
1992
|
|
|
1993 ; SPACE ( -- )
|
|
|
1994 ; Send the blank character to the output device.
|
|
|
1995
|
|
|
1996 FDB SPACE,L1310
|
|
|
1997 L1320 FCB 5,"SPACE"
|
|
|
1998 SPACE jsr DOLST
|
|
|
1999 FDB BLANK,EMIT,EXIT
|
|
|
2000
|
|
|
2001 ; SPACES ( +n -- )
|
|
|
2002 ; Send n spaces to the output device.
|
|
|
2003
|
|
|
2004 FDB SPACS,L1320
|
|
|
2005 L1330 FCB 6,"SPACES"
|
|
|
2006 SPACS jsr DOLST
|
|
|
2007 FDB ZERO,MAX,TOR
|
|
|
2008 FDB BRAN,CHAR2
|
|
|
2009 CHAR1 FDB SPACE
|
|
|
2010 CHAR2 FDB DONXT,CHAR1
|
|
|
2011 FDB EXIT
|
|
|
2012
|
|
|
2013 ; TYPE ( b u -- )
|
|
|
2014 ; Output u characters from b.
|
|
|
2015
|
|
|
2016 FDB TYPES,L1330
|
|
|
2017 L1340 FCB 4,"TYPE"
|
|
|
2018 TYPES jsr DOLST
|
|
|
2019 FDB TOR
|
|
|
2020 FDB BRAN,TYPE2
|
|
|
2021 TYPE1 FDB DUPP,CAT,EMIT
|
|
|
2022 FDB PLUS1
|
|
|
2023 TYPE2 FDB DONXT,TYPE1
|
|
|
2024 FDB DROP,EXIT
|
|
|
2025
|
|
|
2026 ; CR ( -- )
|
|
|
2027 ; Output a carriage return and a line feed.
|
|
|
2028
|
|
|
2029 FDB CR,L1340
|
|
|
2030 L1350 FCB 2,"CR"
|
|
|
2031 CR jsr DOLST
|
|
|
2032 FDB DOCLIT
|
|
|
2033 FCB CRR
|
|
|
2034 FDB EMIT
|
|
|
2035 FDB DOCLIT
|
|
|
2036 FCB LF
|
|
|
2037 FDB EMIT,EXIT
|
|
|
2038
|
|
|
2039 ; do$ ( -- a )
|
|
|
2040 ; Return the address of a compiled string.
|
|
|
2041
|
|
|
2042 FDB DOSTR,L1350
|
|
|
2043 L1360 FCB COMPO+3,"do$"
|
|
|
2044 DOSTR jsr DOLST
|
|
|
2045 FDB RFROM,RAT,RFROM,COUNT,PLUS
|
|
|
2046 FDB ALGND,TOR,SWAP,TOR,EXIT
|
|
|
2047
|
|
|
2048 ; $"| ( -- a )
|
|
|
2049 ; Run time routine compiled by $". Return address of a compiled string.
|
|
|
2050
|
|
|
2051 FDB STRQP,L1360
|
|
|
2052 L1370 FCB COMPO+3,'$','"','|'
|
|
|
2053 STRQP jsr DOLST
|
|
|
2054 FDB DOSTR,EXIT ;force a call to do$
|
|
|
2055
|
|
|
2056 ; ."| ( -- )
|
|
|
2057 ; Run time routine of ." . Output a compiled string.
|
|
|
2058
|
|
|
2059 FDB DOTQP,L1370
|
|
|
2060 L1380 FCB COMPO+3,'.','"','|'
|
|
|
2061 DOTQP jsr DOLST
|
|
|
2062 FDB DOSTR,COUNT,TYPES,EXIT
|
|
|
2063
|
|
|
2064 ; .R ( n +n -- )
|
|
|
2065 ; Display an integer in a field of n columns, right justified.
|
|
|
2066
|
|
|
2067 FDB DOTR,L1380
|
|
|
2068 L1390 FCB 2,".R"
|
|
|
2069 DOTR jsr DOLST
|
|
|
2070 FDB TOR,STR,RFROM,OVER,SUBB
|
|
|
2071 FDB SPACS,TYPES,EXIT
|
|
|
2072
|
|
|
2073 ; U.R ( u +n -- )
|
|
|
2074 ; Display an unsigned integer in n column, right justified.
|
|
|
2075
|
|
|
2076 FDB UDOTR,L1390
|
|
|
2077 L1400 FCB 3,"U.R"
|
|
|
2078 UDOTR jsr DOLST
|
|
|
2079 FDB TOR,BDIGS,DIGS,EDIGS
|
|
|
2080 FDB RFROM,OVER,SUBB
|
|
|
2081 FDB SPACS,TYPES,EXIT
|
|
|
2082
|
|
|
2083 ; U. ( u -- )
|
|
|
2084 ; Display an unsigned integer in free format.
|
|
|
2085
|
|
|
2086 FDB UDOT,L1400
|
|
|
2087 L1410 FCB 2,"U."
|
|
|
2088 UDOT jsr DOLST
|
|
|
2089 FDB BDIGS,DIGS,EDIGS
|
|
|
2090 FDB SPACE,TYPES,EXIT
|
|
|
2091
|
|
|
2092 ; . ( w -- )
|
|
|
2093 ; Display an integer in free format, preceeded by a space.
|
|
|
2094
|
|
|
2095 FDB DOT,L1410
|
|
|
2096 L1420 FCB 1,"."
|
|
|
2097 DOT jsr DOLST
|
|
|
2098 FDB BASE,AT,DOCLIT
|
|
|
2099 FCB 10
|
|
|
2100 FDB XORR ;?decimal
|
|
|
2101 FDB QBRAN,DOT1
|
|
|
2102 FDB UDOT,EXIT ;no, display unsigned
|
|
|
2103 DOT1 FDB STR,SPACE,TYPES,EXIT ;yes, display signed
|
|
|
2104
|
|
|
2105 ; ? ( a -- )
|
|
|
2106 ; Display the contents in a memory cell.
|
|
|
2107
|
|
|
2108 FDB QUEST,L1420
|
|
|
2109 L1430 FCB 1,"?"
|
|
|
2110 QUEST jsr DOLST
|
|
|
2111 FDB AT,DOT,EXIT
|
|
|
2112
|
|
|
2113 ;; Parsing
|
|
|
2114
|
|
|
2115 ; parse ( b u c -- b u delta ; <string> )
|
|
|
2116 ; Scan string delimited by c. Return found string and its offset.
|
|
|
2117
|
|
|
2118 FDB PARS,L1430
|
|
|
2119 L1440 FCB 5,"parse"
|
|
|
2120 PARS jsr DOLST
|
|
|
2121 FDB TEMP,STORE,OVER,TOR,DUPP
|
|
|
2122 FDB QBRAN,PARS8
|
|
|
2123 FDB MINUS1,TEMP,AT,BLANK,EQUAL
|
|
|
2124 FDB QBRAN,PARS3
|
|
|
2125 FDB TOR
|
|
|
2126 PARS1 FDB BLANK,OVER,CAT ;skip leading blanks ONLY
|
|
|
2127 FDB SUBB,ZLESS,INVER
|
|
|
2128 FDB QBRAN,PARS2
|
|
|
2129 FDB PLUS1
|
|
|
2130 FDB DONXT,PARS1
|
|
|
2131 FDB RFROM,DROP,ZERO,DUPP,EXIT
|
|
|
2132 PARS2 FDB RFROM
|
|
|
2133 PARS3 FDB OVER,SWAP
|
|
|
2134 FDB TOR
|
|
|
2135 PARS4 FDB TEMP,AT,OVER,CAT,SUBB ;scan for delimiter
|
|
|
2136 FDB TEMP,AT,BLANK,EQUAL
|
|
|
2137 FDB QBRAN,PARS5
|
|
|
2138 FDB ZLESS
|
|
|
2139 PARS5 FDB QBRAN,PARS6
|
|
|
2140 FDB PLUS1
|
|
|
2141 FDB DONXT,PARS4
|
|
|
2142 FDB DUPP,TOR
|
|
|
2143 FDB BRAN,PARS7
|
|
|
2144 PARS6 FDB RFROM,DROP,DUPP
|
|
|
2145 FDB PLUS1,TOR
|
|
|
2146 PARS7 FDB OVER,SUBB
|
|
|
2147 FDB RFROM,RFROM,SUBB,EXIT
|
|
|
2148 PARS8 FDB OVER,RFROM,SUBB,EXIT
|
|
|
2149
|
|
|
2150 ; PARSE ( c -- b u ; <string> )
|
|
|
2151 ; Scan input stream and return counted string delimited by c.
|
|
|
2152
|
|
|
2153 FDB PARSE,L1440
|
|
|
2154 L1450 FCB 5,"PARSE"
|
|
|
2155 PARSE jsr DOLST
|
|
|
2156 FDB TOR,TIB,INN,AT,PLUS ;current input buffer pointer
|
|
|
2157 FDB NTIB,AT,INN,AT,SUBB ;remaining count
|
|
|
2158 FDB RFROM,PARS,INN,PSTOR,EXIT
|
|
|
2159
|
|
|
2160 ; .( ( -- )
|
|
|
2161 ; Output following string up to next ) .
|
|
|
2162
|
|
|
2163 FDB DOTPR,L1450
|
|
|
2164 L1460 FCB IMEDD+2,".("
|
|
|
2165 DOTPR jsr DOLST
|
|
|
2166 FDB DOLIT,')',PARSE,TYPES,EXIT
|
|
|
2167
|
|
|
2168 ; ( ( -- )
|
|
|
2169 ; Ignore following string up to next ) . A comment.
|
|
|
2170
|
|
|
2171 FDB PAREN,L1460
|
|
|
2172 L1470 FCB IMEDD+1,"("
|
|
|
2173 PAREN jsr DOLST
|
|
|
2174 FDB DOLIT,')',PARSE,DDROP,EXIT
|
|
|
2175
|
|
|
2176 ; \ ( -- )
|
|
|
2177 ; Ignore following text till the end of line.
|
|
|
2178
|
|
|
2179 FDB BKSLA,L1470
|
|
|
2180 L1480 FCB IMEDD+1,92 ; '\' but give as numeric to avoid different escap char processing in different assemblers
|
|
|
2181 BKSLA jsr DOLST
|
|
|
2182 FDB NTIB,AT,INN,STORE,EXIT
|
|
|
2183
|
|
|
2184 ; CHAR ( -- c )
|
|
|
2185 ; Parse next word and return its first character.
|
|
|
2186
|
|
|
2187 FDB CHAR,L1480
|
|
|
2188 L1490 FCB 4,"CHAR"
|
|
|
2189 CHAR jsr DOLST
|
|
|
2190 FDB BLANK,PARSE,DROP,CAT,EXIT
|
|
|
2191
|
|
|
2192 ; TOKEN ( -- a ; <string> )
|
|
|
2193 ; Parse a word from input stream and copy it to name dictionary.
|
|
|
2194
|
|
|
2195 FDB TOKEN,L1490
|
|
|
2196 L1500 FCB 5,"TOKEN"
|
|
|
2197 TOKEN jsr DOLST
|
|
|
2198 FDB BLANK,PARSE,DOCLIT
|
|
|
2199 FCB 31
|
|
|
2200 FDB MIN
|
|
|
2201 FDB NP,AT,OVER,SUBB,CELLM
|
|
|
2202 FDB PACKS,EXIT
|
|
|
2203
|
|
|
2204 ; WORD ( c -- a ; <string> )
|
|
|
2205 ; Parse a word from input stream and copy it to code dictionary.
|
|
|
2206
|
|
|
2207 FDB WORD,L1500
|
|
|
2208 L1510 FCB 4,"WORD"
|
|
|
2209 WORD jsr DOLST
|
|
|
2210 FDB PARSE,HERE,PACKS,EXIT
|
|
|
2211
|
|
|
2212 ;; Dictionary search
|
|
|
2213
|
|
|
2214 ; NAME> ( na -- ca )
|
|
|
2215 ; Return a code address given a name address.
|
|
|
2216
|
|
|
2217 FDB NAMET,L1510
|
|
|
2218 L1520 FCB 5,"NAME>"
|
|
|
2219 NAMET jsr DOLST
|
|
|
2220 FDB CELLM,CELLM,AT,EXIT
|
|
|
2221
|
|
|
2222 ; SAME? ( a a u -- a a f \ -0+ )
|
|
|
2223 ; Compare u bytes in two strings. Return 0 if identical.
|
|
|
2224
|
|
|
2225 FDB SAMEQ,L1520
|
|
|
2226 L1530 FCB 5,"SAME?"
|
|
|
2227 SAMEQ jsr DOLST
|
|
|
2228 FDB TOR
|
|
|
2229 FDB BRAN,SAME2
|
|
|
2230 SAME1 FDB OVER,RAT,PLUS,CAT
|
|
|
2231 FDB OVER,RAT,PLUS,CAT
|
|
|
2232 FDB SUBB,QDUP
|
|
|
2233 FDB QBRAN,SAME2
|
|
|
2234 FDB RFROM,DROP,EXIT
|
|
|
2235 SAME2 FDB DONXT,SAME1
|
|
|
2236 FDB DOLIT,0,EXIT
|
|
|
2237
|
|
|
2238 ; find ( a va -- ca na | a F )
|
|
|
2239 ; Search a vocabulary for a string. Return ca and na if succeeded.
|
|
|
2240
|
|
|
2241 FDB FIND,L1530
|
|
|
2242 L1540 FCB 4,"find"
|
|
|
2243 FIND jsr DOLST
|
|
|
2244 FDB SWAP,DUPP,CAT,MINUS1
|
|
|
2245 FDB TEMP,STORE
|
|
|
2246 FDB DUPP,AT,TOR,CELLP,SWAP
|
|
|
2247 FIND1 FDB AT,DUPP
|
|
|
2248 FDB QBRAN,FIND6
|
|
|
2249 FDB DUPP,AT,DOLIT,MASKK,ANDD,RAT,XORR
|
|
|
2250 FDB QBRAN,FIND2
|
|
|
2251 FDB CELLP,MONE
|
|
|
2252 FDB BRAN,FIND3
|
|
|
2253 FIND2 FDB CELLP,TEMP,AT,SAMEQ
|
|
|
2254 FIND3 FDB BRAN,FIND4
|
|
|
2255 FIND6 FDB RFROM,DROP
|
|
|
2256 FDB SWAP,CELLM,SWAP,EXIT
|
|
|
2257 FIND4 FDB QBRAN,FIND5
|
|
|
2258 FDB CELLM,CELLM
|
|
|
2259 FDB BRAN,FIND1
|
|
|
2260 FIND5 FDB RFROM,DROP,SWAP,DROP
|
|
|
2261 FDB CELLM
|
|
|
2262 FDB DUPP,NAMET,SWAP,EXIT
|
|
|
2263
|
|
|
2264 ; NAME? ( a -- ca na | a F )
|
|
|
2265 ; Search all context vocabularies for a string.
|
|
|
2266
|
|
|
2267 FDB NAMEQ,L1540
|
|
|
2268 L1550 FCB 5,"NAME?"
|
|
|
2269 NAMEQ jsr DOLST
|
|
|
2270 FDB CNTXT,DUPP,DAT,XORR
|
|
|
2271 FDB QBRAN,NAMQ1
|
|
|
2272 FDB CELLM
|
|
|
2273 NAMQ1 FDB TOR
|
|
|
2274 NAMQ2 FDB RFROM,CELLP,DUPP,TOR
|
|
|
2275 FDB AT,QDUP
|
|
|
2276 FDB QBRAN,NAMQ3
|
|
|
2277 FDB FIND,QDUP
|
|
|
2278 FDB QBRAN,NAMQ2
|
|
|
2279 FDB RFROM,DROP,EXIT
|
|
|
2280 NAMQ3 FDB RFROM,DROP
|
|
|
2281 FDB ZERO,EXIT
|
|
|
2282
|
|
|
2283 ;; Terminal response
|
|
|
2284
|
|
|
2285 ; ^H ( bot eot cur -- bot eot cur )
|
|
|
2286 ; Backup the cursor by one character.
|
|
|
2287
|
|
|
2288 FDB BKSP,L1550
|
|
|
2289 L1560 FCB 2,"^H"
|
|
|
2290 BKSP jsr DOLST
|
|
|
2291 FDB TOR,OVER,RFROM,SWAP,OVER,XORR
|
|
|
2292 FDB QBRAN,BACK1
|
|
|
2293 FDB DOLIT,BKSPP,TECHO,ATEXE,MINUS1
|
|
|
2294 FDB BLANK,TECHO,ATEXE
|
|
|
2295 FDB DOLIT,BKSPP,TECHO,ATEXE
|
|
|
2296 BACK1 FDB EXIT
|
|
|
2297
|
|
|
2298 ; TAP ( bot eot cur c -- bot eot cur )
|
|
|
2299 ; Accept and echo the key stroke and bump the cursor.
|
|
|
2300
|
|
|
2301 FDB TAP,L1560
|
|
|
2302 L1570 FCB 3,"TAP"
|
|
|
2303 TAP jsr DOLST
|
|
|
2304 FDB DUPP,TECHO,ATEXE
|
|
|
2305 FDB OVER,CSTOR,PLUS1,EXIT
|
|
|
2306
|
|
|
2307 ; kTAP ( bot eot cur c -- bot eot cur )
|
|
|
2308 ; Process a key stroke, CR or backspace.
|
|
|
2309
|
|
|
2310 FDB KTAP,L1570
|
|
|
2311 L1580 FCB 4,"kTAP"
|
|
|
2312 KTAP jsr DOLST
|
|
|
2313 FDB DUPP,DOCLIT
|
|
|
2314 FCB CRR
|
|
|
2315 FDB XORR
|
|
|
2316 FDB QBRAN,KTAP2
|
|
|
2317 FDB DUPP,DOLIT,BKSPP,XORR
|
|
|
2318 FDB SWAP,DOLIT,BKSPP2,XORR,ANDD
|
|
|
2319 FDB QBRAN,KTAP1
|
|
|
2320 FDB BLANK,TAP,EXIT
|
|
|
2321 KTAP1 FDB BKSP,EXIT
|
|
|
2322 KTAP2 FDB DROP,SWAP,DROP,DUPP,EXIT
|
|
|
2323
|
|
|
2324 ; accept ( b u -- b u )
|
|
|
2325 ; Accept characters to input buffer. Return with actual count.
|
|
|
2326
|
|
|
2327 FDB ACCEP,L1580
|
|
|
2328 L1590 FCB 6,"ACCEPT"
|
|
|
2329 ACCEP jsr DOLST
|
|
|
2330 FDB OVER,PLUS,OVER
|
|
|
2331 ACCP1 FDB DDUP,XORR
|
|
|
2332 FDB QBRAN,ACCP4
|
|
|
2333 FDB KEY,DUPP
|
|
|
2334 ; FDB BLANK,SUBB,DOLIT,95,ULESS
|
|
|
2335 FDB BLANK,DOLIT,127,WITHI
|
|
|
2336 FDB QBRAN,ACCP2
|
|
|
2337 FDB TAP
|
|
|
2338 FDB BRAN,ACCP3
|
|
|
2339 ACCP2 FDB TTAP,ATEXE
|
|
|
2340 ACCP3 FDB BRAN,ACCP1
|
|
|
2341 ACCP4 FDB DROP,OVER,SUBB,EXIT
|
|
|
2342
|
|
|
2343 ; EXPECT ( b u -- )
|
|
|
2344 ; Accept input stream and store count in SPAN.
|
|
|
2345
|
|
|
2346 FDB EXPEC,L1590
|
|
|
2347 L1600 FCB 6,"EXPECT"
|
|
|
2348 EXPEC jsr DOLST
|
|
|
2349 FDB TEXPE,ATEXE,SPAN,STORE,DROP,EXIT
|
|
|
2350
|
|
|
2351 ; QUERY ( -- )
|
|
|
2352 ; Accept input stream to terminal input buffer.
|
|
|
2353
|
|
|
2354 FDB QUERY,L1600
|
|
|
2355 L1610 FCB 5,"QUERY"
|
|
|
2356 QUERY jsr DOLST
|
|
|
2357 FDB TIB,DOCLIT
|
|
|
2358 FCB 80
|
|
|
2359 FDB TEXPE,ATEXE,NTIB,STORE
|
|
|
2360 FDB DROP,ZERO,INN,STORE,EXIT
|
|
|
2361
|
|
|
2362 ;; Error handling
|
|
|
2363
|
|
|
2364 ; CATCH ( ca -- 0 | err# )
|
|
|
2365 ; Execute word at ca and set up an error frame for it.
|
|
|
2366
|
|
|
2367 FDB CATCH,L1610
|
|
|
2368 L1620 FCB 5,"CATCH"
|
|
|
2369 CATCH jsr DOLST
|
|
|
2370 FDB SPAT,TOR,HANDL,AT,TOR ;save error frame
|
|
|
2371 FDB RPAT,HANDL,STORE,EXECU ;execute
|
|
|
2372 FDB RFROM,HANDL,STORE ;restore error frame
|
|
|
2373 FDB RFROM,DROP,ZERO,EXIT ;no error
|
|
|
2374
|
|
|
2375 ; THROW ( err# -- err# )
|
|
|
2376 ; Reset system to current local error frame an update error flag.
|
|
|
2377
|
|
|
2378 FDB THROW,L1620
|
|
|
2379 L1630 FCB 5,"THROW"
|
|
|
2380 THROW jsr DOLST
|
|
|
2381 FDB HANDL,AT,RPSTO ;restore return stack
|
|
|
2382 FDB RFROM,HANDL,STORE ;restore handler frame
|
|
|
2383 FDB RFROM,SWAP,TOR,SPSTO ;restore data stack
|
|
|
2384 FDB DROP,RFROM,EXIT
|
|
|
2385
|
|
|
2386 ; NULL$ ( -- a )
|
|
|
2387 ; Return address of a null string with zero count.
|
|
|
2388
|
|
|
2389 FDB NULLS,L1630
|
|
|
2390 L1640 FCB 5,"NULL$"
|
|
|
2391 NULLS
|
|
|
2392 ;;;; jsr DOLST
|
|
|
2393 ;;;; FDB DOVAR ;emulate CREATE
|
|
|
2394 jsr FDOVAR
|
|
|
2395 FDB 0
|
|
|
2396 FCB 99,111,121,111,116,101
|
|
|
2397
|
|
|
2398 ; ABORT ( -- )
|
|
|
2399 ; Reset data stack and jump to QUIT.
|
|
|
2400
|
|
|
2401 FDB ABORT,L1640
|
|
|
2402 L1650 FCB 5,"ABORT"
|
|
|
2403 ABORT jsr DOLST
|
|
|
2404 FDB NULLS,THROW
|
|
|
2405
|
|
|
2406 ; abort" ( f -- )
|
|
|
2407 ; Run time routine of ABORT" . Abort with a message.
|
|
|
2408
|
|
|
2409 FDB ABORQ,L1650
|
|
|
2410 L1660 FCB COMPO+6,"abort",'"'
|
|
|
2411 ABORQ jsr DOLST
|
|
|
2412 FDB QBRAN,ABOR1 ;text flag
|
|
|
2413 FDB DOSTR,THROW ;pass error string
|
|
|
2414 ABOR1 FDB DOSTR,DROP,EXIT ;drop error
|
|
|
2415
|
|
|
2416 ;; The text interpreter
|
|
|
2417
|
|
|
2418 ; $INTERPRET ( a -- )
|
|
|
2419 ; Interpret a word. If failed, try to convert it to an integer.
|
|
|
2420
|
|
|
2421 FDB INTER,L1660
|
|
|
2422 L1670 FCB 10,"$INTERPRET"
|
|
|
2423 INTER jsr DOLST
|
|
|
2424 FDB NAMEQ,QDUP ;?defined
|
|
|
2425 FDB QBRAN,INTE1
|
|
|
2426 FDB AT,DOLIT,COMPO<<8,ANDD ;?compile only lexicon bits
|
|
|
2427 FDB ABORQ
|
|
|
2428 FCB 13," compile only"
|
|
|
2429 FDB EXECU,EXIT ;execute defined word
|
|
|
2430 INTE1 FDB TNUMB,ATEXE ;convert a number
|
|
|
2431 FDB QBRAN,INTE2
|
|
|
2432 FDB EXIT
|
|
|
2433 INTE2 FDB THROW ;error
|
|
|
2434
|
|
|
2435 ; [ ( -- )
|
|
|
2436 ; Start the text interpreter.
|
|
|
2437
|
|
|
2438 FDB LBRAC,L1670
|
|
|
2439 L1680 FCB IMEDD+1,"["
|
|
|
2440 LBRAC jsr DOLST
|
|
|
2441 FDB DOLIT,INTER,TEVAL,STORE,EXIT
|
|
|
2442
|
|
|
2443 ; .OK ( -- )
|
|
|
2444 ; Display 'ok' only while interpreting.
|
|
|
2445
|
|
|
2446 FDB DOTOK,L1680
|
|
|
2447 L1690 FCB 3,".OK"
|
|
|
2448 DOTOK jsr DOLST
|
|
|
2449 FDB DOLIT,INTER,TEVAL,AT,EQUAL
|
|
|
2450 FDB QBRAN,DOTO1
|
|
|
2451 FDB DOTQP
|
|
|
2452 FCB 3," ok"
|
|
|
2453 DOTO1 FDB CR,EXIT
|
|
|
2454
|
|
|
2455 ; ?STACK ( -- )
|
|
|
2456 ; Abort if the data stack underflows.
|
|
|
2457
|
|
|
2458 FDB QSTAC,L1690
|
|
|
2459 L1700 FCB 6,"?STACK"
|
|
|
2460 QSTAC jsr DOLST
|
|
|
2461 FDB DEPTH,ZLESS ;check only for underflow
|
|
|
2462 FDB ABORQ
|
|
|
2463 FCB 10," underflow"
|
|
|
2464 FDB EXIT
|
|
|
2465
|
|
|
2466 ; EVAL ( -- )
|
|
|
2467 ; Interpret the input stream.
|
|
|
2468
|
|
|
2469 FDB EVAL,L1700
|
|
|
2470 L1710 FCB 4,"EVAL"
|
|
|
2471 EVAL jsr DOLST
|
|
|
2472 EVAL1 FDB TOKEN,DUPP,CAT ;?input stream empty
|
|
|
2473 FDB QBRAN,EVAL2
|
|
|
2474 FDB TEVAL,ATEXE,QSTAC ;evaluate input, check stack
|
|
|
2475 FDB BRAN,EVAL1
|
|
|
2476 EVAL2 FDB DROP,TPROM,ATEXE,EXIT ;prompt
|
|
|
2477
|
|
|
2478 ;; Shell
|
|
|
2479
|
|
|
2480 ; PRESET ( -- )
|
|
|
2481 ; Reset data stack pointer and the terminal input buffer.
|
|
|
2482
|
|
|
2483 FDB PRESE,L1710
|
|
|
2484 L1720 FCB 6,"PRESET"
|
|
|
2485 PRESE jsr DOLST
|
|
|
2486 FDB SZERO,AT,SPSTO
|
|
|
2487 FDB DOLIT,TIBB,NTIB,CELLP,STORE,EXIT
|
|
|
2488
|
|
|
2489 ; xio ( a a a -- )
|
|
|
2490 ; Reset the I/O vectors 'EXPECT, 'TAP, 'ECHO and 'PROMPT.
|
|
|
2491
|
|
|
2492 FDB XIO,L1720
|
|
|
2493 L1730 FCB COMPO+3,"xio"
|
|
|
2494 XIO jsr DOLST
|
|
|
2495 FDB DOLIT,ACCEP,TEXPE,DSTOR
|
|
|
2496 FDB TECHO,DSTOR,EXIT
|
|
|
2497
|
|
|
2498 ; FILE ( -- )
|
|
|
2499 ; Select I/O vectors for file download.
|
|
|
2500
|
|
|
2501 FDB FILE,L1730
|
|
|
2502 L1740 FCB 4,"FILE"
|
|
|
2503 FILE jsr DOLST
|
|
|
2504 FDB DOLIT,PACE,DOLIT,DROP
|
|
|
2505 FDB DOLIT,KTAP,XIO,EXIT
|
|
|
2506
|
|
|
2507 ; HAND ( -- )
|
|
|
2508 ; Select I/O vectors for terminal interface.
|
|
|
2509
|
|
|
2510 FDB HAND,L1740
|
|
|
2511 L1750 FCB 4,"HAND"
|
|
|
2512 HAND jsr DOLST
|
|
|
2513 FDB DOLIT,DOTOK,DOLIT,EMIT
|
|
|
2514 FDB DOLIT,KTAP,XIO,EXIT
|
|
|
2515
|
|
|
2516 ; I/O ( -- a )
|
|
|
2517 ; Array to store default I/O vectors.
|
|
|
2518
|
|
|
2519 FDB ISLO,L1750
|
|
|
2520 L1760 FCB 3,"I/O"
|
|
|
2521 ISLO
|
|
|
2522 ;; jsr DOLST
|
|
|
2523 ;; FDB DOVAR ;emulate CREATE
|
|
|
2524 jsr FDOVAR
|
|
|
2525 FDB QRX,TXSTO ;default I/O vectors
|
|
|
2526
|
|
|
2527 ; CONSOLE ( -- )
|
|
|
2528 ; Initiate terminal interface.
|
|
|
2529
|
|
|
2530 FDB CONSO,L1760
|
|
|
2531 L1770 FCB 7,"CONSOLE"
|
|
|
2532 CONSO jsr DOLST
|
|
|
2533 FDB ISLO,DAT,TQKEY,DSTOR ;restore default I/O device
|
|
|
2534 FDB HAND,EXIT ;keyboard input
|
|
|
2535
|
|
|
2536 ; QUIT ( -- )
|
|
|
2537 ; Reset return stack pointer and start text interpreter.
|
|
|
2538
|
|
|
2539 FDB QUIT,L1770
|
|
|
2540 L1780 FCB 4,"QUIT"
|
|
|
2541 QUIT jsr DOLST
|
|
|
2542 FDB RZERO,AT,RPSTO ;reset return stack pointer
|
|
|
2543 QUIT1 FDB LBRAC ;start interpretation
|
|
|
2544 QUIT2 FDB QUERY ;get input
|
|
|
2545 FDB DOLIT,EVAL,CATCH,QDUP ;evaluate input
|
|
|
2546 FDB QBRAN,QUIT2 ;continue till error
|
|
|
2547 FDB TPROM,AT,TOR ;save input device
|
|
|
2548 FDB CONSO,NULLS,OVER,XORR ;?display error message
|
|
|
2549 FDB QBRAN,QUIT3
|
|
|
2550 FDB SPACE,COUNT,TYPES ;error message
|
|
|
2551 FDB DOTQP
|
|
|
2552 FCB 3," ? " ;error prompt
|
|
|
2553 QUIT3 FDB RFROM,DOLIT,DOTOK,XORR ;?file input
|
|
|
2554 FDB QBRAN,QUIT4
|
|
|
2555 FDB DOLIT,ERR,EMIT ;file error, tell host
|
|
|
2556 QUIT4 FDB PRESE ;some cleanup
|
|
|
2557 FDB BRAN,QUIT1
|
|
|
2558
|
|
|
2559 ;; The compiler
|
|
|
2560
|
|
|
2561 ; ' ( -- ca )
|
|
|
2562 ; Search context vocabularies for the next word in input stream.
|
|
|
2563
|
|
|
2564 FDB TICK,L1780
|
|
|
2565 L1790 FCB 1,"'"
|
|
|
2566 TICK jsr DOLST
|
|
|
2567 FDB TOKEN,NAMEQ ;?defined
|
|
|
2568 FDB QBRAN,TICK1
|
|
|
2569 FDB EXIT ;yes, push code address
|
|
|
2570 TICK1 FDB THROW ;no, error
|
|
|
2571
|
|
|
2572 ; ALLOT ( n -- )
|
|
|
2573 ; Allocate n bytes to the code dictionary.
|
|
|
2574
|
|
|
2575 FDB ALLOT,L1790
|
|
|
2576 L1800 FCB 5,"ALLOT"
|
|
|
2577 ALLOT jsr DOLST
|
|
|
2578 FDB CP,PSTOR,EXIT ;adjust code pointer
|
|
|
2579
|
|
|
2580 ; , ( w -- )
|
|
|
2581 ; Compile an integer into the code dictionary.
|
|
|
2582
|
|
|
2583 FDB COMMA,L1800
|
|
|
2584 L1810 FCB 1,","
|
|
|
2585 COMMA jsr DOLST
|
|
|
2586 FDB HERE,DUPP,CELLP ;cell boundary
|
|
|
2587 FDB CP,STORE,STORE,EXIT ;adjust code pointer and compile
|
|
|
2588
|
|
|
2589 ; [COMPILE] ( -- ; <string> )
|
|
|
2590 ; Compile the next immediate word into code dictionary.
|
|
|
2591
|
|
|
2592 FDB BCOMP,L1810
|
|
|
2593 L1820 FCB IMEDD+9,"[COMPILE]"
|
|
|
2594 BCOMP jsr DOLST
|
|
|
2595 FDB TICK,COMMA,EXIT
|
|
|
2596
|
|
|
2597 ; COMPILE ( -- )
|
|
|
2598 ; Compile the next address in colon list to code dictionary.
|
|
|
2599
|
|
|
2600 FDB COMPI,L1820
|
|
|
2601 L1830 FCB COMPO+7,"COMPILE"
|
|
|
2602 COMPI jsr DOLST
|
|
|
2603 FDB RFROM,DUPP,AT,COMMA ;compile address
|
|
|
2604 FDB CELLP,TOR,EXIT ;adjust return address
|
|
|
2605
|
|
|
2606 ; LITERAL ( w -- )
|
|
|
2607 ; Compile tos to code dictionary as an integer literal.
|
|
|
2608
|
|
|
2609 FDB LITER,L1830
|
|
|
2610 L1840 FCB IMEDD+7,"LITERAL"
|
|
|
2611 LITER jsr DOLST
|
|
|
2612 FDB COMPI,DOLIT,COMMA,EXIT
|
|
|
2613
|
|
|
2614 ; $," ( -- )
|
|
|
2615 ; Compile a literal string up to next " .
|
|
|
2616
|
|
|
2617 FDB STRCQ,L1840
|
|
|
2618 L1850 FCB 3,"$,",'"'
|
|
|
2619 STRCQ jsr DOLST
|
|
|
2620 FDB DOLIT,'"',WORD ;move string to code dictionary
|
|
|
2621 FDB COUNT,PLUS,ALGND ;calculate aligned end of string
|
|
|
2622 FDB CP,STORE,EXIT ;adjust the code pointer
|
|
|
2623
|
|
|
2624 ; RECURSE ( -- )
|
|
|
2625 ; Make the current word available for compilation.
|
|
|
2626
|
|
|
2627 FDB RECUR,L1850
|
|
|
2628 L1860 FCB IMEDD+7,"RECURSE"
|
|
|
2629 RECUR jsr DOLST
|
|
|
2630 FDB LAST,AT,NAMET,COMMA,EXIT
|
|
|
2631
|
|
|
2632 ;; Structures
|
|
|
2633
|
|
|
2634 ; DO ( -- a m )
|
|
|
2635 ; Start a DO-LOOP/+LOOP structure in a colon definition.
|
|
|
2636
|
|
|
2637 FDB DO,L1860
|
|
|
2638 L1861 FCB IMEDD+2,"DO"
|
|
|
2639 DO jsr DOLST
|
|
|
2640 FDB COMPI,DODO,HERE
|
|
|
2641 FDB ONE ; marker for DO
|
|
|
2642 FDB EXIT
|
|
|
2643
|
|
|
2644 ; ?DO ( -- a m )
|
|
|
2645 ; Start a ?DO-LOOP/+LOOP structure in a colon definition.
|
|
|
2646
|
|
|
2647 FDB QDO,L1861
|
|
|
2648 L1862 FCB IMEDD+3,"?DO"
|
|
|
2649 QDO jsr DOLST
|
|
|
2650 FDB COMPI,DOQDO,HERE
|
|
|
2651 FDB COMPI,0 ; branch destination placeholder
|
|
|
2652 FDB TWO ; marker for ?DO
|
|
|
2653 FDB EXIT
|
|
|
2654
|
|
|
2655 ; (?DO) ( w w -- )
|
|
|
2656 ; Runtime part of DO in a DO-LOOP/+LOOP structure.
|
|
|
2657
|
|
|
2658 FDB DOQDO,L1862
|
|
|
2659 L1862A FCB 5,"(?DO)"
|
|
|
2660 DOQDO
|
|
|
2661 puls d ;start
|
|
|
2662 cmpd ,s ;start < end -> ok
|
|
|
2663 blt DOQDO1
|
|
|
2664 leas 2,s ;drop end
|
|
|
2665 ldu ,u
|
|
|
2666 pulu pc ;branch past loop
|
|
|
2667 DOQDO1
|
|
|
2668 puls x ;end
|
|
|
2669 stx ,--y ;end to return stack
|
|
|
2670 std ,--y ;start to return stack
|
|
|
2671 leau 2,u ;skip jump forward
|
|
|
2672 pulu pc
|
|
|
2673
|
|
|
2674 ; -DO ( -- a m )
|
|
|
2675 ; Start a -DO-LOOP/+LOOP structure in a colon definition.
|
|
|
2676
|
|
|
2677 FDB MDO,L1862A
|
|
|
2678 L1862B FCB IMEDD+3,"-DO"
|
|
|
2679 MDO jsr DOLST
|
|
|
2680 FDB COMPI,DOMDO,HERE
|
|
|
2681 FDB COMPI,0 ; branch destination placeholder
|
|
|
2682 FDB TWO ; marker for ?DO/-DO
|
|
|
2683 FDB EXIT
|
|
|
2684
|
|
|
2685 ; (-DO) ( w w -- )
|
|
|
2686 ; Runtime part of -DO in a -DO-LOOP/+LOOP structure.
|
|
|
2687
|
|
|
2688 FDB DOMDO,L1862B
|
|
|
2689 L1862C FCB 5,"(-DO)"
|
|
|
2690 DOMDO
|
|
|
2691 puls d ;start
|
|
|
2692 cmpd ,s ;start > end -> ok
|
|
|
2693 bgt DOMDO1
|
|
|
2694 leas 2,s ;drop end
|
|
|
2695 ldu ,u
|
|
|
2696 pulu pc ;branch past loop
|
|
|
2697 DOMDO1
|
|
|
2698 puls x ;end
|
|
|
2699 stx ,--y ;end to return stack
|
|
|
2700 std ,--y ;start to return stack
|
|
|
2701 leau 2,u ;skip jump forward
|
|
|
2702 pulu pc
|
|
|
2703
|
|
|
2704 ; (DO) ( w w -- )
|
|
|
2705 ; Runtime part of DO in a DO-LOOP/+LOOP structure.
|
|
|
2706
|
|
|
2707 FDB DODO,L1862C
|
|
|
2708 L1863 FCB 4,"(DO)"
|
|
|
2709 DODO
|
|
|
2710 puls d,x ;start first, end second
|
|
|
2711 stx ,--y ;end to return stack
|
|
|
2712 std ,--y ;start to return stack
|
|
|
2713 pulu pc
|
|
|
2714
|
|
|
2715 ; (LOOP) ( -- )
|
|
|
2716 ; Runtime part of LOOP
|
|
|
2717
|
|
|
2718 FDB DOLOOP,L1863
|
|
|
2719 L1864 FCB 6,"(LOOP)"
|
|
|
2720 DOLOOP
|
|
|
2721 ldd #1
|
|
|
2722 bra DOPLOF
|
|
|
2723
|
|
|
2724 ; (+LOOP) ( -- )
|
|
|
2725 ; Runtime part of +LOOP
|
|
|
2726
|
|
|
2727 FDB DOPLOOP,L1864
|
|
|
2728 L1865 FCB IMEDD+7,"(+LOOP)"
|
|
|
2729 DOPLOOP
|
|
|
2730 ldd ,s++ ; increment
|
|
|
2731 bpl DOPLOF ; forward
|
|
|
2732 addd ,y ; start/index
|
|
|
2733 cmpd 2,y ; end
|
|
|
2734 ble DOPLO1 ; index <= end -> leave
|
|
|
2735 std ,y
|
|
|
2736 ldu ,u ; branch to begin of loop
|
|
|
2737 pulu pc
|
|
|
2738
|
|
|
2739 DOPLOF addd ,y ; start/index
|
|
|
2740 cmpd 2,y ; end
|
|
|
2741 bge DOPLO1 ; index >= end -> leave
|
|
|
2742 std ,y ; save back
|
|
|
2743 ldu ,u ; branch to begin of loop
|
|
|
2744 pulu pc
|
|
|
2745 DOPLO1
|
|
|
2746 leau 2,u ; skip back destination
|
|
|
2747 leay 4,y ; remove index and upper from r stack
|
|
|
2748 pulu pc
|
|
|
2749
|
|
|
2750 ; LOOP ( a m -- )
|
|
|
2751 ; Terminate a DO/?DO-LOOP loop structure.
|
|
|
2752
|
|
|
2753 FDB LOOP,L1865
|
|
|
2754 L1866 FCB IMEDD+4,"LOOP"
|
|
|
2755 LOOP jsr DOLST
|
|
|
2756 FDB COMPI,DOLOOP
|
|
|
2757 FDB TWO,EQUAL,QBRAN,LOOP1
|
|
|
2758 FDB HERE,CELLP,OVER,STORE,CELLP ; branch forward destination
|
|
|
2759 LOOP1 FDB COMMA,EXIT
|
|
|
2760
|
|
|
2761
|
|
|
2762 ; +LOOP ( a m -- )
|
|
|
2763 ; Terminate a DO/?DO-+LOOP loop structure.
|
|
|
2764
|
|
|
2765 FDB PLOOP,L1866
|
|
|
2766 L1867 FCB IMEDD+5,"+LOOP"
|
|
|
2767 PLOOP jsr DOLST
|
|
|
2768 FDB COMPI,DOPLOOP
|
|
|
2769 FDB TWO,EQUAL,QBRAN,PLOOP1
|
|
|
2770 FDB HERE,CELLP,OVER,STORE,CELLP ; branch forward destination
|
|
|
2771 PLOOP1 FDB COMMA,EXIT
|
|
|
2772
|
|
|
2773 ; LEAVE ( -- )
|
|
|
2774 ; Leave DO/LOOP
|
|
|
2775
|
|
|
2776 FDB LEAVE,L1867
|
|
|
2777 L1868 FCB 5,"LEAVE"
|
|
|
2778 LEAVE
|
|
|
2779 ldd ,y ;take index on return stack
|
|
|
2780 std 2,y ;and change end to it
|
|
|
2781 pulu pc
|
|
|
2782
|
|
|
2783 ; FOR ( -- a )
|
|
|
2784 ; Start a FOR-NEXT loop structure in a colon definition.
|
|
|
2785
|
|
|
2786 FDB FOR,L1867
|
|
|
2787 L1870 FCB IMEDD+3,"FOR"
|
|
|
2788 FOR jsr DOLST
|
|
|
2789 FDB COMPI,TOR,HERE,EXIT
|
|
|
2790
|
|
|
2791 ; BEGIN ( -- a )
|
|
|
2792 ; Start an infinite or indefinite loop structure.
|
|
|
2793
|
|
|
2794 FDB BEGIN,L1870
|
|
|
2795 L1880 FCB IMEDD+5,"BEGIN"
|
|
|
2796 BEGIN jsr DOLST
|
|
|
2797 FDB HERE,EXIT
|
|
|
2798
|
|
|
2799 ; NEXT ( a -- )
|
|
|
2800 ; Terminate a FOR-NEXT loop structure.
|
|
|
2801
|
|
|
2802 FDB NEXT,L1880
|
|
|
2803 L1890 FCB IMEDD+4,"NEXT"
|
|
|
2804 NEXT jsr DOLST
|
|
|
2805 FDB COMPI,DONXT,COMMA,EXIT
|
|
|
2806
|
|
|
2807 ; UNTIL ( a -- )
|
|
|
2808 ; Terminate a BEGIN-UNTIL indefinite loop structure.
|
|
|
2809
|
|
|
2810 FDB UNTIL,L1890
|
|
|
2811 L1900 FCB IMEDD+5,"UNTIL"
|
|
|
2812 UNTIL jsr DOLST
|
|
|
2813 FDB COMPI,QBRAN,COMMA,EXIT
|
|
|
2814
|
|
|
2815 ; AGAIN ( a -- )
|
|
|
2816 ; Terminate a BEGIN-AGAIN infinite loop structure.
|
|
|
2817
|
|
|
2818 FDB AGAIN,L1900
|
|
|
2819 L1910 FCB IMEDD+5,"AGAIN"
|
|
|
2820 AGAIN jsr DOLST
|
|
|
2821 FDB COMPI,BRAN,COMMA,EXIT
|
|
|
2822
|
|
|
2823 ; IF ( -- A )
|
|
|
2824 ; Begin a conditional branch structure.
|
|
|
2825
|
|
|
2826 FDB IFF,L1910
|
|
|
2827 L1920 FCB IMEDD+2,"IF"
|
|
|
2828 IFF jsr DOLST
|
|
|
2829 FDB COMPI,QBRAN,HERE
|
|
|
2830 FDB ZERO,COMMA,EXIT
|
|
|
2831
|
|
|
2832 ; AHEAD ( -- A )
|
|
|
2833 ; Compile a forward branch instruction.
|
|
|
2834
|
|
|
2835 FDB AHEAD,L1920
|
|
|
2836 L1930 FCB IMEDD+5,"AHEAD"
|
|
|
2837 AHEAD jsr DOLST
|
|
|
2838 FDB COMPI,BRAN,HERE,ZERO,COMMA,EXIT
|
|
|
2839
|
|
|
2840 ; REPEAT ( A a -- )
|
|
|
2841 ; Terminate a BEGIN-WHILE-REPEAT indefinite loop.
|
|
|
2842
|
|
|
2843 FDB REPEA,L1930
|
|
|
2844 L1940 FCB IMEDD+6,"REPEAT"
|
|
|
2845 REPEA jsr DOLST
|
|
|
2846 FDB AGAIN,HERE,SWAP,STORE,EXIT
|
|
|
2847
|
|
|
2848 ; THEN ( A -- )
|
|
|
2849 ; Terminate a conditional branch structure.
|
|
|
2850
|
|
|
2851 FDB THENN,L1940
|
|
|
2852 L1950 FCB IMEDD+4,"THEN"
|
|
|
2853 THENN jsr DOLST
|
|
|
2854 FDB HERE,SWAP,STORE,EXIT
|
|
|
2855
|
|
|
2856 ; AFT ( a -- a A )
|
|
|
2857 ; Jump to THEN in a FOR-AFT-THEN-NEXT loop the first time through.
|
|
|
2858
|
|
|
2859 FDB AFT,L1950
|
|
|
2860 L1960 FCB IMEDD+3,"AFT"
|
|
|
2861 AFT jsr DOLST
|
|
|
2862 FDB DROP,AHEAD,BEGIN,SWAP,EXIT
|
|
|
2863
|
|
|
2864 ; ELSE ( A -- A )
|
|
|
2865 ; Start the false clause in an IF-ELSE-THEN structure.
|
|
|
2866
|
|
|
2867 FDB ELSEE,L1960
|
|
|
2868 L1970 FCB IMEDD+4,"ELSE"
|
|
|
2869 ELSEE jsr DOLST
|
|
|
2870 FDB AHEAD,SWAP,THENN,EXIT
|
|
|
2871
|
|
|
2872 ; WHILE ( a -- A a )
|
|
|
2873 ; Conditional branch out of a BEGIN-WHILE-REPEAT loop.
|
|
|
2874
|
|
|
2875 FDB WHILE,L1970
|
|
|
2876 L1980 FCB IMEDD+5,"WHILE"
|
|
|
2877 WHILE jsr DOLST
|
|
|
2878 FDB IFF,SWAP,EXIT
|
|
|
2879
|
|
|
2880 ; ABORT" ( -- ; <string> )
|
|
|
2881 ; Conditional abort with an error message.
|
|
|
2882
|
|
|
2883 FDB ABRTQ,L1980
|
|
|
2884 L1990 FCB IMEDD+6,"ABORT",'"'
|
|
|
2885 ABRTQ jsr DOLST
|
|
|
2886 FDB COMPI,ABORQ,STRCQ,EXIT
|
|
|
2887
|
|
|
2888 ; $" ( -- ; <string> )
|
|
|
2889 ; Compile an inline string literal.
|
|
|
2890
|
|
|
2891 FDB STRQ,L1990
|
|
|
2892 L2000 FCB IMEDD+2,'$','"'
|
|
|
2893 STRQ jsr DOLST
|
|
|
2894 FDB COMPI,STRQP,STRCQ,EXIT
|
|
|
2895
|
|
|
2896 ; ." ( -- ; <string> )
|
|
|
2897 ; Compile an inline string literal to be typed out at run time.
|
|
|
2898
|
|
|
2899 FDB DOTQ,L2000
|
|
|
2900 L2010 FCB IMEDD+2,'.','"'
|
|
|
2901 DOTQ jsr DOLST
|
|
|
2902 FDB COMPI,DOTQP,STRCQ,EXIT
|
|
|
2903
|
|
|
2904 ;; Name compiler
|
|
|
2905
|
|
|
2906 ; ?UNIQUE ( a -- a )
|
|
|
2907 ; Display a warning message if the word already exists.
|
|
|
2908
|
|
|
2909 FDB UNIQU,L2010
|
|
|
2910 L2020 FCB 7,"?UNIQUE"
|
|
|
2911 UNIQU jsr DOLST
|
|
|
2912 FDB DUPP,NAMEQ ;?name exists
|
|
|
2913 FDB QBRAN,UNIQ1
|
|
|
2914 FDB DOTQP ;redefinitions are OK
|
|
|
2915 FCB 7," reDef " ;but the user should be warned
|
|
|
2916 FDB OVER,COUNT,TYPES ;just in case its not planned
|
|
|
2917 UNIQ1 FDB DROP,EXIT
|
|
|
2918
|
|
|
2919 ; $,n ( na -- )
|
|
|
2920 ; Build a new dictionary name using the string at na.
|
|
|
2921
|
|
|
2922 FDB SNAME,L2020
|
|
|
2923 L2030 FCB 3,"$,n"
|
|
|
2924 SNAME jsr DOLST
|
|
|
2925 FDB DUPP,CAT ;?null input
|
|
|
2926 FDB QBRAN,PNAM1
|
|
|
2927 FDB UNIQU ;?redefinition
|
|
|
2928 FDB DUPP,LAST,STORE ;save na for vocabulary link
|
|
|
2929 FDB HERE,ALGND,SWAP ;align code address
|
|
|
2930 FDB CELLM ;link address
|
|
|
2931 FDB CRRNT,AT,AT,OVER,STORE
|
|
|
2932 FDB CELLM,DUPP,NP,STORE ;adjust name pointer
|
|
|
2933 FDB STORE,EXIT ;save code pointer
|
|
|
2934 PNAM1 FDB STRQP
|
|
|
2935 FCB 5," name" ;null input
|
|
|
2936 FDB THROW
|
|
|
2937
|
|
|
2938 ;; FORTH compiler
|
|
|
2939
|
|
|
2940 ; $COMPILE ( a -- )
|
|
|
2941 ; Compile next word to code dictionary as a token or literal.
|
|
|
2942
|
|
|
2943 FDB SCOMP,L2030
|
|
|
2944 L2040 FCB 8,"$COMPILE"
|
|
|
2945 SCOMP jsr DOLST
|
|
|
2946 FDB NAMEQ,QDUP ;?defined
|
|
|
2947 FDB QBRAN,SCOM2
|
|
|
2948 FDB AT,DOLIT,IMEDD<<8,ANDD ;?immediate
|
|
|
2949 FDB QBRAN,SCOM1
|
|
|
2950 FDB EXECU,EXIT ;its immediate, execute
|
|
|
2951 SCOM1 FDB COMMA,EXIT ;its not immediate, compile
|
|
|
2952 SCOM2 FDB TNUMB,ATEXE ;try to convert to number
|
|
|
2953 FDB QBRAN,SCOM3
|
|
|
2954 FDB LITER,EXIT ;compile number as integer
|
|
|
2955 SCOM3 FDB THROW ;error
|
|
|
2956
|
|
|
2957 ; OVERT ( -- )
|
|
|
2958 ; Link a new word into the current vocabulary.
|
|
|
2959
|
|
|
2960 FDB OVERT,L2040
|
|
|
2961 L2050 FCB 5,"OVERT"
|
|
|
2962 OVERT jsr DOLST
|
|
|
2963 FDB LAST,AT,CRRNT,AT,STORE,EXIT
|
|
|
2964
|
|
|
2965 ; ; ( -- )
|
|
|
2966 ; Terminate a colon definition.
|
|
|
2967
|
|
|
2968 FDB SEMIS,L2050
|
|
|
2969 L2060 FCB IMEDD+COMPO+1,";"
|
|
|
2970 SEMIS jsr DOLST
|
|
|
2971 FDB COMPI,EXIT,LBRAC,OVERT,EXIT
|
|
|
2972
|
|
|
2973 ; ] ( -- )
|
|
|
2974 ; Start compiling the words in the input stream.
|
|
|
2975
|
|
|
2976 FDB RBRAC,L2060
|
|
|
2977 L2070 FCB 1,"]"
|
|
|
2978 RBRAC jsr DOLST
|
|
|
2979 FDB DOLIT,SCOMP,TEVAL,STORE,EXIT
|
|
|
2980
|
|
|
2981 ; call, ( ca -- )
|
|
|
2982 ; Assemble a call instruction to ca.
|
|
|
2983
|
|
|
2984 FDB CALLC,L2070
|
|
|
2985 L2080 FCB 5,"call,"
|
|
|
2986 CALLC jsr DOLST
|
|
|
2987 FDB DOCLIT
|
|
|
2988 FCB CALLL
|
|
|
2989 FDB HERE,CSTOR ;Direct Threaded Code
|
|
|
2990 FDB ONE,ALLOT
|
|
|
2991 FDB COMMA,EXIT ;DTC 6809 extended addr jsr
|
|
|
2992
|
|
|
2993 ; : ( -- ; <string> )
|
|
|
2994 ; Start a new colon definition using next word as its name.
|
|
|
2995
|
|
|
2996 FDB COLON,L2080
|
|
|
2997 L2090 FCB 1,":"
|
|
|
2998 COLON jsr DOLST
|
|
|
2999 FDB TOKEN,SNAME,DOLIT,DOLST
|
|
|
3000 FDB CALLC,RBRAC,EXIT
|
|
|
3001
|
|
|
3002 ; IMMEDIATE ( -- )
|
|
|
3003 ; Make the last compiled word an immediate word.
|
|
|
3004
|
|
|
3005 FDB IMMED,L2090
|
|
|
3006 L2100 FCB 9,"IMMEDIATE"
|
|
|
3007 IMMED jsr DOLST
|
|
|
3008 FDB DOLIT,IMEDD<<8,LAST,AT,AT,ORR
|
|
|
3009 FDB LAST,AT,STORE,EXIT
|
|
|
3010
|
|
|
3011 ;; Defining words
|
|
|
3012
|
|
|
3013 ; USER ( u -- ; <string> )
|
|
|
3014 ; Compile a new user variable.
|
|
|
3015
|
|
|
3016 FDB USER,L2100
|
|
|
3017 L2110 FCB 4,"USER"
|
|
|
3018 USER jsr DOLST
|
|
|
3019 FDB TOKEN,SNAME,OVERT
|
|
|
3020 ;;;; FDB DOLIT,DOLST,CALLC
|
|
|
3021 ;;;; FDB DOLIT,DOUSE,COMMA
|
|
|
3022 ; fast implementation ....
|
|
|
3023 FDB DOLIT,FDOUSE,CALLC
|
|
|
3024 FDB COMMA,EXIT
|
|
|
3025
|
|
|
3026 ; CREATE ( -- ; <string> )
|
|
|
3027 ; Compile a new array entry without allocating code space.
|
|
|
3028
|
|
|
3029 FDB CREAT,L2110
|
|
|
3030 L2120 FCB 6,"CREATE"
|
|
|
3031 CREAT jsr DOLST
|
|
|
3032 FDB TOKEN,SNAME,OVERT
|
|
|
3033 ;;;; FDB DOLIT,DOLST,CALLC
|
|
|
3034 ;;;; FDB DOLIT,DOVAR,COMMA,EXIT
|
|
|
3035 ; fast implementation ....
|
|
|
3036 FDB DOLIT,FDOVAR,CALLC,EXIT
|
|
|
3037
|
|
|
3038 ; VARIABLE ( -- ; <string> )
|
|
|
3039 ; Compile a new variable initialized to 0.
|
|
|
3040
|
|
|
3041 FDB VARIA,L2120
|
|
|
3042 L2130 FCB 8,"VARIABLE"
|
|
|
3043 VARIA jsr DOLST
|
|
|
3044 FDB CREAT,ZERO,COMMA,EXIT
|
|
|
3045
|
|
|
3046 ; CONSTANT ( w -- ; <string> )
|
|
|
3047 ; Compile a new constant with value w.
|
|
|
3048
|
|
|
3049 FDB CONST,L2130
|
|
|
3050 L2135 FCB 8,"CONSTANT"
|
|
|
3051 CONST jsr DOLST
|
|
|
3052 FDB TOKEN,SNAME,OVERT
|
|
|
3053 FDB DOLIT,DOCONST,CALLC
|
|
|
3054 FDB COMMA,EXIT
|
|
|
3055
|
|
|
3056 ;; Tools
|
|
|
3057
|
|
|
3058 ; _TYPE ( b u -- )
|
|
|
3059 ; Display a string. Filter non-printing characters.
|
|
|
3060
|
|
|
3061 FDB UTYPE,L2135
|
|
|
3062 L2140 FCB 5,"_TYPE"
|
|
|
3063 UTYPE jsr DOLST
|
|
|
3064 FDB TOR ;start count down loop
|
|
|
3065 FDB BRAN,UTYP2 ;skip first pass
|
|
|
3066 UTYP1 FDB DUPP,CAT,TCHAR,EMIT ;display only printable
|
|
|
3067 FDB PLUS1 ;increment address
|
|
|
3068 UTYP2 FDB DONXT,UTYP1 ;loop till done
|
|
|
3069 FDB DROP,EXIT
|
|
|
3070
|
|
|
3071 ; dm+ ( a u -- a )
|
|
|
3072 ; Dump u bytes from , leaving a+u on the stack.
|
|
|
3073
|
|
|
3074 FDB DUMPP,L2140
|
|
|
3075 L2150 FCB 3,"dm+"
|
|
|
3076 DUMPP jsr DOLST
|
|
|
3077 FDB OVER,DOLIT,4,UDOTR ;display address
|
|
|
3078 FDB SPACE,TOR ;start count down loop
|
|
|
3079 FDB BRAN,PDUM2 ;skip first pass
|
|
|
3080 PDUM1 FDB DUPP,CAT,DOLIT,3,UDOTR ;display numeric data
|
|
|
3081 FDB PLUS1 ;increment address
|
|
|
3082 PDUM2 FDB DONXT,PDUM1 ;loop till done
|
|
|
3083 FDB EXIT
|
|
|
3084
|
|
|
3085 ; DUMP ( a u -- )
|
|
|
3086 ; Dump u bytes from a, in a formatted manner.
|
|
|
3087
|
|
|
3088 FDB DUMP,L2150
|
|
|
3089 L2160 FCB 4,"DUMP"
|
|
|
3090 DUMP jsr DOLST
|
|
|
3091 FDB BASE,AT,TOR,HEX ;save radix, set hex
|
|
|
3092 FDB DOCLIT
|
|
|
3093 FCB 16
|
|
|
3094 FDB SLASH ;change count to lines
|
|
|
3095 FDB TOR ;start count down loop
|
|
|
3096 DUMP1 FDB CR,DOCLIT
|
|
|
3097 FCB 16
|
|
|
3098 FDB DDUP,DUMPP ;display numeric
|
|
|
3099 FDB ROT,ROT
|
|
|
3100 FDB TWO,SPACS,UTYPE ;display printable characters
|
|
|
3101 FDB NUFQ,INVER ;user control
|
|
|
3102 FDB QBRAN,DUMP2
|
|
|
3103 FDB DONXT,DUMP1 ;loop till done
|
|
|
3104 FDB BRAN,DUMP3
|
|
|
3105 DUMP2 FDB RFROM,DROP ;cleanup loop stack, early exit
|
|
|
3106 DUMP3 FDB DROP,RFROM,BASE,STORE ;restore radix
|
|
|
3107 FDB EXIT
|
|
|
3108
|
|
|
3109 ; .S ( ... -- ... )
|
|
|
3110 ; Display the contents of the data stack.
|
|
|
3111
|
|
|
3112 FDB DOTS,L2160
|
|
|
3113 L2170 FCB 2,".S"
|
|
|
3114 DOTS jsr DOLST
|
|
|
3115 FDB CR,DEPTH ;stack depth
|
|
|
3116 FDB TOR ;start count down loop
|
|
|
3117 FDB BRAN,DOTS2 ;skip first pass
|
|
|
3118 DOTS1 FDB RAT,PICK,DOT ;index stack, display contents
|
|
|
3119 DOTS2 FDB DONXT,DOTS1 ;loop till done
|
|
|
3120 FDB DOTQP
|
|
|
3121 FCB 4," <sp"
|
|
|
3122 FDB EXIT
|
|
|
3123
|
|
|
3124 ; !CSP ( -- )
|
|
|
3125 ; Save stack pointer in CSP for error checking.
|
|
|
3126
|
|
|
3127 FDB STCSP,L2170
|
|
|
3128 L2180 FCB 4,"!CSP"
|
|
|
3129 STCSP jsr DOLST
|
|
|
3130 FDB SPAT,CSP,STORE,EXIT ;save pointer
|
|
|
3131
|
|
|
3132 ; ?CSP ( -- )
|
|
|
3133 ; Abort if stack pointer differs from that saved in CSP.
|
|
|
3134
|
|
|
3135 FDB QCSP,L2180
|
|
|
3136 L2190 FCB 4,"?CSP"
|
|
|
3137 QCSP jsr DOLST
|
|
|
3138 FDB SPAT,CSP,AT,XORR ;compare pointers
|
|
|
3139 FDB ABORQ ;abort if different
|
|
|
3140 FCB 6,"stacks"
|
|
|
3141 FDB EXIT
|
|
|
3142
|
|
|
3143 ; >NAME ( ca -- na | F )
|
|
|
3144 ; Convert code address to a name address.
|
|
|
3145
|
|
|
3146 FDB TNAME,L2190
|
|
|
3147 L2200 FCB 5,">NAME"
|
|
|
3148 TNAME jsr DOLST
|
|
|
3149 FDB CRRNT ;vocabulary link
|
|
|
3150 TNAM1 FDB CELLP,AT,QDUP ;check all vocabularies
|
|
|
3151 FDB QBRAN,TNAM4
|
|
|
3152 FDB DDUP
|
|
|
3153 TNAM2 FDB AT,DUPP ;?last word in a vocabulary
|
|
|
3154 FDB QBRAN,TNAM3
|
|
|
3155 FDB DDUP,NAMET,XORR ;compare
|
|
|
3156 FDB QBRAN,TNAM3
|
|
|
3157 FDB CELLM ;continue with next word
|
|
|
3158 FDB BRAN,TNAM2
|
|
|
3159 TNAM3 FDB SWAP,DROP,QDUP
|
|
|
3160 FDB QBRAN,TNAM1
|
|
|
3161 FDB SWAP,DROP,SWAP,DROP,EXIT
|
|
|
3162 TNAM4 FDB DROP,DOLIT,0,EXIT
|
|
|
3163
|
|
|
3164 ; .ID ( na -- )
|
|
|
3165 ; Display the name at address.
|
|
|
3166
|
|
|
3167 FDB DOTID,L2200
|
|
|
3168 L2210 FCB 3,".ID"
|
|
|
3169 DOTID jsr DOLST
|
|
|
3170 FDB QDUP ;if zero no name
|
|
|
3171 FDB QBRAN,DOTI1
|
|
|
3172 FDB COUNT,DOCLIT
|
|
|
3173 FCB $1F
|
|
|
3174 FDB ANDD ;mask lexicon bits
|
|
|
3175 FDB UTYPE,EXIT ;display name string
|
|
|
3176 DOTI1 FDB DOTQP
|
|
|
3177 FCB 9," {noName}"
|
|
|
3178 FDB EXIT
|
|
|
3179
|
|
|
3180 ; SEE ( -- ; <string> )
|
|
|
3181 ; A simple decompiler.
|
|
|
3182
|
|
|
3183 FDB SEE,L2210
|
|
|
3184 L2220 FCB 3,"SEE"
|
|
|
3185 SEE jsr DOLST
|
|
|
3186 FDB TICK ;starting address
|
|
|
3187 FDB PLUS1 ;skip JSR
|
|
|
3188 ;primitive check ...
|
|
|
3189 FDB BASE,AT,TOR,HEX ;switch to hex base
|
|
|
3190 FDB DUPP,AT,DOLIT,DOLST,XORR
|
|
|
3191 ;high level word?
|
|
|
3192 FDB QBRAN,SEE1 ;yes!
|
|
|
3193 FDB CR,DOTQP ;primitive word only
|
|
|
3194 FCB 9, " PRIMITVE"
|
|
|
3195 FDB BRAN,SEE5 ;exit
|
|
|
3196 SEE1 FDB CR,CELLP,DUPP,UDOT,SPACE
|
|
|
3197 FDB DUPP,AT,DUPP ;?does it contain a zero
|
|
|
3198 FDB QBRAN,SEE2
|
|
|
3199 FDB TNAME ;?is it a name
|
|
|
3200 SEE2 FDB QDUP ;name address or zero
|
|
|
3201 FDB QBRAN,SEE3
|
|
|
3202
|
|
|
3203 FDB SPACE,DOTID ;display name
|
|
|
3204 FDB DUPP,AT
|
|
|
3205
|
|
|
3206 FDB DUPP,DOLIT,DOCLIT,EQUAL ; doCLIT?
|
|
|
3207 FDB QBRAN,SEE21
|
|
|
3208 FDB OVER,CELLP,CAT,SPACE,UDOT ; CLIT: get only single byte
|
|
|
3209 FDB SWAP,PLUS1,SWAP
|
|
|
3210 FDB BRAN,SEE28
|
|
|
3211
|
|
|
3212 SEE21 FDB DUPP,DOLIT,DOLIT,EQUAL ; doCLIT?
|
|
|
3213 FDB OVER,DOLIT,QBRAN,EQUAL,ORR ; ?BRAN ?
|
|
|
3214 FDB OVER,DOLIT,BRAN,EQUAL,ORR; BRANCH ?
|
|
|
3215 FDB OVER,DOLIT,DONXT,EQUAL,ORR; next ? (from FOR/NEXT)
|
|
|
3216 FDB OVER,DOLIT,DOLOOP,EQUAL,ORR; (LOOP) ?
|
|
|
3217 FDB OVER,DOLIT,DOPLOOP,EQUAL,ORR; (+LOOP) ?
|
|
|
3218 FDB OVER,DOLIT,DODO,EQUAL,ORR; (DO) ?
|
|
|
3219 FDB OVER,DOLIT,DOQDO,EQUAL,ORR; (?DO) ?
|
|
|
3220 FDB OVER,DOLIT,DOMDO,EQUAL,ORR; (-DO) ?
|
|
|
3221 FDB QBRAN,SEE27
|
|
|
3222 FDB SWAP,CELLP,DUPP,AT,SPACE,UDOT,SWAP ; LIT: get word
|
|
|
3223 FDB BRAN,SEE28
|
|
|
3224 SEE27
|
|
|
3225 FDB DUPP,DOLIT,DOTQP,EQUAL ; ." ..."
|
|
|
3226 FDB OVER,DOLIT,ABORQ,EQUAL,ORR ; ABORT" ..."
|
|
|
3227 FDB OVER,DOLIT,STRQP,EQUAL,ORR ; $" ..."
|
|
|
3228 FDB QBRAN,SEE29 ; last case aalway to SEE29!!
|
|
|
3229 FDB SWAP,CELLP ; print compiled string
|
|
|
3230 FDB DUPP,COUNT,TYPES,DOCLIT
|
|
|
3231 FCB 34
|
|
|
3232 FDB EMIT
|
|
|
3233 FDB COUNT,PLUS,CELLM,SWAP ; adjust continuation address
|
|
|
3234
|
|
|
3235 SEE28 FDB DROP ; LEAVL, without EXIT check
|
|
|
3236 FDB BRAN,SEE4
|
|
|
3237 SEE29 FDB DROP ; ELSE
|
|
|
3238 FDB BRAN,SEE31 ; cleanup, check for EXIT
|
|
|
3239
|
|
|
3240 SEE3 FDB DUPP,AT,UDOT ;display number
|
|
|
3241 FDB BRAN,SEE4
|
|
|
3242 SEE31 FDB DUPP,AT,DOLIT,EXIT,XORR ; stop on EXIT word
|
|
|
3243 ; but not if SEE decompiles itself!
|
|
|
3244 FDB QBRAN,SEE5
|
|
|
3245 SEE4 FDB NUFQ ;user control
|
|
|
3246 FDB QBRAN,SEE1
|
|
|
3247 SEE5 FDB RFROM,BASE,STORE,DROP,EXIT
|
|
|
3248
|
|
|
3249 ; WORDS ( -- )
|
|
|
3250 ; Display the names in the context vocabulary.
|
|
|
3251
|
|
|
3252 FDB WORDS,L2220
|
|
|
3253 L2230 FCB 5,"WORDS"
|
|
|
3254 WORDS jsr DOLST
|
|
|
3255 FDB CR,CNTXT,AT ;only in context
|
|
|
3256 WORS1 FDB AT,QDUP ;?at end of list
|
|
|
3257 FDB QBRAN,WORS2
|
|
|
3258 FDB DUPP,SPACE,DOTID ;display a name
|
|
|
3259 FDB CELLM,NUFQ ;user control
|
|
|
3260 FDB QBRAN,WORS1
|
|
|
3261 FDB DROP
|
|
|
3262 WORS2 FDB EXIT
|
|
|
3263
|
|
|
3264 ;; Hardware reset
|
|
|
3265
|
|
|
3266 ; VER ( -- n )
|
|
|
3267 ; Return the version number of this implementation.
|
|
|
3268
|
|
|
3269 FDB VERSN,L2230
|
|
|
3270 L2240 FCB 3,"VER"
|
|
|
3271 VERSN jsr DOLST
|
|
|
3272 FDB DOLIT,VER*256+EXT,EXIT
|
|
|
3273
|
|
|
3274 ; hi ( -- )
|
|
|
3275 ; Display the sign-on message of eForth.
|
|
|
3276
|
|
|
3277 FDB HI,L2240
|
|
|
3278 L2250 FCB 2,"hi"
|
|
|
3279 HI jsr DOLST
|
|
|
3280 FDB STOIO,CR,DOTQP ;initialize I/O
|
|
|
3281 FCB 11,"eForth v" ;model
|
|
|
3282 FCB VER+'0','.',EXT+'0' ;version
|
|
|
3283 FDB CR,EXIT
|
|
|
3284
|
|
|
3285 ; 'BOOT ( -- a )
|
|
|
3286 ; The application startup vector.
|
|
|
3287
|
|
|
3288 FDB TBOOT,L2250
|
|
|
3289 L2260 FCB 5,"'BOOT"
|
|
|
3290 TBOOT
|
|
|
3291 ;;;; jsr DOLST
|
|
|
3292 ;;;; FDB DOVAR
|
|
|
3293 jsr FDOVAR
|
|
|
3294 FDB HI ;application to boot
|
|
|
3295
|
|
|
3296 ; COLD ( -- )
|
|
|
3297 ; The hilevel cold start sequence.
|
|
|
3298
|
|
|
3299 FDB COLD,L2260
|
|
|
3300 L2270 FCB 4,"COLD"
|
|
|
3301 COLD jsr DOLST
|
|
|
3302 COLD1 FDB DOLIT,UZERO,DOLIT,UPP
|
|
|
3303 FDB DOLIT,ULAST-UZERO,CMOVE ;initialize user area
|
|
|
3304 FDB PRESE ;initialize data stack and TIB
|
|
|
3305 FDB TBOOT,ATEXE ;application boot
|
|
|
3306 FDB FORTH,CNTXT,AT,DUPP ;initialize search order
|
|
|
3307 FDB CRRNT,DSTOR,OVERT
|
|
|
3308 ; TEST
|
|
|
3309 ; FDB DOLIT,10,DOLIT,1
|
|
|
3310 ; FDB DODO
|
|
|
3311 ;
|
|
|
3312 FDB QUIT ;start interpretation
|
|
|
3313 FDB BRAN,COLD1 ;just in case
|
|
|
3314
|
|
|
3315 ;===============================================================
|
|
|
3316
|
|
|
3317 LASTN EQU L2270 ;last name address in name dictionary
|
|
|
3318
|
|
|
3319 NTOP EQU NAMEE ;next available memory in name dictionary
|
|
|
3320 CTOP EQU * ;next available memory in code dictionary
|
|
|
3321
|
|
|
3322
|
|
|
3323 END ORIG
|
|
|
3324
|
|
|
3325 ;===============================================================
|
|
|
3326
|
