-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathhc11e4th.asm
2733 lines (2046 loc) · 103 KB
/
hc11e4th.asm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;*******************************************************************************
;* Language : Motorola/Freescale/NXP 68HC11 Assembly Language (aspisys.com/ASM11)
;*******************************************************************************
;
; 68HC11 eForth for the Motorola FREEWARE assembler
;
; This version of eForth runs on the Motorola 68HC11 microcontrollers.
; The source code itself is derived from the original 8051 eForth as
; developed by Dr. C. H. Ting. I have rewritten the source to use the
; Motorola FREEWARE assembler, and have added features of interest
; to users of the 'HC11 family:
;
; 1. This code creates separate name and code areas, per conventional
; eForth. The two areas, however, are intertwined throughout the
; object file, rather than growing inward from opposite ends of the
; memory space during assembly as done in the original 8051 code.
;
; At execution time, the name and code pointers are aimed at addresses
; selected by the user at assembly time. From then on, the name and
; code areas expand as normal (code area grows toward higher memory,
; name area grows toward lower memory).
;
; 2. The object created by this source code is fully ROMable and
; fits in about 7K of EPROM. Upon execution, a word called TASK is
; moved into the RAM area and the name and code pointers are initialized.
;
; 3. Like the original eForth, this version is word-aligned in all
; respects. This imposes a tiny size penalty and a minor speed penalty
; over a typical byte-aligned 68HC11 Forth.
;
; 4. I have not added any code for interrupt vectoring. You should bring
; this up initially by burning it into EPROM and running it by a G command
; in BUFFALO. (Alternatively, you could download the S19 file via serial
; port into RAM.) Later, you can add your own interrupt vectoring, move
; the code into the $ffff area, and disable BUFFALO. This would let you
; execute eForth directly on power-up.
;
; 5. I have added the word NOOP (for no-operation). It is an empty word
; that simply serves as the execution code for TASK.
;
; This is a straight-up, no-frills porting of 8051 eForth to the 68HC11.
; I have not added words you will likely miss, such as CONSTANT and C,.
; Nor have I rewritten any high-level words in assembly language; since
; FIND and NUMBER are high-level, you can expect slow compilation.
;
; But eForth is intended to be a starting point; feel free to extend and
; modify as you like.
;
; I place this source code in the public domain. I cannot guarantee
; to support or maintain it, and I certainly do not take any responsibility
; for whatever you do with or to this code, nor for any effects this code
; generates, either directly or indirectly. I wrote this code primarily
; for pleasure, and I hope you enjoy playing with it and learning from it.
;
; If you have any questions or comments, you can reach me at:
;
; Karl Lunt
; 2133 186th Pl., SE
; Bothell, WA 98012
; (206) 483-0447
; Internet: karl@mav.com
;*******************************************************************************
#ListOff
#Uses exp-f1.inc
#ListOn
;*******************************************************************************
; Macros
;*******************************************************************************
token macro label,'string'[,c|i]
mset #','
mreq 1,2:label,'string'
mstr 2
align 2
#temp :index
fdb ~1~
#ifz :temp-1
fdb 0 ; link of 0 means first entry
#else
fdb _link{:temp-1}
#endif
#temp1
#ifparm ~3~ = c
#temp1 COMPO
#else ifparm ~3~ = i
#temp1 IMMED
#else ifparm ~3~ = ic
#temp1 IMMED+COMPO
#else ifparm ~3~ = ci
#temp1 IMMED+COMPO
#else ifnb ~3~
merror Unexpected: ~3~
#endif
_link{:temp} fcb :temp1+:2-2 ;length of literal without quotes
fcc ~2~
#ifz :2\2
fcb 0 ; null-fill cell
#endif
#ifndef ~1~
~1~ proc
#endif
#ifdef ADD_NOP_JMP_DOLST
nop
jmp dolst
#endif
endm
;*******************************************************************************
COMPO equ $40 ; lexicon compile only bit
IMMED equ $80 ; lexicon immediate bit
MASKK equ $1f7f ; lexicon bit mask
CELL_SIZE equ 2 ; size of a cell
DEFAULT_RADIX equ 10
VOCSS equ 8 ; depth of vocabulary stack
VER equ 1 ; version number
EXT equ 0 ; extension number
ERR equ 27 ; error escape
TRUE equ -1 ; eForth true flag
FALSE equ 0 ; eForth false flag
#if :cpu = 6811 ; (will leave NON_JMP undefined if ported)
NOP_JMP equ $017E ; nop-jmp opcodes (68HC11)
#endif
;===============================================================================
; RAM allocation: +-------------------------------+ top of RAM (RAMEND)
; | return stack grows down |
; | \/ |
; | \/ |
; +-------------------------------+
; | text input buffer |
; +-------------------------------+
; | data stack grows down |
; | \/ |
; | \/ |
; +-------------------------------+
; | /\ |
; | /\ |
; | user area grows up |
; +-------------------------------|
; | name dictionary grows down |
; | \/ |
; | \/ |
; +-------------------------------+
; | /\ |
; | /\ |
; | code dictionary grows up |
; +-------------------------------+ bottom of RAM (RAMBEG)
;===============================================================================
; You can customize the memory usage of this eForth by changing the
; values assigned to the following equates. All sizes are in bytes
; and must be even numbers.
RAMBEG equ $a000 ; bottom of ram memory
RAMEND equ $bfff ; top of ram memory
ROMBEG equ $c000 ; bottom of rom memory
us equ $100 ; user area size in bytes
rts equ $100 ; return stack/tib size
dts equ $100 ; data stack size
; These equates fix the relative positions of eForth's buffers and
; stack areas.
rpp equ RAMEND&$fffe ; start of return stack (rp0)
tibb equ rpp-rts ; start of tib, body of rtn stack
spp equ tibb-2 ; start of data stack (sp0)
upp equ spp-dts-us-$10 ; start of user area (up)
NAMEE equ upp-$10&$fffe ; initial name dictionary (word align)
CODEE equ RAMBEG ; initial code dictionary
;*******************************************************************************
; Allocation of 68HC11 working registers. These registers should stay
; in the zero-page area for faster execution speed.
;*******************************************************************************
#RAM
;*******************************************************************************
org $0022
?ip rmb 2 ; 2 bytes for IP
;*******************************************************************************
#ROM ; Start of 'hc11 eForth code
;*******************************************************************************
; ROM-based default data values. These are automatically
; preloaded into the user area upon reset.
uzero fdb:4 0 ; reserved
fdb spp ; sp0
fdb rpp ; rp0
fdb qrx ; '?key
fdb txsto ; 'emit
fdb accep ; 'expect
fdb ktap ; 'tap
fdb txsto ; 'echo
fdb dotok ; 'prompt
fdb DEFAULT_RADIX ; base
fdb 0 ; tmp
fdb 0 ; span
fdb 0 ; >in
fdb 0 ; #tib
fdb tibb ; tib
fdb 0 ; csp
fdb inter ; 'eval
fdb numbq ; 'number
fdb 0 ; hld
fdb 0 ; handler
fdb 0 ; context pointer
fdb:VOCSS 0 ; vocabulary stack (VOCSS deep)
fdb 0 ; current pointer
fdb 0 ; vocabulary link pointer
fdb CODEE ; cp
fdb 0 ; np (overwritten at powerup)
fdb 0 ; last (overwritten at powerup)
fdb 0 ; forth (overwritten at powerup)
fdb 0 ; vocabulary link
#size uzero
; The following code is copied to the start of the RAM name
; dictionary space on powerup.
ntask fdb noop ; 'code' for task
fdb coldlink ; link 'back' to cold
#ppc
fcs LEN@@,'TASK'
LEN@@ equ *-:ppc-2 ; (-1 for zero fill and -1 for length byte)
#size ntask
;*******************************************************************************
; Start of the compiler; jump here on power-up.
; Note that serial port initialization can occur here and at !IO; if
; you change any initialization code here, be sure to duplicate the
; changes in !IO.
Start proc
sei
lda #%10110011 ; turn on a/d, use edge irq, enable
; delay after stop, set slow clk to
; watchdog
sta OPTION
lda #$30 ; 9600 BAUD @ 2MHz bus
sta BAUD
clr SCCR1 ; 8-bit xfers
lda #$0c
sta SCCR2 ; no interrupts, enable r & t
lds #spp-2 ; temp start of data stack
ldy #rpp ; temp start of return stack
ldx #cold1 ; point to first instruction
bra ?next2 ; and start it up
;*******************************************************************************
; The forth inner interpreter
; Entry can occur at one of three locations, depending on the action
; needed.
; Entry at pushd pushes the word in A:B onto the data stack, then
; falls into ?next. Use this entry point when leaving a low-level
; definition that must also push a result (in D) onto the data
; stack.
; Entry at ?next simply moves to the next low-level definition in
; the thread. Use this entry point when leaving a low-level
; definition that does not need to save any results onto the data
; stack.
; Entry at ?next2 uses the value in X as the current IP (instruction
; pointer) and calculates the next executable address from it. Use
; this entry point when changing execution threads; for example, see
; the code at ?BRANCH.
pushd proc
pshd ; save D as word on stack and fall into ?next
?next ldx ?ip ; get current ip
?next2 ldb #2 ; ip = ip + 2
abx
stx ?ip
dex:2 ; x = ip - 2
ldx ,x ; x = (x)
jmp ,x ; go to (x)
dolst ldb #4 ; x = x + 4
abx ; (to jump around NOP JMP DOLST)
ldd ?ip ; get old IP
std ,y ; save on return stack
dey:2 ; make room on return stack
bra ?next2 ; and go to next level
exit ldb #2 ; y = y + 2
aby
ldx ,y ; pull old IP from return stack
bra ?next2 ; and go to previous level
;*******************************************************************************
; Each eForth word contains a header of the following format:
; fdb label points to executable code
; fdb prev_name points back to previous name
; this_name:
; fcb options+n n = length of name in bytes
; fcc 'XXXX' string containing word's name
; fcb 0 word-alignment IF n IS EVEN!
; label:
; ----- start of assembly code for XXXX
; where options is IMMED if this is an IMMEDIATE word and COMPO if
; this is a COMPILE-ONLY word. Note that the line containing fcb 0 is
; optional; it should only appear if the word's name contains an even
; number of characters. Look over several definitions below
; for examples of building headers.
; Note that all low-level (assembly language) definitions begin with the
; phrase:
; align 2 ;WAS: org *+1&$fffe
; This forces the definition to be word-aligned. This org statement is
; not necessary for high-level definitions.
; Note also that all embedded strings (usually following an 'fdb dotqp')
; must contain an even number of bytes INCLUDING THE LENGTH BYTE. If
; necessary, use a 'fcb 0' to pad out to the next word address. Check
; the definitions below for examples.
; If you add customized low-level definitions, observe the following
; register usage:
; The hardware stack (S-register) serves as eForth's data stack. You must
; always push and pull data in word-wide sequences. Never leave the data
; stack having pushed or pulled an odd number of bytes.
; The Y-register defines eForth's return stack. All accesses must be
; word-wide. See the code at >R and R> for examples of using the Y-register
; as a stack pointer.
; The X-register may be freely trashed in your code, with one possible
; exception. If you leave your new definition with a jump to ?next2,
; X must point to the next threaded address to execute. See the code in
; BRANCH for an example.
; The A- and B-registers may also be used freely, again with one possible
; exception. If you leave your new definition with a jump to pushd,
; A:B will be pushed onto the data stack prior to executing the next
; word in the thread.
;*******************************************************************************
; The kernel
;*******************************************************************************
;*******************************************************************************
; dolit ( -- w )
; push an inline literal.
@token dolit,'doLIT',c
ldx ?ip ; get addr of next word
ldd ,x ; get data at that addr
inx:2 ; now bump IP
stx ?ip
bra pushd ; and save on stack
;*******************************************************************************
; dolist ( a -- )
; process colon list.
@token dolst,'doLIST',c ; points back into inner interpreter
;*******************************************************************************
; next ( -- )
; run time code for the single index loop.
; : next ( -- ) \ hilevel model
; r> r> dup if 1 - >r @ >r exit then drop cell+ >r ;
@token donxt,'next',c
ldd 2,y ; get counter on return stack
beq Cont@@ ; branch if loop is done
decd ; no, bump the counter
std 2,y ; and replace on stack
bra bran ; and branch back to top
Cont@@ iny:2 ; done, burn counter from stack
ldx ?ip ; get the IP
inx:2 ; and get addr past branch target
bra ?next2 ; and go do next word
;*******************************************************************************
; ?branch ( f -- )
; branch if flag is zero.
@token qbran,'?branch',c
puld ; get TOS to D
cmpd #0 ; did we get a 0?
bne Old@@ ; branch if not
ldx ?ip ; yes, get next word as addr
ldx ,x ; now get contents as new IP
bra ?next2 ; and jump there
Old@@ ldx ?ip ; get old ip
inx:2 ; and move past branch addr
jmp ?next2 ; and jump there
;*******************************************************************************
; branch ( -- )
; branch to an inline address.
@token bran,'branch',c ; use code inside ?BRANCH
;*******************************************************************************
; execute ( ca -- )
; execute the word at ca.
@token execu,'EXECUTE'
pulx ; get ca from TOS
jmp ,x ; and go do it
;*******************************************************************************
; exit ( -- )
; terminate a colon definition.
@token exit,'EXIT' ; points back into inner interpreter
;*******************************************************************************
; ! ( u a -- )
; store u into address a.
@token store,'!'
pulx ; get the addr
puld ; get the word
std ,x ; and save to addr
jmp ?next
;*******************************************************************************
; @ ( a -- w )
; push memory location to the data stack.
@token at,'@'
pulx ; get the addr
ldd ,x ; get the data there
jmp pushd ; and save it
;*******************************************************************************
; c! ( c b -- )
; pop the data stack to byte memory.
@token cstor,'C!'
pulx ; get the addr
puld ; get the data (only low byte counts)
stb ,x ; save to addr
jmp ?next
;*******************************************************************************
; c@ ( b -- c )
; push byte memory location to the data stack.
@token cat,'C@'
pulx ; get the addr
ldb ,x ; get the data
clra ; make MSB = 0
jmp pushd ; and save it
;*******************************************************************************
; >r ( w -- )
; push the data stack to the return stack.
@token tor,'>R',c
puld ; get the data at TOS
std ,y ; save on return stack
dey:2 ; and make room
jmp ?next
;*******************************************************************************
; r@ ( -- w )
; copy top of return stack to the data stack.
@token rat,'R@'
ldd 2,y ; get top value on return stack
jmp pushd ; and save to data stack
;*******************************************************************************
; r> ( -- w )
; pop the return stack to the data stack.
@token rfrom,'R>'
iny:2 ; count this value
ldd ,y ; get top value on return stack
jmp pushd ; now save it
;*******************************************************************************
; rp@ ( -- a )
; push the current rp to the data stack.
@token rpat,'RP@'
pshy ; save return pointer
jmp ?next
;*******************************************************************************
; rp! ( a -- )
; set the return stack pointer.
@token rpsto,'RP!',c
puly ; use new return pointer
jmp ?next
;*******************************************************************************
; sp@ ( -- a )
; push the current data stack pointer.
@token spat,'SP@'
tsx ; get current stack pointer
dex ; adjust for tsx instr
pshx ; and save on data stack
jmp ?next
;*******************************************************************************
; sp! ( a -- )
; set the data stack pointer.
@token spsto,'SP!'
pulx ; get new stack pointer
inx ; prepare for txs
txs ; and make it count
jmp ?next
;*******************************************************************************
; dup ( w -- w w )
; duplicate the top stack item.
@token dup,'DUP'
pulx ; get TOS
pshx:2 ; save it back, and a copy
jmp ?next
;*******************************************************************************
; drop ( w -- )
; discard top stack item.
@token drop,'DROP'
pulx ; burn a data item
jmp ?next
;*******************************************************************************
; swap ( w1 w2 -- w2 w1 )
; exchange top two stack items.
@token swap,'SWAP'
pulx ; get top item
puld ; get second item
pshx ; save top item
jmp pushd ; and save second item
;*******************************************************************************
; over ( w1 w2 -- w1 w2 w1 )
; copy second stack item to top.
@token over,'OVER'
tsx ; get the stack pointer
ldd 2,x ; get second item
jmp pushd ; and push onto stack
;*******************************************************************************
; 0< ( n -- t )
; return true if n is negative.
@token zless,'0<'
puld ; get TOS
tsta ; check high bit
bmi True@@ ; branch if negative
ldd #FALSE ; get the flag
jmp pushd ; and set it
True@@ ldd #TRUE ; get the flag
jmp pushd ; and set it
;*******************************************************************************
; and ( w w -- w )
; bitwise and.
@token and,'AND'
puld ; get TOS
tsx ; get stack pointer
anda ,x ; and do the and
andb 1,x
std ,x ; save back to stack
jmp ?next
;*******************************************************************************
; or ( w w -- w )
; bitwise inclusive or.
@token or,'OR'
puld ; get TOS
tsx ; get stack pointer
ora ,x ; and do the and
orb 1,x
std ,x ; save back to stack
jmp ?next
;*******************************************************************************
; xor ( w w -- w )
; bitwise exclusive or.
@token xor,'XOR'
puld ; get TOS
tsx ; get stack pointer
eora ,x ; and do the and
eorb 1,x
std ,x ; save back to stack
jmp ?next
;*******************************************************************************
; um+ ( w w -- w cy )
; add two numbers, return the sum and carry flag.
@token uplus,'UM+'
puld ; get TOS
tsx ; get the stack pointer
addd ,x ; and add second item
std ,x ; put back on stack
ldd #0 ; presume false
rolb ; move carry into word
jmp pushd ; and save on stack
;*******************************************************************************
; device dependent i/o
;*******************************************************************************
;*******************************************************************************
; !io ( -- )
; initialize the serial i/o devices.
@token stoio,'!IO'
lda #$30 ; 9600 BAUD
sta BAUD
lda #$00 ; 8-bit xfers
sta SCCR1
lda #$0c
sta SCCR2 ; no interrupts, enable r & t
jmp ?next
;*******************************************************************************
; ?rx ( -- c t | f )
; return input character and true, or a false if no input.
@token qrx,'?RX'
clra ; assume no char available
ldb SCSR ; get serial status reg
andb #%00100000 ; check RDRF bit
beq Save@@ ; branch if nothing there
ldb SCDR ; char; move into B
pshd ; save char to stack as word
ldd #TRUE ; get the flag
Save@@ jmp pushd ; and save flag
;*******************************************************************************
; tx! ( c -- )
; send character c to the output device.
@token txsto,'TX!'
puld ; get char from TOS, char is in B
Loop@@ lda SCSR ; time to send?
bpl Loop@@ ; loop until time
stb SCDR ; write char to SCI
jmp ?next
;*******************************************************************************
; system and user variables
;*******************************************************************************
ADD_NOP_JMP_DOLST ;from this point on after @token
;*******************************************************************************
; dovar ( -- a )
; run time routine for variable and create.
@token dovar,'doVAR',c
fdb rfrom,exit
;*******************************************************************************
; up ( -- a )
; pointer to the user area.
@token up,'UP'
fdb dovar
fdb upp
;*******************************************************************************
; douser ( -- a )
; run time routine for user variables.
@token douse,'doUSER',c
fdb rfrom,at,up,at,plus,exit
;*******************************************************************************
; sp0 ( -- a )
; pointer to bottom of the data stack.
@token szero,'SP0'
fdb douse,8,exit
;*******************************************************************************
; rp0 ( -- a )
; pointer to bottom of the return stack.
@token rzero,'RP0'
fdb douse,10,exit
;*******************************************************************************
; '?key ( -- a )
; execution vector of ?key.
@token tqkey,"'?key"
fdb douse,12,exit
;*******************************************************************************
; 'emit ( -- a )
; execution vector of emit.
@token temit,"'emit"
fdb douse,14,exit
;*******************************************************************************
; 'expect ( -- a )
; execution vector of expect.
@token texpe,"'expect"
fdb douse,16,exit
;*******************************************************************************
; 'tap ( -- a )
; execution vector of tap.
@token ttap,"'tap"
fdb douse,18,exit
;*******************************************************************************
; 'echo ( -- a )
; execution vector of echo.
@token techo,"'echo"
fdb douse,20,exit
;*******************************************************************************
; 'prompt ( -- a )
; execution vector of prompt.
@token tprom,"'prompt"
fdb douse,22,exit
;*******************************************************************************
; base ( -- a )
; storage of the radix base for numeric i/o.
@token base,'BASE'
fdb douse,24,exit
;*******************************************************************************
; tmp ( -- a )
; a temporary storage location used in parse and find.
@token temp,'tmp',c
fdb douse,26,exit
;*******************************************************************************
; span ( -- a )
; hold character count received by expect.
@token span,'SPAN'
fdb douse,28,exit
;*******************************************************************************
; >in ( -- a )
; hold the character pointer while parsing input stream.
@token inn,'>IN'
fdb douse,30,exit
;*******************************************************************************
; #tib ( -- a )
; hold the current count and address of the terminal input buffer.
@token ntib,'#TIB'
fdb douse,32,exit
;*******************************************************************************
; csp ( -- a )
; hold the stack pointer for error checking.
@token csp,'CSP'
fdb douse,36,exit
;*******************************************************************************
; 'eval ( -- a )
; execution vector of eval.
@token teval,"'eval"
fdb douse,38,exit
;*******************************************************************************
; 'number ( -- a )
; execution vector of number?.
@token tnumb,"'number"
fdb douse,40,exit
;*******************************************************************************
; hld ( -- a )
; hold a pointer in building a numeric output string.
@token hld,'HLD'
fdb douse,42,exit
;*******************************************************************************
; handler ( -- a )
; hold the return stack pointer for error handling.
@token handl,'HANDLER'
fdb douse,44,exit
;*******************************************************************************
; context ( -- a )
; a area to specify vocabulary search order.
@token cntxt,'CONTEXT'
fdb douse,46,exit
;*******************************************************************************
; current ( -- a )
; point to the vocabulary to be extended.
@token crrnt,'CURRENT'
fdb douse,64,exit
;*******************************************************************************
; cp ( -- a )
; point to the top of the code dictionary.
@token cp,'CP'
fdb douse,68,exit
;*******************************************************************************
; np ( -- a )
; point to the bottom of the name dictionary.
@token np,'NP'
fdb douse,70,exit
;*******************************************************************************
; last ( -- a )
; point to the last name in the name dictionary.
@token last,'LAST'
fdb douse,72,exit
;*******************************************************************************
; forth ( -- a )
; point to the last name in the name dictionary.
@token vfrth,'forth'
fdb douse,74,exit
;*******************************************************************************
; WARNING: Next available user area offset is 78.
;*******************************************************************************
;*******************************************************************************
; common functions
;*******************************************************************************
;*******************************************************************************
; forth ( -- )
; make forth the context vocabulary.
@token forth,'FORTH'
fdb vfrth,cntxt,store,exit
;*******************************************************************************
; ?dup ( w -- w w | 0 )
; dup tos if its is not zero.
@token qdup,'?DUP'
fdb dup
fdb qbran,qdup1
fdb dup
qdup1 fdb exit
;*******************************************************************************
; rot ( w1 w2 w3 -- w2 w3 w1 )
; rot 3rd item to top.
@token rot,'ROT'
fdb tor,swap,rfrom,swap,exit
;*******************************************************************************
; 2drop ( w w -- )
; discard two items on stack.
@token ddrop,'2DROP'
fdb drop,drop,exit
;*******************************************************************************
; 2dup ( w1 w2 -- w1 w2 w1 w2 )
; duplicate top two items.
@token ddup,'2DUP'
fdb over,over,exit
;*******************************************************************************
; + ( w w -- sum )
; add top two items.
@token plus,'+'
fdb uplus,drop,exit
;*******************************************************************************
; d+ ( d d -- d )
; double addition, as an example using um+.
@token dplus,'D+'
fdb tor,swap,tor,uplus
fdb rfrom,rfrom,plus,plus,exit
;*******************************************************************************
; not ( w -- w )
; one's complement of tos.
@token inver,'NOT'
fdb dolit,-1,xor,exit
;*******************************************************************************
; negate ( n -- -n )
; two's complement of tos.
@token negat,'NEGATE'
fdb inver,dolit,1,plus,exit
;*******************************************************************************
; dnegate ( d -- -d )
; two's complement of top double.
@token dnega,'DNEGATE'
fdb inver,tor,inver
fdb dolit,1,uplus
fdb rfrom,plus,exit
;*******************************************************************************
; - ( n1 n2 -- n1-n2 )
; subtraction.
@token sub,'-'
fdb negat,plus,exit
;*******************************************************************************
; abs ( n -- n )
; return the absolute value of n.
@token abs,'ABS'
fdb dup,zless
fdb qbran,abs1
fdb negat
abs1 fdb exit
;*******************************************************************************
; = ( w w -- t )
; return true if top two are equal.
@token equal,'='
fdb xor
fdb qbran,equ1
fdb dolit,FALSE,exit ; false flag
equ1 fdb dolit,TRUE,exit ; true flag