-
Notifications
You must be signed in to change notification settings - Fork 4
/
Copy pathans-forth.lst
5010 lines (4841 loc) · 281 KB
/
ans-forth.lst
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
Sun May 8 2016 22:10 Page 1
***************************************
** WDC 65C816 Macro Assembler **
** **
** Version 3.49.1- Feb 6 2006 **
***************************************
1 ;===============================================================================
2 ; _ _ _ ____ _____ _ _ _ ___ _ __
3 ; / \ | \ | / ___| | ___|__ _ __| |_| |__ ( )( _ )/ |/ /_
4 ; / _ \ | \| \___ \ | |_ / _ \| '__| __| '_ \ |/ / _ \| | '_ \
5 ; / ___ \| |\ |___) | | _| (_) | | | |_| | | | | (_) | | (_) |
6 ; /_/ \_\_| \_|____/ |_| \___/|_| \__|_| |_| \___/|_|\___/
7 ;
8 ; A Direct Threaded ANS Forth for the WDC 65C816
9 ;-------------------------------------------------------------------------------
10 ; Copyright (C)2015-2016 HandCoded Software Ltd.
11 ; All rights reserved.
12 ;
13 ; This work is made available under the terms of the Creative Commons
14 ; Attribution-NonCommercial-ShareAlike 4.0 International license. Open the
15 ; following URL to see the details.
16 ;
17 ; http://creativecommons.org/licenses/by-nc-sa/4.0/
18 ;
19 ;===============================================================================
20 ; Notes:
21 ;
22 ; This implementation is designed to run in the 65C816's native mode with both
23 ; the accumulator and index registers in 16-bit mode except when the word needs
24 ; 8-bit memory access.
25 ;
26 ; The DP register is used for the Forth data stack is values can be accessed
27 ; using the direct-page addressing modes. The code uses the same offsets as
28 ; would be used with the stack relative instructions (i.e <1, <3, etc.).
29 ;
30 ; The Y register holds the forth instruction pointer leaving X free for general
31 ; use in words. Some words push Y if they need an extra register.
32 ;
33 ; Some of the high-level definitions are based on Bradford J. Rodriguez's
34 ; CamelForth implementations.
35 ;
36 ;-------------------------------------------------------------------------------
37
38 pw 132
39 inclist on
40 maclist off
41
42 chip 65816
43 longi off
44 longa off
45
46 include "w65c816.inc"
1 ;==============================================================================
2 ; __ ____ ____ ____ ___ _ __
3 ; \ \ / / /_| ___| / ___( _ )/ |/ /_
4 ; \ \ /\ / / '_ \___ \| | / _ \| | '_ \
5 ; \ V V /| (_) |__) | |__| (_) | | (_) |
6 ; \_/\_/ \___/____/ \____\___/|_|\___/
Sun May 8 2016 22:10 Page 2
7 ;
8 ; Western Design Center W65C816 device definitions
9 ;------------------------------------------------------------------------------
10 ; Copyright (C)2015 HandCoded Software Ltd.
11 ; All rights reserved.
12 ;
13 ; This work is made available under the terms of the Creative Commons
14 ; Attribution-NonCommercial-ShareAlike 4.0 International license. Open the
15 ; following URL to see the details.
16 ;
17 ; http://creativecommons.org/licenses/by-nc-sa/4.0/
18 ;
19 ;===============================================================================
20 ; Notes:
21 ;
22 ; Various macros and definitions for the W65C816 microprocessor.
23 ;
24 ;===============================================================================
25 ; Revision History:
26 ;
27 ; 2015-12-18 AJ Initial version
28 ;-------------------------------------------------------------------------------
29 ; $Id$
30 ;-------------------------------------------------------------------------------
31
32 ;==============================================================================
33 ; Status Register Bits
34 ;------------------------------------------------------------------------------
35
36 00000080 N_FLAG equ 1<<7
37 00000040 V_FLAG equ 1<<6
38 00000020 M_FLAG equ 1<<5
39 00000010 X_FLAG equ 1<<4
40 00000010 B_FLAG equ 1<<4
41 00000008 D_FLAG equ 1<<3
42 00000004 I_FLAG equ 1<<2
43 00000002 Z_FLAG equ 1<<1
44 00000001 C_FLAG equ 1<<0
45
46 ;==============================================================================
47 ; Macros
48 ;------------------------------------------------------------------------------
49
50 ; Puts the processor in emulation mode. A, X and Y become 8-bits and the stack
51 ; is fixed at $0100-$01ff.
52
53 emulate macro
54 sec
55 xce
56 longa off
57 longi off
58 endm
59
60 ; Puts the processor in native mode. The size of the memory and index register
61 ; operations is not controlled by the M & X bits in the status register.
62
63 native macro
64 clc
Sun May 8 2016 22:10 Page 3
65 xce
66 endm
67
68 ; Resets the M bit making the accumulator and memory accesses 16-bits wide.
69
70 long_a macro
71 rep #M_FLAG
72 longa on
73 endm
74
75 ; Resets the X bit making the index registers 16-bits wide
76
77 long_i macro
78 rep #X_FLAG
79 longi on
80 endm
81
82 ; Resets the M and X bits making the accumulator, memory accesses and index
83 ; registers 16-bits wide.
84
85 long_ai macro
86 rep #M_FLAG|X_FLAG
87 longa on
88 longi on
89 endm
90
91 ; Sets the M bit making the accumulator and memory accesses 8-bits wide.
92
93 short_a macro
94 sep #M_FLAG
95 longa off
96 endm
97
98 ; Sets the X bit making the index registers 8-bits wide.
99
100 short_i macro
101 sep #X_FLAG
102 longi off
103 endm
104
105 ; Sets the M & X bits making the accumulator, memory accesses and index
106 ; registers 8-bits wide.
107
108 short_ai macro
109 sep #M_FLAG|X_FLAG
110 longa off
111 longi off
112 endm
47
48 ;===============================================================================
49 ; Macros
50 ;-------------------------------------------------------------------------------
51
52 ; The LINK macro deposits the link section of a word header automatically
53 ; linking the new word to the last.
54
55 00000000 WORDZ set 0 ; Word counter
56 00000000 WORD0 equ 0 ; Null address for first word
Sun May 8 2016 22:10 Page 4
57
58 LINK macro TYPE
59 dw WORD@<WORDZ> ; Link
60 db TYPE ; Type
61 WORDZ set WORDZ+1
62 WORD@<WORDZ>:
63 endm
64
65 ; Deposits a word header containing the name which is linked back to the
66 ; previous word.
67 ;
68 ; The WDC assembler does not handle string parameters to macros very well,
69 ; stopping at the first comma or space in them, so some headers must be
70 ; manually constructed.
71
72 00000000 NORMAL equ $00
73 00000080 IMMEDIATE equ $80
74
75 HEADER macro LEN,NAME,TYPE
76 LINK TYPE
77 db LEN,NAME
78 endm
79
80 ; The CONTINUE macro is used at the end of a native word to invoke the next
81 ; word pointer.
82
83 CONTINUE macro
84 tyx ; Copy IP to X
85 iny
86 iny
87 jmp (0,x) ; Then execute word
88 endm
89
90 TRAILER macro
91 LAST_WORD dw WORD@<WORDZ>
92 endm
93
94 ;===============================================================================
95 ; Definitions
96 ;-------------------------------------------------------------------------------
97
98 00000016 USER_SIZE equ 22
99 00000080 DSTACK_SIZE equ 128
100 00000080 RSTACK_SIZE equ 128
101
102 00000000 TO_IN_OFFSET equ 0
103 00000002 BASE_OFFSET equ 2
104 00000004 BLK_OFFSET equ 4
105 00000006 DP_OFFSET equ 6
106 00000008 LATEST_OFFSET equ 8
107 0000000A SCR_OFFSET equ 10
108 0000000C SOURCEID_OFFSET equ 12 ; Input source flag
109 0000000E STATE_OFFSET equ 14 ; Compiling/Interpreting flag
110 00000010 BUFFER_OFFSET equ 16 ; Address of the input buffer
111 00000012 LENGTH_OFFSET equ 18 ; Length of the input buffer
112 00000014 HP_OFFSET equ 20
113
114 00000080 TIB_SIZE equ 128
Sun May 8 2016 22:10 Page 5
115 00000030 PAD_SIZE equ 48
116
117 ;===============================================================================
118 ; Data Areas
119 ;-------------------------------------------------------------------------------
120
121 00000000 USER_AREA equ $0000 ; User variable area
122 00000016 TIB_AREA equ USER_AREA+USER_SIZE ; Terminal Input Buffer
123 00000096 PAD_AREA equ TIB_AREA+TIB_SIZE ; Scratch pad
124 000000C6 PAD_END equ PAD_AREA+PAD_SIZE
125
126 00000100 DSTACK_START equ $0100
127 00000180 DSTACK_END equ DSTACK_START+DSTACK_SIZE
128
129 00000180 RSTACK_START equ DSTACK_END
130 00000200 RSTACK_END equ RSTACK_START+RSTACK_SIZE
131
132 ;===============================================================================
133 ; Forth Entry Point
134 ;-------------------------------------------------------------------------------
135
136 code
137 public Start
138 extern NEXT_WORD
139 Start:
140 00:0000: 18 FB native ; Go to native mode
141 00:0002: C2 30 long_ai ; And all 16-bit registers
142 00:0004: A9 FF 01 lda #RSTACK_END-1 ; Initialise return stack
143 00:0007: 1B tcs
144 00:0008: A9 7F 01 lda #DSTACK_END-1 ; .. and data stack
145 00:000B: 5B tcd
146
147 00:000C: A0 xx xx ldy #COLD ; Then perform COLD start
148 00:000F: BB C8 C8 7C CONTINUE
00:0013: 00 00
149
150 COLD:
151 00:0015: xx xx dw DECIMAL
152 00:0017: xx xx dw ZERO
153 00:0019: xx xx dw BLK
154 00:001B: xx xx dw STORE
155 00:001D: xx xx dw FALSE
156 00:001F: xx xx dw STATE
157 00:0021: xx xx dw STORE
158 00:0023: xx xx xx xx dw DO_LITERAL,NEXT_WORD
159 00:0027: xx xx dw DP
160 00:0029: xx xx dw STORE
161 00:002B: xx xx xx xx dw DO_LITERAL,LAST_WORD
162 00:002F: xx xx dw FETCH
163 00:0031: xx xx dw LATEST
164 00:0033: xx xx dw STORE
165 00:0035: xx xx dw CR
166 00:0037: xx xx dw CR
167 00:0039: xx xx dw DO_TITLE
168 00:003B: xx xx dw TYPE
169 00:003D: xx xx dw CR
170 00:003F: xx xx dw CR
171 00:0041: xx xx dw ABORT
Sun May 8 2016 22:10 Page 6
172
173 ;===============================================================================
174 ; System/User Variables
175 ;-------------------------------------------------------------------------------
176
177 ; #TIB ( -- a-addr )
178 ;
179 ; a-addr is the address of a cell containing the number of characters in the
180 ; terminal input buffer.
181
182 00:0043: 00 00 00 04 HEADER 4,"#TIB",NORMAL
00:0047: 23 54 49 42
183 00:004B: 20 xx xx HASH_TIB: jsr DO_CONSTANT
184 00:004E: xx xx dw $+2
185 00:0050: 7E 00 dw TIB_SIZE-2
186
187 ; >IN ( -- a-addr )
188 ;
189 ; a-addr is the address of a cell containing the offset in characters from the
190 ; start of the input buffer to the start of the parse area.
191
192 00:0052: xx xx 00 03 HEADER 3,">IN",NORMAL
00:0056: 3E 49 4E
193 00:0059: 20 xx xx TO_IN: jsr DO_USER
194 00:005C: 00 00 dw TO_IN_OFFSET
195
196 ; BASE ( -- a-addr )
197 ;
198 ; a-addr is the address of a cell containing the current number-conversion
199 ; radix {{2...36}}.
200
201 00:005E: xx xx 00 04 HEADER 4,"BASE",NORMAL
00:0062: 42 41 53 45
202 00:0066: 20 xx xx BASE: jsr DO_USER
203 00:0069: 02 00 dw BASE_OFFSET
204
205 ; BLK ( -- a-addr )
206 ;
207 ; a-addr is the address of a cell containing zero or the number of the mass-
208 ; storage block being interpreted. If BLK contains zero, the input source is
209 ; not a block and can be identified by SOURCE-ID, if SOURCE-ID is available. An
210 ; ambiguous condition exists if a program directly alters the contents of BLK.
211
212 00:006B: xx xx 00 03 HEADER 3,"BLK",NORMAL
00:006F: 42 4C 4B
213 00:0072: 20 xx xx BLK: jsr DO_USER
214 00:0075: 04 00 dw BLK_OFFSET
215
216 ; (BUFFER)
217
218 00:0077: 20 xx xx BUFFER: jsr DO_USER
219 00:007A: 10 00 dw BUFFER_OFFSET
220
221 ; DP ( -- a-addr )
222 ;
223 ; Dictionary Pointer
224
225 00:007C: xx xx 00 02 HEADER 2,"DP",NORMAL
Sun May 8 2016 22:10 Page 7
00:0080: 44 50
226 00:0082: 20 xx xx DP: jsr DO_USER
227 00:0085: 06 00 dw DP_OFFSET
228
229 ; HP ( -- a-addr )
230 ;
231 ; Hold Pointer
232
233 00:0087: 20 xx xx HP: jsr DO_USER
234 00:008A: 14 00 dw HP_OFFSET
235
236 ; LATEST ( -- a-addr )
237
238 00:008C: xx xx 00 06 HEADER 6,"LATEST",NORMAL
00:0090: 4C 41 54 45
00:0094: 53 54
239 00:0096: 20 xx xx LATEST: jsr DO_USER
240 00:0099: 08 00 dw LATEST_OFFSET
241
242 ; (LENGTH)
243
244 00:009B: 20 xx xx LENGTH: jsr DO_USER
245 00:009E: 12 00 dw LENGTH_OFFSET
246
247 ; SCR ( -- a-addr )
248 ;
249 ; a-addr is the address of a cell containing the block number of the block most
250 ; recently LISTed.
251
252 00:00A0: xx xx 00 03 HEADER 3,"SCR",NORMAL
00:00A4: 53 43 52
253 00:00A7: 20 xx xx SCR: jsr DO_USER
254 00:00AA: 0A 00 dw SCR_OFFSET
255
256 ; (SOURCE-ID)
257
258 00:00AC: 20 xx xx SOURCEID: jsr DO_USER
259 00:00AF: 0C 00 dw SOURCEID_OFFSET
260
261 ; STATE ( -- a-addr )
262 ;
263 ; a-addr is the address of a cell containing the compilation-state flag. STATE
264 ; is true when in compilation state, false otherwise. The true value in STATE
265 ; is non-zero, but is otherwise implementation-defined.
266
267 00:00B1: xx xx 00 05 HEADER 5,"STATE",NORMAL
00:00B5: 53 54 41 54
00:00B9: 45
268 00:00BA: 20 xx xx STATE: jsr DO_USER
269 00:00BD: 0E 00 dw STATE_OFFSET
270
271 ; TIB ( -- c-addr )
272 ;
273 ; c-addr is the address of the terminal input buffer.
274
275 00:00BF: xx xx 00 03 HEADER 3,"TIB",NORMAL
00:00C3: 54 49 42
276 00:00C6: 20 xx xx TIB: jsr DO_CONSTANT
Sun May 8 2016 22:10 Page 8
277 00:00C9: 16 00 dw TIB_AREA
278
279 ;===============================================================================
280 ; Constants
281 ;-------------------------------------------------------------------------------
282
283 ; 0 ( -- 0 )
284 ;
285 ; Push the constant value zero on the stack
286
287 00:00CB: xx xx 00 01 HEADER 1,"0",NORMAL
00:00CF: 30
288 ZERO:
289 00:00D0: 7B tdc
290 00:00D1: 3A dec a ; Make space on the stack
291 00:00D2: 3A dec a
292 00:00D3: 5B tcd
293 00:00D4: 64 01 stz <1 ; And create a zero value
294 00:00D6: BB C8 C8 7C CONTINUE ; Done
00:00DA: 00 00
295
296 ; BL ( -- char )
297 ;
298 ; char is the character value for a space.
299
300 00:00DC: xx xx 00 02 HEADER 2,"BL",NORMAL
00:00E0: 42 4C
301 BL:
302 00:00E2: 7B tdc
303 00:00E3: 3A dec a ; Make space on the stack
304 00:00E4: 3A dec a
305 00:00E5: 5B tcd
306 00:00E6: A9 20 00 lda #' ' ; And save a space value
307 00:00E9: 85 01 sta <1
308 00:00EB: BB C8 C8 7C CONTINUE ; Done
00:00EF: 00 00
309
310 ; FALSE ( -- false )
311 ;
312 ; Return a false flag.
313
314 00:00F1: xx xx 00 05 HEADER 5,"FALSE",NORMAL
00:00F5: 46 41 4C 53
00:00F9: 45
315 FALSE:
316 00:00FA: 7B tdc
317 00:00FB: 3A dec a ; Make space on the stack
318 00:00FC: 3A dec a
319 00:00FD: 5B tcd
320 00:00FE: 64 01 stz <1 ; And create a false value
321 00:0100: BB C8 C8 7C CONTINUE ; Done
00:0104: 00 00
322
323 ; TRUE ( -- true )
324 ;
325 ; Return a true flag, a single-cell value with all bits set.
326
327 00:0106: xx xx 00 04 HEADER 4,"TRUE",NORMAL
Sun May 8 2016 22:10 Page 9
00:010A: 54 52 55 45
328 TRUE:
329 00:010E: 7B tdc
330 00:010F: 3A dec a ; Make space on the stack
331 00:0110: 3A dec a
332 00:0111: 5B tcd
333 00:0112: 64 01 stz <1 ; And create a true value
334 00:0114: C6 01 dec <1
335 00:0116: BB C8 C8 7C CONTINUE ; Done
00:011A: 00 00
336
337 ;===============================================================================
338 ; Radix
339 ;-------------------------------------------------------------------------------
340
341 ; DECIMAL ( -- )
342 ;
343 ; Set the numeric conversion radix to ten (decimal).
344
345 00:011C: xx xx 00 07 HEADER 7,"DECIMAL",NORMAL
00:0120: 44 45 43 49
00:0124: 4D 41 4C
346 00:0127: 20 xx xx DECIMAL: jsr DO_COLON
347 00:012A: xx xx 0A 00 dw DO_LITERAL,10
348 00:012E: xx xx dw BASE
349 00:0130: xx xx dw STORE
350 00:0132: xx xx dw EXIT
351
352 ; HEX ( -- )
353 ;
354 ; Set contents of BASE to sixteen.
355
356 00:0134: xx xx 00 03 HEADER 3,"HEX",NORMAL
00:0138: 48 45 58
357 00:013B: 20 xx xx HEX: jsr DO_COLON
358 00:013E: xx xx 10 00 dw DO_LITERAL,16
359 00:0142: xx xx dw BASE
360 00:0144: xx xx dw STORE
361 00:0146: xx xx dw EXIT
362
363 ;===============================================================================
364 ; Memory Operations
365 ;-------------------------------------------------------------------------------
366
367 ; ! ( x a-addr -- )
368 ;
369 ; Store x at a-addr.
370
371 00:0148: xx xx 00 01 HEADER 1,"!",NORMAL
00:014C: 21
372 STORE:
373 00:014D: A5 03 lda <3 ; Fetch data value
374 00:014F: 92 01 sta (1) ; .. and store
375 00:0151: 7B tdc ; Clean up data stack
376 00:0152: 1A inc a
377 00:0153: 1A inc a
378 00:0154: 1A inc a
379 00:0155: 1A inc a
Sun May 8 2016 22:10 Page 10
380 00:0156: 5B tcd
381 00:0157: BB C8 C8 7C CONTINUE ; Done
00:015B: 00 00
382
383 ; +! ( n|u a-addr -- )
384 ;
385 ; Add n|u to the single-cell number at a-addr.
386
387 00:015D: xx xx 00 02 HEADER 2,"+!",NORMAL
00:0161: 2B 21
388 PLUS_STORE:
389 00:0163: 18 clc
390 00:0164: A5 03 lda <3 ; Fetch data value
391 00:0166: 72 01 adc (1)
392 00:0168: 92 01 sta (1)
393 00:016A: 7B tdc ; Clean up data stack
394 00:016B: 1A inc a
395 00:016C: 1A inc a
396 00:016D: 1A inc a
397 00:016E: 1A inc a
398 00:016F: 5B tcd
399 00:0170: BB C8 C8 7C CONTINUE ; Done
00:0174: 00 00
400
401 ; , ( x -- )
402 ;
403 ; Reserve one cell of data space and store x in the cell. If the data-space
404 ; pointer is aligned when , begins execution, it will remain aligned when ,
405 ; finishes execution. An ambiguous condition exists if the data-space pointer
406 ; is not aligned prior to execution of ,.
407 ;
408 ; In this implementation is its defined as:
409 ;
410 ; HERE ! 1 CELLS ALLOT
411
412 00:0176: xx xx 00 LINK NORMAL
413 00:0179: 01 2C db 1,","
414 00:017B: 20 xx xx COMMA: jsr DO_COLON
415 00:017E: xx xx dw HERE
416 00:0180: xx xx dw STORE
417 00:0182: xx xx 01 00 dw DO_LITERAL,1
418 00:0186: xx xx dw CELLS
419 00:0188: xx xx dw ALLOT
420 00:018A: xx xx dw EXIT
421
422 ; 2! ( x1 x2 a-addr -- )
423 ;
424 ; Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the next
425 ; consecutive cell.
426 ;
427 ; In this implementation is its defined as:
428 ;
429 ; SWAP OVER ! CELL+ !.
430
431 00:018C: xx xx 00 02 HEADER 2,"2!",NORMAL
00:0190: 32 21
432 00:0192: 20 xx xx TWO_STORE: jsr DO_COLON
433 00:0195: xx xx dw SWAP
Sun May 8 2016 22:10 Page 11
434 00:0197: xx xx dw OVER
435 00:0199: xx xx dw STORE
436 00:019B: xx xx dw CELL_PLUS
437 00:019D: xx xx dw STORE
438 00:019F: xx xx dw EXIT
439
440 ; 2@ ( a-addr -- x1 x2 )
441 ;
442 ; Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and x1 at
443 ; the next consecutive cell.
444 ;
445 ; In this implementation is its defined as:
446 ;
447 ; DUP CELL+ @ SWAP @
448
449 00:01A1: xx xx 00 02 HEADER 2,"2@",NORMAL
00:01A5: 32 40
450 00:01A7: 20 xx xx TWO_FETCH: jsr DO_COLON
451 00:01AA: xx xx dw DUP
452 00:01AC: xx xx dw CELL_PLUS
453 00:01AE: xx xx dw FETCH
454 00:01B0: xx xx dw SWAP
455 00:01B2: xx xx dw FETCH
456 00:01B4: xx xx dw EXIT
457
458 ; @ ( a-addr -- x )
459 ;
460 ; x is the value stored at a-addr.
461
462 00:01B6: xx xx 00 01 HEADER 1,"@",NORMAL
00:01BA: 40
463 FETCH:
464 00:01BB: B2 01 lda (1) ; Fetch from memory
465 00:01BD: 85 01 sta <1 ; .. and replace top value
466 00:01BF: BB C8 C8 7C CONTINUE ; Done
00:01C3: 00 00
467
468 ; ALLOT ( n -- )
469 ;
470 ; If n is greater than zero, reserve n address units of data space. If n is
471 ; less than zero, release |n| address units of data space. If n is zero, leave
472 ; the data-space pointer unchanged.
473 ;
474 ; In this implementation its is defined as:
475 ;
476 ; DP +!
477
478 00:01C5: xx xx 00 05 HEADER 5,"ALLOT",NORMAL
00:01C9: 41 4C 4C 4F
00:01CD: 54
479 00:01CE: 20 xx xx ALLOT: jsr DO_COLON
480 00:01D1: xx xx dw DP
481 00:01D3: xx xx dw PLUS_STORE
482 00:01D5: xx xx dw EXIT
483
484 ; C! ( char c-addr -- )
485 ;
486 ; Store char at c-addr. When character size is smaller than cell size, only the
Sun May 8 2016 22:10 Page 12
487 ; number of low-order bits corresponding to character size are transferred.
488
489 00:01D7: xx xx 00 02 HEADER 2,"C!",NORMAL
00:01DB: 43 21
490 C_STORE:
491 00:01DD: A5 03 lda <3 ; Fetch the data value
492 00:01DF: E2 20 short_a
493 00:01E1: 92 01 sta (1) ; And store it
494 00:01E3: C2 20 long_a
495 00:01E5: 7B tdc ; Clean up the stack
496 00:01E6: 1A inc a
497 00:01E7: 1A inc a
498 00:01E8: 1A inc a
499 00:01E9: 1A inc a
500 00:01EA: 5B tcd
501 00:01EB: BB C8 C8 7C CONTINUE ; Done
00:01EF: 00 00
502
503 ; C, ( char -- )
504 ;
505 ; Reserve space for one character in the data space and store char in the
506 ; space. If the data-space pointer is character aligned when C, begins
507 ; execution, it will remain character aligned when C, finishes execution.
508 ; An ambiguous condition exists if the data-space pointer is not character-
509 ; aligned prior to execution of C,
510 ;
511 ; HERE C! 1 CHARS ALLOT
512
513 00:01F1: xx xx 00 LINK NORMAL
514 00:01F4: 02 43 2C db 2,"C,"
515 00:01F7: 20 xx xx C_COMMA: jsr DO_COLON
516 00:01FA: xx xx dw HERE
517 00:01FC: xx xx dw C_STORE
518 00:01FE: xx xx 01 00 dw DO_LITERAL,1
519 00:0202: xx xx dw CHARS
520 00:0204: xx xx dw ALLOT
521 00:0206: xx xx dw EXIT
522
523 ; C@ ( c-addr -- char )
524 ;
525 ; Fetch the character stored at c-addr. When the cell size is greater than
526 ; character size, the unused high-order bits are all zeroes.
527
528 00:0208: xx xx 00 02 HEADER 2,"C@",NORMAL
00:020C: 43 40
529 C_FETCH:
530 00:020E: E2 20 short_a
531 00:0210: B2 01 lda (1) ; Fetch the data byte
532 00:0212: 85 01 sta <1 ; .. and replace stack value
533 00:0214: 64 02 stz <2
534 00:0216: C2 20 long_a
535 00:0218: BB C8 C8 7C CONTINUE ; Done
00:021C: 00 00
536
537 ; HERE ( -- addr )
538 ;
539 ; addr is the data-space pointer.
540
Sun May 8 2016 22:10 Page 13
541 00:021E: xx xx 00 04 HEADER 4,"HERE",NORMAL
00:0222: 48 45 52 45
542 00:0226: 20 xx xx HERE: jsr DO_COLON
543 00:0229: xx xx dw DP
544 00:022B: xx xx dw FETCH
545 00:022D: xx xx dw EXIT
546
547 ;===============================================================================
548 ; Alignment
549 ;-------------------------------------------------------------------------------
550
551 ; ALIGN ( -- )
552 ;
553 ; If the data-space pointer is not aligned, reserve enough space to align it.
554
555 00:022F: xx xx 00 05 HEADER 5,"ALIGN",NORMAL
00:0233: 41 4C 49 47
00:0237: 4E
556 ALIGN:
557 00:0238: BB C8 C8 7C CONTINUE ; Done
00:023C: 00 00
558
559 ; ALIGNED ( addr -- a-addr )
560 ;
561 ; a-addr is the first aligned address greater than or equal to addr.
562
563 00:023E: xx xx 00 07 HEADER 7,"ALIGNED",NORMAL
00:0242: 41 4C 49 47
00:0246: 4E 45 44
564 ALIGNED:
565 00:0249: BB C8 C8 7C CONTINUE ; Done
00:024D: 00 00
566
567 ; CELL+ ( a-addr1 -- a-addr2 )
568 ;
569 ; Add the size in address units of a cell to a-addr1, giving a-addr2.
570
571 00:024F: xx xx 00 05 HEADER 5,"CELL+",NORMAL
00:0253: 43 45 4C 4C
00:0257: 2B
572 CELL_PLUS:
573 00:0258: E6 01 inc <1 ; Bump the address by two
574 00:025A: E6 01 inc <1
575 00:025C: BB C8 C8 7C CONTINUE ; Done
00:0260: 00 00
576
577 ; CELLS ( n1 -- n2 )
578 ;
579 ; n2 is the size in address units of n1 cells.
580
581 00:0262: xx xx 00 05 HEADER 5,"CELLS",NORMAL
00:0266: 43 45 4C 4C
00:026A: 53
582 CELLS:
583 00:026B: 06 01 asl <1 ; Two bytes per cell
584 00:026D: BB C8 C8 7C CONTINUE ; Done
00:0271: 00 00
585
Sun May 8 2016 22:10 Page 14
586 ; CHAR+ ( c-addr1 -- c-addr2 )
587 ;
588 ; Add the size in address units of a character to c-addr1, giving c-addr2.
589
590 00:0273: xx xx 00 05 HEADER 5,"CHAR+",NORMAL
00:0277: 43 48 41 52
00:027B: 2B
591 CHAR_PLUS:
592 00:027C: E6 01 inc <1 ; Bump the address by one
593 00:027E: BB C8 C8 7C CONTINUE ; Done
00:0282: 00 00
594
595 ; CHAR- ( c-addr1 -- c-addr2 )
596 ;
597 ; Subtract the size in address units of a character to c-addr1, giving c-addr2.
598
599 00:0284: xx xx 00 05 HEADER 5,"CHAR-",NORMAL
00:0288: 43 48 41 52
00:028C: 2D
600 CHAR_MINUS:
601 00:028D: C6 01 dec <1
602 00:028F: BB C8 C8 7C CONTINUE ; Done
00:0293: 00 00
603
604 ; CHARS ( n1 -- n2 )
605 ;
606 ; n2 is the size in address units of n1 characters.
607
608 00:0295: xx xx 00 05 HEADER 5,"CHARS",NORMAL
00:0299: 43 48 41 52
00:029D: 53
609 CHARS:
610 00:029E: BB C8 C8 7C CONTINUE ; Done
00:02A2: 00 00
611
612 ;===============================================================================
613 ; Stack Operations
614 ;-------------------------------------------------------------------------------
615
616 ; 2DROP ( x1 x2 -- )
617 ;
618 ; Drop cell pair x1 x2 from the stack.
619
620 00:02A4: xx xx 00 05 HEADER 5,"2DROP",NORMAL
00:02A8: 32 44 52 4F
00:02AC: 50
621 TWO_DROP:
622 00:02AD: 7B tdc ; Removed two words from stack
623 00:02AE: 1A inc a
624 00:02AF: 1A inc a
625 00:02B0: 1A inc a
626 00:02B1: 1A inc a
627 00:02B2: 5B tcd
628 00:02B3: BB C8 C8 7C CONTINUE ; Done
00:02B7: 00 00
629
630 ; 2DUP ( x1 x2 -- x1 x2 x1 x2 )
631 ;
Sun May 8 2016 22:10 Page 15
632 ; Duplicate cell pair x1 x2.
633
634 00:02B9: xx xx 00 04 HEADER 4,"2DUP",NORMAL
00:02BD: 32 44 55 50
635 TWO_DUP:
636 00:02C1: 7B tdc ; Make space for new value
637 00:02C2: 3A dec a
638 00:02C3: 3A dec a
639 00:02C4: 3A dec a
640 00:02C5: 3A dec a
641 00:02C6: 5B tcd
642 00:02C7: A5 05 lda <5 ; Copy top two values
643 00:02C9: 85 01 sta <1
644 00:02CB: A5 07 lda <7
645 00:02CD: 85 03 sta <3
646 00:02CF: BB C8 C8 7C CONTINUE ; Done
00:02D3: 00 00
647
648 ; 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )
649 ;
650 ; Copy cell pair x1 x2 to the top of the stack.
651
652 00:02D5: xx xx 00 05 HEADER 5,"2OVER",NORMAL
00:02D9: 32 4F 56 45
00:02DD: 52
653 TWO_OVER:
654 00:02DE: 7B tdc ; Make space for new value
655 00:02DF: 3A dec a
656 00:02E0: 3A dec a
657 00:02E1: 3A dec a
658 00:02E2: 3A dec a
659 00:02E3: 5B tcd
660 00:02E4: A5 09 lda <9 ; Ciopy top two values
661 00:02E6: 85 01 sta <1
662 00:02E8: A5 0B lda <11
663 00:02EA: 85 03 sta <3
664 00:02EC: BB C8 C8 7C CONTINUE ; Done
00:02F0: 00 00
665
666 ; 2ROT ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )
667 ;
668 ; Rotate the top three cell pairs on the stack bringing cell pair x1 x2 to
669 ; the top of the stack.
670
671 00:02F2: xx xx 00 04 HEADER 4,"2ROT",NORMAL
00:02F6: 32 52 4F 54
672 00:02FA: 20 xx xx TWO_ROT: jsr DO_COLON
673 00:02FD: A5 0B lda <11 ; Save x1
674 00:02FF: 48 pha
675 00:0300: A5 09 lda <9 ; Save x2
676 00:0302: 48 pha
677 00:0303: A5 07 lda <7 ; Move x3
678 00:0305: 85 0B sta <11
679 00:0307: A5 05 lda <5 ; Move x4
680 00:0309: 85 09 sta <9
681 00:030B: A5 03 lda <3 ; Move x5
682 00:030D: 85 07 sta <7
683 00:030F: A5 01 lda <1 ; Move x6
Sun May 8 2016 22:10 Page 16
684 00:0311: 85 05 sta <5
685 00:0313: 68 pla ; Restore x2
686 00:0314: 85 01 sta <1
687 00:0316: 68 pla ; Restore x1
688 00:0317: 85 03 sta <3
689 00:0319: BB C8 C8 7C CONTINUE ; Done
00:031D: 00 00
690
691 ; 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 )
692 ;
693 ; Exchange the top two cell pairs.
694
695 00:031F: xx xx 00 05 HEADER 5,"2SWAP",NORMAL
00:0323: 32 53 57 41
00:0327: 50
696 TWO_SWAP:
697 00:0328: A5 03 lda <3 ; Save x3
698 00:032A: 48 pha
699 00:032B: A5 01 lda <1 ; Save x4
700 00:032D: 48 pha
701 00:032E: A5 07 lda <7 ; Move x1
702 00:0330: 85 03 sta <3
703 00:0332: A5 05 lda <5 ; Move x2
704 00:0334: 85 01 sta <1
705 00:0336: 68 pla ; Move x4
706 00:0337: 85 05 sta <5
707 00:0339: 68 pla ; Move x3
708 00:033A: 85 07 sta <7
709 00:033C: BB C8 C8 7C CONTINUE ; Done
00:0340: 00 00
710
711 ; ?DUP ( x -- 0 | x x )
712 ;
713 ; Duplicate x if it is non-zero.
714
715 00:0342: xx xx 00 04 HEADER 4,"?DUP",NORMAL
00:0346: 3F 44 55 50
716 QUERY_DUP:
717 00:034A: A5 01 lda <1 ; Fetch top value
718 00:034C: D0 39 bne DUP ; Non-zero value?
719 00:034E: BB C8 C8 7C CONTINUE ; Done
00:0352: 00 00
720
721 ; DEPTH ( -- +n )
722 ;
723 ; +n is the number of single-cell values contained in the data stack before +n
724 ; was placed on the stack.
725
726 00:0354: xx xx 00 05 HEADER 5,"DEPTH",NORMAL
00:0358: 44 45 50 54
00:035C: 48
727 00:035D: 20 xx xx DEPTH: jsr DO_COLON
728 00:0360: xx xx dw AT_DP
729 00:0362: xx xx 7F 01 dw DO_LITERAL,DSTACK_END-1
730 00:0366: xx xx dw SWAP
731 00:0368: xx xx dw MINUS
732 00:036A: xx xx dw TWO_SLASH
733 00:036C: xx xx dw EXIT
Sun May 8 2016 22:10 Page 17
734
735 ; DROP ( x -- )
736 ;
737 ; Remove x from the stack.
738
739 00:036E: xx xx 00 04 HEADER 4,"DROP",NORMAL
00:0372: 44 52 4F 50
740 DROP:
741 00:0376: 7B tdc ; Drop the top value
742 00:0377: 1A inc a
743 00:0378: 1A inc a
744 00:0379: 5B tcd
745 00:037A: BB C8 C8 7C CONTINUE ; Done
00:037E: 00 00
746
747 ; DUP ( x -- x x )
748 ;
749 ; Duplicate x.
750
751 00:0380: xx xx 00 03 HEADER 3,"DUP",NORMAL
00:0384: 44 55 50