-
Notifications
You must be signed in to change notification settings - Fork 0
/
camel16.lst
2659 lines (2659 loc) · 126 KB
/
camel16.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
0000 1 ; Listing 2.
0000 2 ; ===============================================
0000 3 ; CamelForth for the Mojang DCPU-16 (http://0x10c.com)
0000 4 ; Copyright (c) 2012 Helge Horch
0000 5 ; CamelForth for the Zilog Z80
0000 6 ; Copyright (c) 1994,1995 Bradford J. Rodriguez
0000 7 ;
0000 8 ; This program is free software; you can redistribute it and/or modify
0000 9 ; it under the terms of the GNU General Public License as published by
0000 10 ; the Free Software Foundation; either version 3 of the License, or
0000 11 ; (at your option) any later version.
0000 12 ;
0000 13 ; This program is distributed in the hope that it will be useful,
0000 14 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
0000 15 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
0000 16 ; GNU General Public License for more details.
0000 17 ;
0000 18 ; You should have received a copy of the GNU General Public License
0000 19 ; along with this program. If not, see <http://www.gnu.org/licenses/>.
0000 20
0000 21 ; Commercial inquiries should be directed to the author at
0000 22 ; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
0000 23 ; or via email to bj@camelforth.com
0000 24 ;
0000 25 ; ===============================================
0000 26 ; CAMEL16.S: Code Primitives
0000 27 ; Source code is for the ASM assembler.
0000 28 ; Forth words are documented as follows:
0000 29 ;x NAME stack -- stack description
0000 30 ; where x=C for ANS Forth Core words, X for ANS
0000 31 ; Extensions, Z for internal or private words.
0000 32 ;
0000 33 ; Direct-Threaded Forth model for DCPU-16
0000 34 ; 16 bit cell, 16 bit char, 16 bit (word) adrs unit
0000 35 ; DCPU-16 B = Forth TOS (top Param Stack item)
0000 36 ; C = W working register
0000 37 ; Z = IP Interpreter Pointer
0000 38 ; SP = PSP Param Stack Pointer
0000 39 ; X = RSP Return Stack Pointer
0000 40 ; Y = UP User area Pointer
0000 41 ; A, I, J = temporaries
0000 42 ;
0000 43 ; Revision history:
0000 44 ; 07 Apr 12 v0.1 cloned from Z80 CamelForth
0000 45 ; ===============================================
0000 46 ; Macros to define Forth headers
0000 47 ; HEAD label,name,action
0000 48 ; IMMED label,name,action
0000 49 ; label = assembler name for this word
0000 50 ; (special characters not allowed)
0000 51 ; name = Forth's name for this word
0000 52 ; action = code routine for this word, e.g.
0000 53 ; DOCOLON, or DOCODE for code words
0000 54 ; IMMED defines a header for an IMMEDIATE word.
0000 55 ;
0000 56 ;head MACRO #label,#name,#action
0000 57 ; DAT link
0000 58 ; DAT 0
0000 59 ;link DEFL $
0000 60 ; DAT #length(#name),#name
0000 61 ;#label:
0000 62 ; IF .NOT.(#action=DOCODE)
0000 63 ; jsr #action
0000 64 ; ENDIF
0000 65 ; ENDM
0000 66 ;
0000 67 ;immed MACRO #label,#name,#action
0000 68 ; DAT link
0000 69 ; DAT 1
0000 70 ;link DEFL $
0000 71 ; DB #length(#name),#name
0000 72 ;#label:
0000 73 ; IF .NOT.(#action=DOCODE)
0000 74 ; jsr #action
0000 75 ; ENDIF
0000 76 ; ENDM
0000 77 ;
0000 78 ; The NEXT macro (3 words) assembles the 'next'
0000 79 ; code in-line in every Z80 CamelForth CODE word.
0000 80 ;next MACRO
0000 81 ; set a,[z] ;
0000 82 ; add z,1 ;
0000 83 ; set pc,a ;
0000 84 ; ENDM
0000 85 ;
0000 86 ; ENTRY POINT ===================================
0000 87 ; all registers zeroed, 64K words available
0000 8540 88 :reset ias 0 ; interrupts off
0001 7c20 0087 89 jsr hwdetect ; detect screen and keyboard
0003 7c20 0097 90 jsr hwinit
0005 7c81 fc00 91 set y,0xfc00 ; UP
0007 7c61 ff00 92 set x,0xff00 ; RP
0009 7f81 0deb 93 set pc,cold ; enter top-level Forth word
000b 8761 94 set sp,0
000c 8421 95 set b,0
000d 7f81 0000 96 set pc,reset ; loop if COLD returns
000f 97
000f 98 ; Memory map:
000f 99 ; 0x0000.. Forth kernel and user dictionary
000f 100 ; 0xfc00..0xfc7f User area, 128 words
000f 101 ; 0xfc80..0xfcff Terminal Input Buffer, 128 words
000f 102 ; 0xfd00..0xfdff HOLD area, PAD buffer, L stack, 256 words (40+88+128)
000f 103 ; 0xfe00..0xfeff Return stack, 256 words
000f 104 ; 0xff00..0xffff Parameter stack, 256 words
000f 105 ;
000f 106 ; See also the definitions of U0, S0, and R0
000f 107 ; in the "system variables & constants" area.
000f 108 ; A task (user area) requires 0x400 words.
000f 109
000f 110 ; INTERPRETER LOGIC =============================
000f 111 ; See also "defining words" at end of this file
000f 112
000f 113 ;C EXIT -- exit a colon definition
000f 0000 0000 0004 114 head EXIT,"EXIT",docode
0012 0045 0058 0049 114
0015 0054 114
0016 2ca1 115 set z,[x] ; pop old IP from ret stk
0017 8862 116 add x,1
0018 3401 88a2 0381 117 :anext next
001b 118
001b 119 ;Z lit -- x fetch inline literal to stack
001b 120 ; This is the primitive compiled by LITERAL.
001b 0011 0000 0003 121 head lit,"lit",docode
001e 006c 0069 0074 121
0021 0701 122 set push,b ; push old TOS
0022 3421 123 set b,[z] ; fetch cell at IP to TOS,
0023 88a2 124 add z,1 ; advancing IP
0024 3401 88a2 0381 125 next
0027 126
0027 127 ;C EXECUTE i*x xt -- j*x execute Forth word
0027 128 ;C at 'xt'
0027 001d 0000 0007 129 head EXECUTE,"EXECUTE",docode
002a 0045 0058 0045 129
002d 0043 0055 0054 129
0030 0045 129
0031 0401 130 set a,b ; address of word
0032 6021 131 set b,pop ; get new TOS
0033 0381 132 set pc,a ; go do Forth word
0034 133
0034 134 ; DEFINING WORDS ================================
0034 135
0034 136 ; ENTER, a.k.a. DOCOLON, entered by CALL ENTER
0034 137 ; to enter a new high-level thread (colon def'n.)
0034 138 ; (internal code fragment, not a Forth word)
0034 139 ; N.B.: DOCOLON must be defined before any
0034 140 ; appearance of 'docolon' in a 'word' macro!
0034 141 :docolon ; (alternate name)
0034 8863 142 :enter sub x,1 ; push old IP on ret stack
0035 1561 143 set [x],z
0036 60a1 144 set z,pop ; param field adrs -> IP
0037 3401 88a2 0381 145 next
003a 146
003a 147 ;C VARIABLE -- define a Forth variable
003a 148 ; CREATE 1 CELLS ALLOT ;
003a 149 ; Action of RAM variable is identical to CREATE,
003a 150 ; so we don't need a DOES> clause to change it.
003a 0029 0000 0008 151 head VARIABLE,"VARIABLE",docolon
003d 0056 0041 0052 151
0040 0049 0041 0042 151
0043 004c 0045 7c20 151
0046 0034 151
0047 0ba3 0021 0001 152 DW CREATE,LIT,1,CELLS,ALLOT,EXIT
004a 04ee 093a 0016 152
004d 153 ; DOVAR, code action of VARIABLE, entered by CALL
004d 154 ; DOCREATE, code action of newly created words
004d 155 :docreate
004d 156 :dovar ; -- a-addr
004d 6001 157 set a,pop ; parameter field address
004e 0701 158 set push,b ; push old TOS
004f 0021 159 set b,a ; pfa = variable's adrs -> TOS
0050 3401 88a2 0381 160 next
0053 161
0053 162 ;C CONSTANT n -- define a Forth constant
0053 163 ; CREATE , DOES> (machine code fragment)
0053 003c 0000 0008 164 head CONSTANT,"CONSTANT",docolon
0056 0043 004f 004e 164
0059 0053 0054 0041 164
005c 004e 0054 7c20 164
005f 0034 164
0060 0ba3 0943 0bc1 165 DW CREATE,COMMA,XDOES
0063 166 ; DOCON, code action of CONSTANT,
0063 167 ; entered by CALL DOCON
0063 168 :docon ; -- x
0063 6001 169 set a,pop ; parameter field address
0064 0701 170 set push,b ; push old TOS
0065 2021 171 set b,[a] ; fetch contents of parameter field -> TOS
0066 3401 88a2 0381 172 next
0069 173
0069 174 ;Z USER n -- define user variable 'n'
0069 175 ; CREATE , DOES> (machine code fragment)
0069 0055 0000 0004 176 head USER,"USER",docolon
006c 0055 0053 0045 176
006f 0052 7c20 0034 176
0072 0ba3 0943 0bc1 177 DW CREATE,COMMA,XDOES
0075 178 ; DOUSER, code action of USER,
0075 179 ; entered by CALL DOUSER
0075 180 :douser ; -- a-addr
0075 6001 181 set a,pop ; parameter field address
0076 0701 182 set push,b ; push old TOS
0077 2021 183 set b,[a] ; fetch contents of parameter field (the offset)
0078 1022 184 add b,y ; add user base address
0079 3401 88a2 0381 185 next
007c 186
007c 187 ; DODOES, code action of DOES> clause
007c 188 ; entered by CALL fragment
007c 189 ; parameter field
007c 190 ; ...
007c 191 ; fragment: CALL DODOES
007c 192 ; high-level thread
007c 193 ; Enters high-level thread with address of
007c 194 ; parameter field on top of stack.
007c 195 ; (internal code fragment, not a Forth word)
007c 196 :dodoes ; -- a-addr
007c 8863 197 sub x,1 ; push old IP on ret stk
007d 1561 198 set [x],z
007e 60a1 199 set z,pop ; adrs of new thread -> IP
007f 6001 200 set a,pop ; adrs of parameter field
0080 0701 201 set push,b ; push old TOS onto stack
0081 0021 202 set b,a ; pfa -> new TOS
0082 3401 88a2 0381 203 next
0085 204
0085 205 ; TERMINAL I/O =============================
0085 206
0085 0000 207 :hwmon dat 0 ; monitor device number
0086 0000 208 :hwkbd dat 0 ; keyboard device number
0087 209
0087 210 :hwdetect
0087 1e00 211 hwn j ; query #devices
0088 84c1 212 set i,0
0089 1cd2 213 :hwloop ife i,j ; so scan 0..n-1
008a 6381 214 set pc,pop ; return if done
008b 1a20 215 hwq i
008c 7c32 7349 216 ife b,0x7349 ; LEM1802?
008e 1bc1 0085 217 set [hwmon],i
0090 7c32 30cf 218 ife b,0x30cf ; keyboard?
0092 1bc1 0086 219 set [hwkbd],i
0094 88c2 220 add i,1
0095 7f81 0089 221 set pc,hwloop
0097 222
0097 7821 00b3 223 :hwinit set b,[vrama]
0099 8401 224 set a,0 ; MEM_MAP_SCREEN
009a 7a40 0085 225 hwi [hwmon]
009c 226 ; set b,0
009c 227 ; set a,1 ; MEM_MAP_FONT: built-in
009c 228 ; hwi [hwmon]
009c 229 ; set a,2 ; MEM_MAP_PALETTE: built-in
009c 230 ; hwi [hwmon]
009c 9001 231 set a,3 ; SET_BORDER_COLOR
009d 7821 00df 232 set b,[colora]
009f a42d 233 shr b,8
00a0 7a40 0085 234 hwi [hwmon]
00a2 8421 235 set b,0 ; turn off kbd interrupts
00a3 9001 236 set a,3
00a4 7a40 0086 237 hwi [hwkbd]
00a6 8401 238 set a,0 ; clear keyboard buffer
00a7 7a40 0086 239 hwi [hwkbd]
00a9 6381 240 set pc,pop
00aa 241
00aa 242 ;Z VRAM -- addr video RAM start
00aa 006b 0000 0004 243 head vram,"VRAM",docon
00ad 0056 0052 0041 243
00b0 004d 7c20 0063 243
00b3 8000 244 :vrama DW 0x8000
00b4 245
00b4 246 ;Z VLEN -- u video RAM extent (words)
00b4 00ac 0000 0004 247 head vlen,"VLEN",docon
00b7 0056 004c 0045 247
00ba 004e 7c20 0063 247
00bd 0180 248 :vlena DW 384
00be 249
00be 250 ;Z VCOLS -- u video line length
00be 00b6 0000 0005 251 head vcols,"VCOLS",docon
00c1 0056 0043 004f 251
00c4 004c 0053 7c20 251
00c7 0063 251
00c8 0020 252 DW 32
00c9 253
00c9 254 ;Z CURSOR -- addr cursor offset on screen (next char)
00c9 00c0 0000 0006 255 head cursor,"CURSOR",dovar
00cc 0043 0055 0052 255
00cf 0053 004f 0052 255
00d2 7c20 004d 255
00d4 0000 256 :cursora DW 0
00d5 257
00d5 258 ;Z COLOR -- addr color mask applied to chars
00d5 00cb 0000 0005 259 head color,"COLOR",dovar
00d8 0043 004f 004c 259
00db 004f 0052 7c20 259
00de 004d 259
00df a200 260 :colora DW 0xa200 ; green on green
00e0 261
00e0 262 ;Z UNBLINK -- u store non-blinking blank at cursor
00e0 00d7 0000 0007 263 head UNBLINK,"UNBLINK",docolon
00e3 0055 004e 0042 263
00e6 004c 0049 004e 263
00e9 004b 7c20 0034 263
00ec 00d2 0276 00b1 264 DW cursor, fetch, vram, over, plus ; ( ofs a)
00ef 01e6 0287 264
00f1 00dd 0276 0583 265 DW color, fetch, bl, plus, swop, store ; ( ofs)
00f4 0287 01d9 0261 265
00f7 0016 266 DW exit
00f8 267
00f8 268 ;C EMIT c -- output character to console
00f8 00e2 0000 0004 269 head EMIT,"EMIT",docolon
00fb 0045 004d 0049 269
00fe 0054 7c20 0034 269
0101 0021 0008 01e6 270 DW lit, 8, over, equal, qbranch, notbs
0104 034e 039b 0111 270
0107 01ce 00ea 02e7 271 DW drop, unblink, oneminus
010a 0021 0000 071f 272 DW lit, 0, max, cursor, store
010d 00d2 0261 272
010f 038d 0124 273 DW branch, blink
0111 00dd 0276 0287 274 :notbs DW color, fetch, plus ; ( c)
0114 00d2 0276 00b1 275 DW cursor, fetch, vram, plus, store ; ( )
0117 0287 0261 275
0119 00d2 0276 01b7 276 DW cursor, fetch, dup, vlen, oneminus, uless ; ( ofs f)
011c 00bb 02e7 0375 276
011f 039b 0137 277 DW qbranch, cr1
0121 02de 00d2 0261 278 DW oneplus, cursor, store ; ( )
0124 00dd 0276 0021 279 :blink DW color, fetch, lit, 0x9f, plus
0127 009f 0287 279
0129 00d2 0276 00b1 280 DW cursor, fetch, vram, plus, store, exit
012c 0287 0261 0016 280
012f 281
012f 282 ;C CR -- output newline
012f 00fa 0000 0002 283 head CR,"CR",docolon
0132 0043 0052 7c20 283
0135 0034 283
0136 00ea 284 DW unblink ; ( ofs)
0137 00c6 02e7 02c7 285 :cr1 DW vcols, oneminus, invert, and ; CR
013a 02a7 285
013b 01b7 00d2 0261 286 DW dup, cursor, store ; ( ofs)
013e 00bb 00c6 029b 287 DW vlen, vcols, minus, equal ; on last line?
0141 034e 287
0142 039b 0155 288 DW qbranch, noscroll
0144 00b1 00c6 01e6 289 DW vram, vcols, over, plus, swop ; ( a a2)
0147 0287 01d9 289
0149 00bb 00c6 029b 290 DW vlen, vcols, minus, cmove ; scroll
014c 0450 290
014d 00b1 00bb 0287 291 DW vram, vlen, plus, vcols, minus ; ( a3)
0150 00c6 029b 291
0152 00c6 038d 0168 292 DW vcols, branch, cls1 ; clear last line
0155 00c6 00d2 032a 293 :noscroll DW vcols, cursor, plusstore
0158 038d 0124 294 DW branch, blink
015a 295
015a 296 ;Z CLS -- clear screen
015a 0131 0000 0003 297 head CLS,"CLS",docolon
015d 0043 004c 0053 297
0160 7c20 0034 297
0162 0021 0000 00d2 298 DW lit, 0, cursor, store
0165 0261 298
0166 00b1 00bb 299 DW vram, vlen ; ( a u)
0168 00dd 0276 0583 300 :cls1 DW color, fetch, bl, plus, fill
016b 0287 043b 300
016d 038d 0124 301 DW branch, blink
016f 302
016f 303 ;Z SAVEKEY -- addr temporary storage for KEY?
016f 015c 0000 0007 304 head savekey,"SAVEKEY",dovar
0172 0053 0041 0056 304
0175 0045 004b 0045 304
0178 0059 7c20 004d 304
017b 0000 305 :savekeya DW 0
017c 306
017c 307 ;X KEY? -- f return true if char waiting
017c 0171 0000 0004 308 head querykey,"KEY?",docode
017f 004b 0045 0059 308
0182 003f 308
0183 8801 309 set a,1
0184 7a40 0086 310 hwi [hwkbd] ; sets c register
0186 c852 311 ife c,0x11 ; Return key?
0187 b841 312 set c,0x0d
0188 c452 313 ife c,0x10 ; Backspace key?
0189 a441 314 set c,0x08
018a 0bc1 017b 315 set [savekeya],c
018c 0701 316 set push,b
018d 0821 317 set b,c
018e 3401 88a2 0381 318 next
0191 319
0191 320 ;C KEY -- c get character from keyboard
0191 321 ; BEGIN SAVEKEY C@ 0= WHILE KEY? DROP REPEAT
0191 322 ; SAVEKEY C@ 0 SAVEKEY C! ;
0191 017e 0000 0003 323 head KEY,"KEY",docolon
0194 004b 0045 0059 323
0197 7c20 0034 323
0199 0179 027f 0334 324 :KEY1 DW SAVEKEY,CFETCH,ZEROEQUAL,qbranch,KEY2
019c 039b 01a2 324
019e 0183 01ce 038d 325 DW QUERYKEY,DROP,branch,KEY1
01a1 0199 325
01a2 0179 027f 0021 326 :KEY2 DW SAVEKEY,CFETCH,LIT,0,SAVEKEY,CSTORE
01a5 0000 0179 026c 326
01a8 0016 327 DW EXIT
01a9 328
01a9 329
01a9 330 ;X BYE i*x -- return to CP/M
01a9 0193 0000 0003 331 head bye,"bye",docode
01ac 0062 0079 0065 331
01af 7f81 01af 332 :halt set pc,halt
01b1 333
01b1 334 ; STACK OPERATIONS ==============================
01b1 335
01b1 336 ;C DUP x -- x x duplicate top of stack
01b1 01ab 0000 0003 337 head DUP,"DUP",docode
01b4 0044 0055 0050 337
01b7 0701 338 :pushtos set push,b
01b8 3401 88a2 0381 339 next
01bb 340
01bb 341 ;C ?DUP x -- 0 | x x DUP if nonzero
01bb 01b3 0000 0004 342 head QDUP,"?DUP",docode
01be 003f 0044 0055 342
01c1 0050 342
01c2 8433 343 ifn b,0
01c3 0701 344 set push,b
01c4 3401 88a2 0381 345 next
01c7 346
01c7 347 ;C DROP x -- drop top of stack
01c7 01bd 0000 0004 348 head DROP,"DROP",docode
01ca 0044 0052 004f 348
01cd 0050 348
01ce 6021 349 :poptos set b,pop
01cf 3401 88a2 0381 350 next
01d2 351
01d2 352 ;C SWAP x1 x2 -- x2 x1 swap top two items
01d2 01c9 0000 0004 353 head SWOP,"SWAP",docode
01d5 0053 0057 0041 353
01d8 0050 353
01d9 0401 354 set a,b
01da 6421 355 set b,peek
01db 0321 356 set peek,a
01dc 3401 88a2 0381 357 next
01df 358
01df 359 ;C OVER x1 x2 -- x1 x2 x1 per stack diagram
01df 01d4 0000 0004 360 head OVER,"OVER",docode
01e2 004f 0056 0045 360
01e5 0052 360
01e6 6401 361 set a,peek
01e7 0701 362 set push,b
01e8 0021 363 set b,a
01e9 3401 88a2 0381 364 next
01ec 365
01ec 366 ;C ROT x1 x2 x3 -- x2 x3 x1 per stack diagram
01ec 01e1 0000 0003 367 head ROT,"ROT",docode
01ef 0052 004f 0054 367
01f2 368 ; x3 is in TOS
01f2 6001 369 set a,pop ; x2
01f3 6041 370 set c,pop ; x1
01f4 0301 371 set push,a
01f5 0701 372 set push,b
01f6 0821 373 set b,c
01f7 3401 88a2 0381 374 next
01fa 375
01fa 376 ;X NIP x1 x2 -- x2 per stack diagram
01fa 01ee 0000 0003 377 head NIP,"NIP",docode
01fd 004e 0049 0050 377
0200 6001 378 set a,pop
0201 3401 88a2 0381 379 next
0204 380
0204 381 ;X TUCK x1 x2 -- x2 x1 x2 per stack diagram
0204 01fc 0000 0004 382 head TUCK,"TUCK",docode
0207 0054 0055 0043 382
020a 004b 382
020b 6001 383 set a,pop
020c 0701 384 set push,b
020d 0301 385 set push,a
020e 3401 88a2 0381 386 next
0211 387
0211 388 ;C >R x -- R: -- x push to return stack
0211 0206 0000 0002 389 head TOR,">R",docode
0214 003e 0052 389
0216 8863 390 sub x,1
0217 0561 391 set [x],b ; push TOS onto rtn stk
0218 6021 392 set b,pop ; pop new TOS
0219 3401 88a2 0381 393 next
021c 394
021c 395 ;C R> -- x R: x -- pop from return stack
021c 0213 0000 0002 396 head RFROM,"R>",docode
021f 0052 003e 396
0221 0701 397 set push,b ; push old TOS
0222 2c21 398 set b,[x] ; pop top rtn stk item
0223 8862 399 add x,1 ; to TOS
0224 3401 88a2 0381 400 next
0227 401
0227 402 ;C R@ -- x R: x -- x fetch from rtn stk
0227 021e 0000 0002 403 head RFETCH,"R@",docode
022a 0052 0040 403
022c 0701 404 set push,b ; push old TOS
022d 2c21 405 set b,[x] ; fetch top rtn stk item
022e 3401 88a2 0381 406 next
0231 407
0231 408 ;Z SP@ -- a-addr get data stack pointer
0231 0229 0000 0003 409 head SPFETCH,"SP@",docode
0234 0053 0050 0040 409
0237 0701 410 set push,b
0238 6c21 411 set b,sp
0239 3401 88a2 0381 412 next
023c 413
023c 414 ;Z SP! a-addr -- set data stack pointer
023c 0233 0000 0003 415 head SPSTORE,"SP!",docode
023f 0053 0050 0021 415
0242 0761 416 set sp,b
0243 6021 417 set b,pop ; get new TOS
0244 3401 88a2 0381 418 next
0247 419
0247 420 ;Z RP@ -- a-addr get return stack pointer
0247 023e 0000 0003 421 head RPFETCH,"RP@",docode
024a 0052 0050 0040 421
024d 0701 422 set push,b
024e 0c21 423 set b,x
024f 3401 88a2 0381 424 next
0252 425
0252 426 ;Z RP! a-addr -- set return stack pointer
0252 0249 0000 0003 427 head RPSTORE,"RP!",docode
0255 0052 0050 0021 427
0258 0461 428 set x,b
0259 6021 429 set b,pop
025a 3401 88a2 0381 430 next
025d 431
025d 432 ; MEMORY AND I/O OPERATIONS =====================
025d 433
025d 434 ;C ! x a-addr -- store cell in memory
025d 0254 0000 0001 435 head STORE,"!",docode
0260 0021 435
0261 6001 436 set a,pop ; data
0262 0121 437 set [b],a
0263 6021 438 set b,pop ; pop new TOS
0264 3401 88a2 0381 439 next
0267 440
0267 441 ;C C! char c-addr -- store char in memory
0267 025f 0000 0002 442 head CSTORE,"C!",docode
026a 0043 0021 442
026c 6001 443 set a,pop ; data
026d 0121 444 set [b],a
026e 6021 445 set b,pop ; pop new TOS
026f 3401 88a2 0381 446 next
0272 447
0272 448 ;C @ a-addr -- x fetch cell from memory
0272 0269 0000 0001 449 head FETCH,"@",docode
0275 0040 449
0276 2421 450 set b,[b]
0277 3401 88a2 0381 451 next
027a 452
027a 453 ;C C@ c-addr -- char fetch char from memory
027a 0274 0000 0002 454 head CFETCH,"C@",docode
027d 0043 0040 454
027f 2421 455 set b,[b]
0280 3401 88a2 0381 456 next
0283 457
0283 458 ;Z PC! char c-addr -- output char to port
0283 459 ; head PCSTORE,"PC!",docode
0283 460 ; pop hl ; char in L
0283 461 ; out (c),l ; to port (BC)
0283 462 ; pop bc ; pop new TOS
0283 463 ; next
0283 464 ;
0283 465 ;Z PC@ c-addr -- char input char from port
0283 466 ; head PCFETCH,"PC@",docode
0283 467 ; in c,(c) ; read port (BC) to C
0283 468 ; ld b,0
0283 469 ; next
0283 470 ;
0283 471 ; ARITHMETIC AND LOGICAL OPERATIONS =============
0283 472
0283 473 ;C + n1/u1 n2/u2 -- n3/u3 add n1+n2
0283 027c 0000 0001 474 head PLUS,"+",docode
0286 002b 474
0287 6022 475 add b,pop
0288 3401 88a2 0381 476 next
028b 477
028b 478 ;X M+ d n -- d add single to double
028b 0285 0000 0002 479 head MPLUS,"M+",docode
028e 004d 002b 479
0290 6041 480 set c,pop ; hi cell
0291 0722 481 add peek,b ; lo cell remains on stack
0292 7442 482 add c,ex
0293 0821 483 set b,c
0294 3401 88a2 0381 484 next
0297 485
0297 486 ;C - n1/u1 n2/u2 -- n3/u3 subtract n1-n2
0297 028d 0000 0001 487 head MINUS,"-",docode
029a 002d 487
029b 0401 488 set a,b
029c 6021 489 set b,pop
029d 0023 490 sub b,a
029e 3401 88a2 0381 491 next
02a1 492
02a1 493 ;C AND x1 x2 -- x3 logical AND
02a1 0299 0000 0003 494 head AND,"AND",docode
02a4 0041 004e 0044 494
02a7 602a 495 and b,pop
02a8 3401 88a2 0381 496 next
02ab 497
02ab 498 ;C OR x1 x2 -- x3 logical OR
02ab 02a3 0000 0002 499 head OR,"OR",docode
02ae 004f 0052 499
02b0 602b 500 bor b,pop
02b1 3401 88a2 0381 501 next
02b4 502
02b4 503 ;C XOR x1 x2 -- x3 logical XOR
02b4 02ad 0000 0003 504 head XOR,"XOR",docode
02b7 0058 004f 0052 504
02ba 602c 505 xor b,pop
02bb 3401 88a2 0381 506 next
02be 507
02be 508 ;C INVERT x1 -- x2 bitwise inversion
02be 02b6 0000 0006 509 head INVERT,"INVERT",docode
02c1 0049 004e 0056 509
02c4 0045 0052 0054 509
02c7 802c 510 xor b,-1
02c8 3401 88a2 0381 511 next
02cb 512
02cb 513 ;C NEGATE x1 -- x2 two's complement
02cb 02c0 0000 0006 514 head NEGATE,"NEGATE",docode
02ce 004e 0045 0047 514
02d1 0041 0054 0045 514
02d4 802c 515 xor b,-1
02d5 8822 516 add b,1
02d6 3401 88a2 0381 517 next
02d9 518
02d9 519 ;C 1+ n1/u1 -- n2/u2 add 1 to TOS
02d9 02cd 0000 0002 520 head ONEPLUS,"1+",docode
02dc 0031 002b 520
02de 8822 521 add b,1
02df 3401 88a2 0381 522 next
02e2 523
02e2 524 ;C 1- n1/u1 -- n2/u2 subtract 1 from TOS
02e2 02db 0000 0002 525 head ONEMINUS,"1-",docode
02e5 0031 002d 525
02e7 8823 526 sub b,1
02e8 3401 88a2 0381 527 next
02eb 528
02eb 529 ;Z >< x1 -- x2 swap bytes (not ANSI)
02eb 02e4 0000 0002 530 head swapbytes,"><",docode
02ee 003e 003c 530
02f0 a42f 531 shl b,8
02f1 742b 532 bor b,ex
02f2 3401 88a2 0381 533 next
02f5 534
02f5 535 ;C 2* x1 -- x2 arithmetic left shift
02f5 02ed 0000 0002 536 head TWOSTAR,"2*",docode
02f8 0032 002a 536
02fa 882f 537 shl b,1
02fb 3401 88a2 0381 538 next
02fe 539
02fe 540 ;C 2/ x1 -- x2 arithmetic right shift
02fe 02f7 0000 0002 541 head TWOSLASH,"2/",docode
0301 0032 002f 541
0303 882e 542 asr b,1
0304 3401 88a2 0381 543 next
0307 544
0307 545 ;C LSHIFT x1 u -- x2 logical L shift u places
0307 0300 0000 0006 546 head LSHIFT,"LSHIFT",docode
030a 004c 0053 0048 546
030d 0049 0046 0054 546
0310 0401 547 set a,b ; count
0311 6021 548 set b,pop
0312 002f 549 shl b,a
0313 3401 88a2 0381 550 next
0316 551
0316 552 ;C RSHIFT x1 u -- x2 logical R shift u places
0316 0309 0000 0006 553 head RSHIFT,"RSHIFT",docode
0319 0052 0053 0048 553
031c 0049 0046 0054 553
031f 0401 554 set a,b ; count
0320 6021 555 set b,pop
0321 002d 556 shr b,a
0322 3401 88a2 0381 557 next
0325 558
0325 559 ;C +! n/u a-addr -- add cell to memory
0325 0318 0000 0002 560 head PLUSSTORE,"+!",docode
0328 002b 0021 560
032a 6122 561 add [b],pop
032b 6021 562 set b,pop
032c 3401 88a2 0381 563 next
032f 564
032f 565 ; COMPARISON OPERATIONS =========================
032f 566
032f 567 ;C 0= n/u -- flag return true if TOS=0
032f 0327 0000 0002 568 head ZEROEQUAL,"0=",docode
0332 0030 003d 568
0334 8433 569 ifn b,0
0335 8821 570 set b,1
0336 8823 571 sub b,1
0337 3401 88a2 0381 572 next
033a 573
033a 574 ;C 0< n -- flag true if TOS negative
033a 0331 0000 0002 575 head ZEROLESS,"0<",docode
033d 0030 003c 575
033f 8437 576 ifu b,0
0340 7f81 0346 577 set pc,tostrue
0342 578 :tosfalse
0342 8421 579 set b,0
0343 3401 88a2 0381 580 next
0346 581 :tostrue
0346 8021 582 set b,-1
0347 3401 88a2 0381 583 next
034a 584
034a 585 ;C = x1 x2 -- flag test x1=x2
034a 033c 0000 0001 586 head EQUAL,"=",docode
034d 003d 586
034e 6032 587 ife b,pop
034f 7f81 0346 588 set pc,tostrue
0351 7f81 0342 589 set pc,tosfalse
0353 590
0353 591 ;X <> x1 x2 -- flag test not eq (not ANSI)
0353 034c 0000 0002 592 head NOTEQUAL,"<>",docolon
0356 003c 003e 7c20 592
0359 0034 592
035a 034e 0334 0016 593 DW EQUAL,ZEROEQUAL,EXIT
035d 594
035d 595 ;C < n1 n2 -- flag test n1<n2, signed
035d 0355 0000 0001 596 head LESS,"<",docode
0360 003c 596
0361 6001 597 set a,pop ; n1
0362 0417 598 ifu a,b
0363 7f81 0346 599 set pc,tostrue
0365 7f81 0342 600 set pc,tosfalse
0367 601
0367 602 ;C > n1 n2 -- flag test n1>n2, signed
0367 035f 0000 0001 603 head GREATER,">",docolon
036a 003e 7c20 0034 603
036d 01d9 0361 0016 604 DW SWOP,LESS,EXIT
0370 605
0370 606 ;C U< u1 u2 -- flag test u1<n2, unsigned
0370 0369 0000 0002 607 head ULESS,"U<",docode
0373 0055 003c 607
0375 6034 608 ifg b,pop
0376 7f81 0346 609 set pc,tostrue
0378 7f81 0342 610 set pc,tosfalse
037a 611
037a 612 ;X U> u1 u2 -- flag u1>u2 unsgd (not ANSI)
037a 0372 0000 0002 613 head UGREATER,"U>",docolon
037d 0055 003e 7c20 613
0380 0034 613
0381 01d9 0375 0016 614 DW SWOP,ULESS,EXIT
0384 615
0384 616 ; LOOP AND BRANCH OPERATIONS ====================
0384 617
0384 618 ;Z branch -- branch always
0384 037c 0000 0006 619 head branch,"branch",docode
0387 0062 0072 0061 619
038a 006e 0063 0068 619
038d 34a1 620 :dobranch set z,[z] ; get inline value => IP
038e 3401 88a2 0381 621 next
0391 622
0391 623 ;Z ?branch x -- branch if TOS zero
0391 0386 0000 0007 624 head qbranch,"?branch",docode
0394 003f 0062 0072 624
0397 0061 006e 0063 624
039a 0068 624
039b 0401 625 set a,b
039c 6021 626 set b,pop ; pop new TOS
039d 8412 627 ife a,0
039e 7f81 038d 628 set pc,dobranch
03a0 88a2 629 add z,1 ; else skip inline value
03a1 3401 88a2 0381 630 next
03a4 631
03a4 632 ;Z (do) n1|u1 n2|u2 -- R: -- sys1 sys2
03a4 633 ;Z run-time code for DO
03a4 634 ; '83 and ANSI standard loops terminate when the
03a4 635 ; boundary of limit-1 and limit is crossed, in
03a4 636 ; either direction. This can be conveniently
03a4 637 ; implemented by making the limit 8000h, so that
03a4 638 ; arithmetic overflow logic can detect crossing.
03a4 639 ; I learned this trick from Laxen & Perry F83.
03a4 640 ; fudge factor = 8000h-limit, to be added to
03a4 641 ; the start value.
03a4 0393 0000 0004 642 head xdo,"(do)",docode
03a7 0028 0064 006f 642
03aa 0029 642
03ab 7c41 8000 643 set c,0x8000
03ad 6043 644 sub c,pop ; 0x8000-limit
03ae 8863 645 sub x,1
03af 0961 646 set [x],c ; push as fudge factor
03b0 0822 647 add b,c ; add fudge to start value
03b1 8863 648 sub x,1
03b2 0561 649 set [x],b ; push adjusted start value
03b3 6021 650 set b,pop
03b4 3401 88a2 0381 651 next
03b7 652
03b7 653 ;Z (loop) R: sys1 sys2 -- | sys1 sys2
03b7 654 ;Z run-time code for LOOP
03b7 655 ; Add 1 to the loop index. If loop terminates,
03b7 656 ; clean up the return stack and skip the branch.
03b7 657 ; Else take the inline branch. Note that LOOP
03b7 658 ; terminates when index=8000h.
03b7 03a6 0000 0006 659 head xloop,"(loop)",docode
03ba 0028 006c 006f 659
03bd 006f 0070 0029 659
03c0 8801 660 set a,1 ; the increment
03c1 2c02 661 :loopad add a,[x] ; get the loop index
03c2 7c12 8000 662 ife a,0x8000
03c4 7f81 03c9 663 set pc,looptr ; terminate loop
03c6 0161 664 set [x],a ; save updated index
03c7 7f81 038d 665 set pc,dobranch ; continue the loop
03c9 8c62 666 :looptr add x,2 ; discard loop info
03ca 88a2 667 add z,1 ; skip the inline branch
03cb 3401 88a2 0381 668 next
03ce 669
03ce 670 ;Z (+loop) n -- R: sys1 sys2 -- | sys1 sys2
03ce 671 ;Z run-time code for +LOOP
03ce 672 ; Add n to the loop index. If loop terminates,
03ce 673 ; clean up the return stack and skip the branch.
03ce 674 ; Else take the inline branch.
03ce 03b9 0000 0007 675 head xplusloop,"(+loop)",docode
03d1 0028 002b 006c 675
03d4 006f 006f 0070 675
03d7 0029 675
03d8 0401 676 set a,b ; the increment
03d9 6021 677 set b,pop ; get new TOX
03da 7f81 03c1 678 set pc,loopad
03dc 679
03dc 680 ;C I -- n R: sys1 sys2 -- sys1 sys2
03dc 681 ;C get the innermost loop index
03dc 03d0 0000 0001 682 head II,"I",docode
03df 0049 682
03e0 0701 683 set push,b ; push old TOS
03e1 2c21 684 set b,[x] ; get loop index
03e2 4c23 0001 685 sub b,[1+x] ; subtract fudge factor though
03e4 3401 88a2 0381 686 next
03e7 687
03e7 688 ;C J -- n R: 4*sys -- 4*sys
03e7 689 ;C get the second loop index
03e7 03de 0000 0001 690 head JJ,"J",docode
03ea 004a 690
03eb 0701 691 set push,b ; push old TOS
03ec 4c21 0002 692 set b,[2+x] ; get outer loop index
03ee 4c23 0003 693 sub b,[3+x] ; subtract fudge factor though
03f0 3401 88a2 0381 694 next
03f3 695
03f3 696 ;C UNLOOP -- R: sys1 sys2 -- drop loop parms
03f3 03e9 0000 0006 697 head UNLOOP,"UNLOOP",docode
03f6 0055 004e 004c 697
03f9 004f 004f 0050 697
03fc 8c62 698 add x,2
03fd 3401 88a2 0381 699 next
0400 700
0400 701 ; MULTIPLY AND DIVIDE ===========================
0400 702
0400 703 ;C UM* u1 u2 -- ud unsigned 16x16->32 mult.
0400 03f5 0000 0003 704 head UMSTAR,"UM*",docode
0403 0055 004d 002a 704
0406 6024 705 mul b,pop
0407 0701 706 set push,b
0408 7421 707 set b,ex
0409 3401 88a2 0381 708 next
040c 709
040c 710 ;C UM/MOD ud u1 -- u2 u3 unsigned 32/16->16
040c 0402 0000 0006 711 head UMSLASHMOD,"UM/MOD",docode
040f 0055 004d 002f 711
0412 004d 004f 0044 711
0415 6001 712 set a,pop ; AC = dividend, B=divisor
0416 6041 713 set c,pop
0417 c4c1 714 set i,16 ; loop counter
0418 884f 715 shl c,1 ; sets EX to MSB
0419 001a 716 :udloop adx a,a ; rotate
041a 87b2 717 ife ex,0
041b 7f81 0421 718 set pc,ud16
041d 0403 719 :ud17 sub a,b ; always fits
041e 87a1 720 set ex,0
041f 7f81 0427 721 set pc,udjoin
0421 0403 722 :ud16 sub a,b
0422 87b2 723 ife ex,0 ; it fit
0423 7f81 0427 724 set pc,udjoin
0425 0402 725 add a,b ; restore step
0426 8ba1 726 set ex,1
0427 085a 727 :udjoin adx c,c ; rotate (complemented) result bit in
0428 1cff 728 std j,j ; side effect: decrement i, don't clobber EX
0429 84d2 729 ife i,0
042a 7f81 042e 730 set pc,udfin
042c 7f81 0419 731 set pc,udloop
042e 804c 732 :udfin xor c,-1 ; de-complement quotient
042f 0301 733 set push,a
0430 0821 734 set b,c
0431 3401 88a2 0381 735 next
0434 736
0434 737 ; BLOCK AND STRING OPERATIONS ===================
0434 738
0434 739 ;C FILL c-addr u char -- fill memory with char
0434 040e 0000 0004 740 head FILL,"FILL",docode
0437 0046 0049 004c 740
043a 004c 740
043b 60c1 741 set i,pop
043c 6001 742 set a,pop
043d 84d2 743 :filoop ife i,0
043e 7f81 0444 744 set pc,mdone
0440 051f 745 std [a],b ; decrements i
0441 8802 746 add a,1
0442 7f81 043d 747 set pc,filoop
0444 6021 748 :mdone set b,pop
0445 3401 88a2 0381 749 next
0448 750
0448 751 ;X CMOVE c-addr1 c-addr2 u -- move from bottom
0448 752 ; as defined in the ANSI optional String word set
0448 753 ; On byte machines, CMOVE and CMOVE> are logical
0448 754 ; factors of MOVE. They are easy to implement on
0448 755 ; CPUs which have a block-move instruction.
0448 0436 0000 0005 756 head CMOVE,"CMOVE",docode
044b 0043 004d 004f 756
044e 0056 0045 756
0450 60c1 757 set i,pop ; destination address
0451 60e1 758 set j,pop ; source address
0452 8432 759 :cmloop ife b,0
0453 7f81 0444 760 set pc,mdone
0455 3dde 761 sti [i],[j]
0456 8823 762 sub b,1
0457 7f81 0452 763 set pc,cmloop
0459 764
0459 765 ;X CMOVE> c-addr1 c-addr2 u -- move from top
0459 766 ; as defined in the ANSI optional String word set
0459 044a 0000 0006 767 head CMOVEUP,"CMOVE>",docode
045c 0043 004d 004f 767
045f 0056 0045 003e 767
0462 60c1 768 set i,pop ; destination address
0463 04c2 769 add i,b
0464 88c3 770 sub i,1
0465 60e1 771 set j,pop ; source address
0466 04e2 772 add j,b
0467 88e3 773 sub j,1
0468 8432 774 :cploop ife b,0
0469 7f81 0444 775 set pc,mdone
046b 3ddf 776 std [i],[j]
046c 8823 777 sub b,1
046d 7f81 0468 778 set pc,cploop
046f 779
046f 780 ;Z SKIP c-addr u c -- c-addr' u'
046f 781 ;Z skip matching chars
046f 782 ; Although SKIP, SCAN, and S= are perhaps not the
046f 783 ; ideal factors of WORD and FIND, they closely
046f 784 ; follow the string operations available on many
046f 785 ; CPUs, and so are easy to implement and fast.
046f 045b 0000 0004 786 head skip,"SKIP",docode
0472 0053 004b 0049 786
0475 0050 786
0476 6041 787 set c,pop
0477 6001 788 set a,pop
0478 8452 789 :skipn ife c,0
0479 7f81 0482 790 set pc,skipd
047b 0513 791 ifn [a],b
047c 7f81 0482 792 set pc,skipd
047e 8802 793 add a,1
047f 8843 794 sub c,1
0480 7f81 0478 795 set pc,skipn
0482 0301 796 :skipd set push,a
0483 0821 797 set b,c
0484 3401 88a2 0381 798 next
0487 799
0487 800 ;Z SCAN c-addr u c -- c-addr' u'
0487 801 ;Z find matching char
0487 0471 0000 0004 802 head scan,"SCAN",docode
048a 0053 0043 0041 802
048d 004e 802
048e 6041 803 set c,pop
048f 6001 804 set a,pop
0490 8452 805 :scann ife c,0
0491 7f81 049a 806 set pc,scand
0493 0512 807 ife [a],b
0494 7f81 049a 808 set pc,scand
0496 8802 809 add a,1
0497 8843 810 sub c,1
0498 7f81 0490 811 set pc,scann
049a 0301 812 :scand set push,a
049b 0821 813 set b,c
049c 3401 88a2 0381 814 next
049f 815
049f 816 ;Z S= c-addr1 c-addr2 u -- n string compare
049f 817 ;Z n<0: s1<s2, n=0: s1=s2, n>0: s1>s2
049f 0489 0000 0002 818 head sequal,"S=",docode
04a2 0053 003d 818
04a4 60e1 819 set j,pop ; addr2
04a5 60c1 820 set i,pop ; addr1
04a6 8432 821 :sloop ife b,0
04a7 7f81 04b5 822 set pc,smatch ; by definition, match!
04a9 3801 823 set a,[i]
04aa 3c03 824 sub a,[j]
04ab 8413 825 ifn a,0
04ac 7f81 04b1 826 set pc,sdiff
04ae 8823 827 sub b,1
04af 7f9e 04a6 828 sti pc,sloop
04b1 c00e 829 :sdiff asr a,15 ; smear sign bit across A
04b2 8412 830 ife a,0
04b3 8802 831 add a,1
04b4 0021 832 set b,a
04b5 3401 88a2 0381 833 :smatch next
04b8 834
04b8 0 INCLUDE camel16d ; CPU Dependencies
04b8 1 ; LISTING 3.
04b8 2 ;
04b8 3 ; ===============================================
04b8 4 ; CamelForth for the Mojang DCPU-16 (http://0x10c.com)
04b8 5 ; Copyright (c) 2012 Helge Horch
04b8 6 ; CamelForth for the Zilog Z80
04b8 7 ; Copyright (c) 1994,1995 Bradford J. Rodriguez
04b8 8 ;
04b8 9 ; This program is free software; you can redistribute it and/or modify
04b8 10 ; it under the terms of the GNU General Public License as published by
04b8 11 ; the Free Software Foundation; either version 3 of the License, or
04b8 12 ; (at your option) any later version.
04b8 13 ;
04b8 14 ; This program is distributed in the hope that it will be useful,
04b8 15 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
04b8 16 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the