-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathforth8.txt
2261 lines (2094 loc) · 36 KB
/
forth8.txt
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
/ ** ORForth **
/ Definitions
ZERO= CLA / 0
ONE= CLA IAC / 1
TWO= CLA CLL CML RTL / 2
NEG= CMA IAC / Two's complement
CAL= CLA CLL
MINUS1= CLA CMA / -1 or 4095
MINUS2= CLA CMA CLL RAL / -2 or 4094
MINUS3= CLA CMA CLL RTL / -3 or 4093
*0
CLA
TLS / send null character to terminal to prepare it
JMP EXNV
C40, 40 / Space
C100, 100
C7000, 7000
M25, -25
*20
IP, START / Instruction pointer
SP, S / Stack pointer
RSP, RS / Return stack pointer
EVR, 0 / Execution vector
VL, CARRYH / Last dictionary link
DP, DICTIONARY / Next dictionary addr
REG6, 0
REG8, 0
REG10, 0
REG12, 0
REG14, 0
STATE, 0 / -1 if compiling, zero otherwise
TOIN, 0 / Pointer into text input
FENCE, 40 / Default fence is space
ROWNO, 0
COLNO, 0
INSOVR, -1 / Start edit with insert
PUSH8, PUSH8R
POP2, POP2R / Pop Reg10 then Reg8 (was popA8)
PUSH2, PUSH2R / Push Reg8 then Reg10 (was push8A)
POP3, POP3R / Pop Reg 12 then Reg 10 then Reg 8 (was popCA8)
PUSH3, PUSH3R / Push Reg 8 then Reg 10 then Reg 12 (was push8AC)
DOTQAUX, DOTQR
TWIXTAUX, TWIXTR
/ Initialization constants
SI, S
RSI, RS
/ These constants appear as AND instructions
C777, 777
C7, 7
C1000, 1000
/ Inc IP
INCIP, 0
ISZ IP
CLA
JMP I INCIP / Return with 0 in Acc
/ Inc SP
INCSP, 0
ISZ SP
CLA
JMP I INCSP / Return with 0 in Acc
/ Dec SP
DECSP, 0
MINUS1 / Load -1
TAD SP / SP=SP-1
DCA SP
CML / Set link to previous
JMP I DECSP / Return with 0 in Acc
/ Inc RSP
INCRSP, 0
ISZ RSP
CLA
JMP I INCRSP / Return with 0 in Acc
/ Dec SP
DECRSP, 0
MINUS1 / Load -1
TAD RSP
DCA RSP
JMP I DECRSP / Exit with 0 in Acc
/ Pop stack to Acc
POP, 0
CLA
TAD I SP / Leave result in Acc
DCA PUSH / Save arg in push return for tmp
JMS INCSP
TAD PUSH
JMP I POP
/ Push Acc to stack
PUSH, 0
DCA POP / What to push is in Acc
JMS DECSP / Save arg in pop return for tmp
TAD POP
DCA I SP / Push Acc to stack
JMP I PUSH / Return with 0 in Acc
/ Serout
SEROUT, 0 / Routine for sending a single character
TSF / Argument is in Acc
JMP .-1
TLS
CLA / Returns with 0 in Acc
JMP I SEROUT
/ SerIn
SERIN, 0 / Routine for reading a single character
KSF
JMP .-1
KRB / Result of input is in Acc
JMP I SERIN
/ ExNV
EXNV, CLA
TAD I IP / Address at IP to EVR
DCA EVR
ISZ IP / Point IP to next word address
JMP I EVR / Go to word address
/ Acc is zero after jump
/ ExColon
COLON, JMS DECRSP / Push current IP to RS
TAD IP
DCA I RSP
TAD EVR / Point IP to word after Colon
IAC
DCA IP
JMP EXNV
/ Jump: Jump routine
JUMP, CLA / Get the addr to jump to
TAD I IP
DCA IP / Store the addr to jump to in IP
JMP EXNV
/ Jump TOS zero routine
JUMPF= . / Jump false
JUMPZ, JMS POP
SNA
JMP JUMP
JUMPZ1, JMS INCIP
JMP EXNV
/ Jump TOS nonzero routine
JUMPT= .
JUMPNZ, JMS POP
SZA
JMP JUMP
JMP JUMPZ1
/ Jump TOS minus routine
JUMPMI, JMS POP
JMPMI1, SPA
JMP JUMP
JMP JUMPZ1
/ Jump TOS GE 0 routine
JUMPNM, JMS POP
CMA
JMP JMPMI1
PAGE
JMP 0
/ NR: Number runner routine: Number at IP to stack
NR, CLA
TAD I IP
JMS PUSH
JMS INCIP
JMP EXNV
/ PopA8: Pop Reg10 then Reg8
POP2R, 0
JMS POP
DCA REG10 / Top of stack to R10
JMS POP / Result is in Acc
DCA REG8 / Under top of stack to R8
JMP I POP2R
/ PopCA8: Pop Reg12 then Reg10 then Reg8
POP3R, 0
JMS POP / Top of stack to R12
DCA REG12
JMS I POP2
JMP I POP3R
/ Push8
PUSH8R, 0
CLA
TAD REG8
JMS PUSH
JMP I PUSH8R
/ Push8A: Push Reg8 then Reg10
PUSH2R, 0
CLA
JMS I PUSH8
TAD REG10
JMS PUSH / R10 will be top of stack
JMP I PUSH2R
/ Push8AC: Push Reg8 then Reg10 then Reg12
PUSH3R, 0
JMS I PUSH2 / Push Reg8 then Reg10
TAD REG12 / R12 will be top of stack
JMS PUSH
JMP I PUSH3R
/ SemiColon
SEMIC, CLA / Return address to IP
TAD I RSP
DCA IP / Store return address in IP
JMS INCRSP / Update RSP
JMP EXNV
/ Store
STOREH, 1001
"!+1000 / ! plus end of text flag
0 / Link to prior head
STORE, JMS I POP2 / Top of stack in R10, value to store in R8
TAD REG8 / Value to store into Acc
DCA I REG10 / Store via R10
JMP EXNV
/ At
ATH, 1001
"@+1000
STOREH / Link to prior head
AT, JMS POP / Address to fetch from
DCA REG8
TAD I REG8 / Fetch the value
JMS PUSH / The value to stack
JMP EXNV
/ Swap
SWAPH, 1004
"S;"W;"A;"P+1000
ATH / Link to prior head
SWAP, JMS POP
DCA REG8 / Top of stack to R8
JMS POP
DCA REG10
JMS I PUSH2 / Push first R8 then R10
JMP EXNV
/ Dup
DUPH, 1003
"D;"U;"P+1000
SWAPH
DUP, JMS POP
DCA REG8
TAD REG8
JMS PUSH
TAD REG8
JMS PUSH
JMP EXNV
/ Over
OVERH, 1004
"O;"V;"E;"R+1000
DUPH / Link to prior head
OVER, JMS I POP2 / Top of stack to R10
JMS I PUSH2 / Push R8 then R10
JMS I PUSH8 / Push a copy of R8
JMP EXNV
/ Rot
ROTH, 1003
"R;"O;"T+1000
OVERH
ROT, JMS I POP3 / Top of stack to R12
TAD REG10 / Stack is R8 R10 R12
JMS PUSH
TAD REG12
JMS PUSH
TAD REG8
JMS PUSH
JMP EXNV
/ Reverse ROT
RROTH, 1004
"R;"R;"O;"T+1000
ROTH
RROT, JMP COLON
ROT
ROT
SEMIC
/ Drop
DROPH, 1004
"D;"R;"O;"P+1000
RROTH
DROP, JMS INCSP
JMP EXNV
/ And
ANDH, 1003
"A;"N;"D+1000
DROPH
FAND, JMS I POP2 / Note: in this program use FAND
TAD REG8
AND REG10
JMS PUSH
JMP EXNV
/ Or
ORH, 1002
"O;"R+1000
ANDH
OR, JMS I POP2 / Pop TOS to REG10
TAD REG8
AND REG10
CMA
AND REG10
TAD REG8
JMS PUSH
JMP EXNV
/ Plus
PLUSH, 1001
"++1000
ORH
PLUS, JMS I POP2 / Pop TOS to REG10
CLL
TAD REG8
TAD REG10
JMS PUSH
JMP EXNV
/ Minus: TOS subtracted from under TOS
MINUSH, 1001
"-+1000
PLUSH
MINUS, JMS I POP2 / Pop TOS to REG10
TAD REG10
NEG
TAD REG8
JMS PUSH
JMP EXNV
/ OntoR: stack to Rstack
ONTORH, 1002
">;"R+1000
MINUSH
ONTOR, JMS DECRSP / Make a hole in RS to put it in
JMS POP
DCA I RSP / Store the value in the hole
JMP EXNV
/ ROnto: Rstack to stack
RONTOH, 1002
"R;">+1000
ONTORH
RONTO, TAD I RSP / Get the current entry in RS
DCA POP / Store return in push return from POP
JMS INCRSP / Increment RSP to prune RS
TAD POP
JMS PUSH / Push the value onto stack
JMP EXNV
/ FindAux: Addr of word at TOS
/ Returns address of parameter part of word or zero if not found
FINDAUX, JMS POP / Get the address of word
DCA REG12 / R10 & R12 point to word
TAD REG12 / R12 saves the address of the word
DCA REG10 / R10 works on it
CLA
TAD VL / Last defined head in dictionary
DCA REG8 / REG8 point to dictionary
FA1, TAD REG8 / Save the start of head inn R6
DCA REG6
TAD I REG8 / Get entry from dictionary
AND C777 / Get the count
NEG
TAD I REG10 / Get the word count
SZA
JMP FA5B / Character counts didn't match
/ Compare chars in the pair of words
FA2, ISZ REG8 / Increment dictionary pointer to first char
ISZ REG10 / Increment word pointer to first char
CLA / Loop to match characters
TAD I REG8 / Fetch a char in dictionary
AND C777 / Mask out the stop bit (if there)
NEG
TAD I REG10 / Get the character in word
SZA
JMP FA5 / They're different, skip to next dictionary word
FA3, CLA / They're the same - keep going
TAD I REG8 / Get the current chracter
AND C1000 / Get the stop flag
SNA / Jump to exit with word found
JMP FA2 / Keep going - go back for the next character
FA4, ISZ REG8 / Found a match - exit with found
ISZ REG8 / Point R8 to Ex addr
CLA
TAD REG8 / Get the execution address
JMS PUSH / Put it on the stack
TAD REG6 / Get the start of the head
JMS PUSH
JMP EXNV
/ Current word wasn't it, need to go to next word
FA5B, ISZ REG8 / Point dictionary pointer to next char if from count
FA5, CLA / Entry for working with current char
TAD I REG8 / Get the current word
AND C1000 / Get the stop flag
SNA / Jump on 0 flag to next dictionary character
JMP FA5B
/ Current character is last in word
ISZ REG8 / Go to the next word - that's the link
CLA
TAD I REG8 / Get the link to next word in dictionary
SNA / If zero were at the end of dictionary
JMP FA6
DCA REG8 / Store the new link in R8
TAD REG12 / Restore the pointer to the word
DCA REG10
JMP FA1 / and do it again
FA6, CLA / End of dictionary and we didn't find it
JMS PUSH / Push a zero on the stack
JMP EXNV
/ UStar Multiply two numbers at TOS
USTARH, 1002
"U;"*+1000
RONTOH
USTAR, JMS POP / Multiplicand to MQ
MQL
JMS POP / Get Multiplier
DCA USTAR1 / and store in multiplier
7405 / MUY
USTAR1, 0
DCA REG10 / Save upper part in R10
MQA
DCA REG8 / Lower part to R8
JMS I PUSH2 / Push R8 then R10 (upper in TOS)
JMP EXNV / High part (TOS), low part (TOS-1)
SPARE, 0
/ UDiv: Divide double length by TOS
DVI= 7407
UDIVH, 1002
"U;"/+1000
USTARH
UDIV, JMS POP / Divisor is at top of stack
DCA REG6
JMS I POP2 / TOS (high part) in R10
TAD REG8 / Get low part
MQL / and put it in MQ
TAD REG6
DCA UDIV1
TAD REG10 / High part to Acc
DVI / DVI
UDIV1, 0 / Divisor
JMS PUSH / Remainder to stack
CLA
MQA / Or in the quotient
JMS PUSH / Push remainder from MQ (TOS)
JMP EXNV / Remainder (TOS), quotient (TOS-1)
/ Zero equals: -1 to stack if TOS zero
ZEQH, 1002
"0;"=+1000
UDIVH
ZEQ, JMS POP
SZA / Skip if zero Acc
ONE / Make it 1 if non-zero
NEG / Change 1 to -1 but leave zero unchanged
CMA
JMS PUSH
JMP EXNV
/ (TOS-1) >= (TOS) ?
MAXNO, 3777
GEH, 1002
">;"=+1000
ZEQH
GE, JMS I POP2 / Low in REG8, high in REG10
CLA
TAD REG10
NEG
TAD REG8
SMA
JMP GE1
CLA
GE0, JMS PUSH
JMP EXNV
GE1, MINUS1
JMP GE0
/ TOS = TOS-1
EQH, 1001
"=+1000
GEH
EQ, JMS I POP2 / TOS in R10
DCA REG12 / Store 0 in REG12
TAD REG8
NEG
TAD REG10
SNA
ISZ REG12 / REG12 is 1 if 0 result
CLA
TAD REG12 / 1 if equal 0 if not
NEG
JMS PUSH
JMP EXNV
/ Exit to OS8
STOPH, 1004
"S;"T;"O;"P+1000
EQH
STOP, JMP I STOPA
STOPA, 7600
/ O.: (OhDot) print TOS in octal
MINUS4, 7774
C260, 260 / Char 0
ODOTH, 1002
"O;".+1000
STOPH
ODOT, CLA
TAD MINUS4
DCA REG12
JMS POP / Get the value to print to R8
RAL / Shift left into link
JMP ODOT2
ODOT1, CLA
TAD POP / Use Pop return for tmp
ODOT2, RTL / Cycle 3 bits into low of Acc
RAL
DCA POP
TAD POP
AND C7
TAD C260 / Make it a char by adding char0
JMS SEROUT
ISZ REG12
JMP ODOT1
JMP EXNV
/ Compile word to dictionary
COMMAH, 1001
",+1000
ODOTH
COMMA, JMS POP / Get the value to store
DCA I DP / Save Acc in dictionary
ISZ DP / Update the dictionary ptr
JMP EXNV
/ Increment TOS
PLUS1H, 1002
"1;"++1000
COMMAH
PLUS1, JMS POP
IAC
JMS PUSH
JMP EXNV
/ CMOVE: Move from bottom of source to target
/ TOS: count; next: target; next: source
CMOVEH, 1005
"C;"M;"O;"V;"E+1000
HEREH
CMOVE, JMS I POP3
JMS CMOVER
JMP EXNV
CMOVER, 0
MINUS1 / Count R12; target R10; source R8
TAD REG8
DCA 10 / Source
MINUS1
TAD REG10
DCA 11 / Target
TAD REG12
NEG
DCA REG12 / -Count
CMOVE1, TAD I 10
DCA I 11
ISZ REG12
JMP CMOVE1
JMP I CMOVER
/ Here: current dictionary pointer
HEREH, 1004
"H;"E;"R;"E+1000
PLUS1H
HERE, TAD DP / Enter with 0 in Acc
JMS PUSH
JMP EXNV
/ PAL version of TWIXT
/ Arg in REG12
/ Low, High in Rtn+1 and RTN+2
TWIXTR, 0
CAL
TAD I TWIXTR / Compare arg to low
ISZ TWIXTR
NEG
TAD REG12
SMA / Skip if Arg >= low limit
JMP TWIXT3
TWIXT1, ISZ TWIXTR
TWIXT2, CLA / Exit with false
JMP I TWIXTR
TWIXT3, CAL / Compare to high limit
TAD REG12
NEG
TAD I TWIXTR
ISZ TWIXTR
SPA / Skip if high limit >= arg
JMP TWIXT2
MINUS1 / Exit with true
JMP I TWIXTR
/ WORDAUX: Comes from FIND and other places
/ TOS: fence; input area
/ On exit: TOS: count; destination; source
/ Count is zero if no word found
/ TOIN is updated with count
WORDAUX, JMS I POP2 / Get the fence (TOS R10) and input addr(R8)
DCA REG6 / Initialize count
WA0, TAD I REG8 / If the leading char not the fence?
NEG
TAD REG10
SZA
JMP WA0B / Wasn't a blank
ISZ REG8 / Was the fence keep on going
JMP WA0
WA0B, CLA
TAD REG8 / Save the input addr in REG12
DCA REG12
WA1, TAD I REG8 / Compare char in buffer with fence
NEG
TAD REG10
SNA
JMP WA2 / Found it
ISZ REG8 / Not the fence yet, go for another
ISZ REG6 / Bump the char count
CLA / Go back for another character
JMP WA1
WA2, CLA / Found a word, get ready to CMOVE it
TAD REG6 / Put the char cocunt at HERE
DCA I DP
TAD REG12 / Source to stack first
JMS PUSH
TAD DP / Then dictionary pointer
IAC / Pt the characters after the count
JMS PUSH
TAD REG6 / TOS: word count for CMOVE
JMS PUSH
TAD SI
NEG
TAD REG8
IAC / Point to the char after fence
DCA TOIN
JMP EXNV
NULLH, 4001 / High bit set means this is null
1000 / 0 plus flag bit
CMOVEH / Skip over TWIXTH
NULL, 0
/ Number: Address of word at TOS
/ Simplified version of number - only does octal numbers
/ REG6 is the character counter, REG8/10 the accumulator
/ REG12 is the char being added, Reg14 is the pointer to buffer
INVALID, 4000
C4, 4
NUMBER, DCA REG8 / Initialize result
DCA REG10 / Accomodate a 24 bit result
JMS POP / Get address of word
DCA REG14 / R14 is the index into the source
TAD I REG14 / Get count
JMS PUSH / and save it on the stack
TAD I REG14 / Get the count again
NEG
DCA REG6 / This is the negative of the count
NUMX1, ISZ REG14 / Point to next (or first) char of number
TAD I REG14 / Character to examine
DCA REG12 / Digit to examine in R12
JMS I TWIXTAUX / Check against char 0 and char 7
260
267
SNA
JMP NUMX2 / Wasn't a valid number
CLA
TAD REG12
C7 / Make it a digit
DCA REG12 / Save it as a digit
TAD REG8 / This is the low part of current accumulation
MQL
TAD REG10 / this is the high part of the result
7413 / Shift AD/MQ 3 places left (get this with 2)
2 / The result is AC/MQ
DCA REG10 / Save the high part of the accumulation
MQA / Get the lower part
CLL / Clear the link
TAD REG12 / Add the current digit to lower part
DCA REG8 / and save the updated accumulation
ISZ REG6 / Inc count (R6) and get another digit
JMP NUMX1
/ Finished
JMS POP / Put the count in R12
DCA REG12
TAD REG8 / Push the low part
JMS PUSH
MINUS1 / Make 4 a three
TAD REG12 / Get the count back
AND C4 / Get the high bit
SNA
JMP EXNV
CLA
TAD REG10
JMS PUSH
TAD STATE
SNA
JMP EXNV
NUMX2, JMS I POP2
TAD INVALID / Wasn't a valid number, push invalid to stack
JMS PUSH
JMP EXNV
/ Key:
KEYSUBH, 1003
"K;"E;"Y+1000
NULLH
KEY, JMS SERIN
JMS PUSH / Returns with 0 in Acc
TAD I SP / Echo the character to print
JMS SEROUT
JMP EXNV
/ Emit Sub:
EMITH, 1004
"E;"M;"I;"T+1000
KEYSUBH
EMIT, JMS POP / Get char to print
JMS SEROUT
JMP EXNV / Returns with 0 n Acc
/ Print out a space
SPH, 1002 / Note: Space is SP on command line
"S;"P+1000 / but is spelled SPACE in assembly
EMITH
SPACE, TAD C40
JMS SEROUT
JMP EXNV
/ No arguments, returns with args for CMOVE
/ Comes from FIND and other places
WORD, JMP COLON
NR / Add TOIN to source origin
TOIN
AT
LDSI / Assume only input from TIB (stack origin)
PLUS
NR / Load a blank for a fence
FENCE
AT
WORDAUX / Returns arguments to move from
CMOVE / TIB to Here in Dictionary
SEMIC
/ No arguments, result: param (TOS) and head addr
FIND, JMP COLON
WORD / Returns address of counted text at HERE
UPCASE
HERE / Requires address of dictionary
FINDAUX / Returns addr of head and params
SEMIC
/ A bunch of arguments for EXPECT
CBS, 10 / Ctrl-h (backspace)
MCR, -15 / minus CR
MRO, -177 / minus backspace
MSPACE, -40 / - space
/ Comes from QUIT
/ Input char from keyboard to TIB (stack origin)
/ limit to buffer size of 56 (70 octal)
/ No arguments - no results
/ places null space at end of input
EXPECT, TAD C100
NEG
DCA REG8 / Initialize count
TAD SI / Initialize buffer ptr to stack origin
DCA REG10
EX0, JMS SERIN
DCA REG12 / REG8 has the char read in
TAD REG12
TAD MRO / Compare to back space
SZA
JMP EX1 / Wasn't a backspace
TAD REG8 / Got BS, check if beginning of buffer
TAD C100
SNA
JMP EX0 / Was at the beginning, just start over
CLA
TAD CBS / Output a BS
JMS SEROUT
TAD C40
JMS SEROUT
TAD CBS
JMS SEROUT
MINUS1 / Back up the buffer pointer
TAD REG10
DCA REG10
MINUS1 / Back up the count
TAD REG8
DCA REG8
JMP EX0
EX1, CLA / Wasn't a BS - Check for CR
TAD REG12
TAD MCR / Negative carriage return
SNA
JMP EX3 / Was a CR
/ Check to make sure it's valid
JMS I TWIXTAUX
40
172 / 172 is lower case z
SNA
JMP EX0
CLA / Store the character
TAD REG12
DCA I REG10
TAD REG12 / And echo it to output
JMS SEROUT
ISZ REG10
ISZ REG8 / Check to see if at end of buffer
JMP EX0 / And go back to another
TAD EXMSGA / Ran out of buffer
DCA REG10 / Print the "Too long" message
JMS I DOTQAUX
TAD SI
DCA REG10
EX3, CLA
TAD C40 / At end store a space
DCA I REG10
ISZ REG10 / then a null
DCA I REG10
ISZ REG10 / And a space
TAD C40
DCA I REG10
JMP EXNV
EXMSGA, EXMSG
EXMSG, 11
" ;"T;"o;"o;" ;"l;"o;"n;"g
CCR, 15 / Bunch of constants for CR
CLF, 12
CRH, 1002
"C;"R+1000
SPH
CR, TAD CCR
JMS SEROUT
TAD CLF
JMS SEROUT
JMP EXNV
/ Print a word whose addr is at TOS
WDOTH, 1002
"W;".+1000
CRH
WDOT, JMS POP / Get the addr of the word to print
DCA REG10
JMS I DOTQAUX
JMP EXNV
EXWOSH, 1005
"E;"X;"W;"O;"S+1000
WDOTH
EXWOS, JMS POP
DCA EVR / Go to this word without incrementing IP
JMP I EVR
/ Print the word following call in word
DOTQ, TAD IP
DCA REG10
JMS I DOTQAUX / Returns 0 in Acc
TAD REG10
DCA IP
ISZ IP / IP points to next word
JMP EXNV
/ Dot Quote: Print following string
DOTQH, 3002 / Set immediate bit
".;""+1000
EXWOSH
JMP COLON
LDSTATE / If compiling, state not 0
JUMPZ
NEWDQ1
NR / Compiling, put in call to DOTQ
DOTQ
COMMA
NEWDQ1, STOREAT / Store quote at fence
FENCE
42
WORD
LDSTATE / If compiling, adjust dictionary
JUMPZ
NEWDQ2
INCDP
JUMP
NEWDQ3
NEWDQ2, LOADAT / Section for immediate
DP / Address to print is in DP
WDOT
NEWDQ3, STOREAT / Return the fence to a space
FENCE
40
SEMIC
/ Print the string at REG10
DOTQR, 0
TAD I REG10 / Count
C777 / And out the high bits
NEG
DCA REG8
DOTQA, ISZ REG10
TAD I REG10 / Get the char to print
JMS SEROUT / Returns 0 in Acc
ISZ REG8
JMP DOTQA
JMP I DOTQR
/ Check for an invalid number (4000)
VALIDN, JMS POP
CLL RAL
SZA
MINUS1 / Non-zero in low 11 bits
SNL
MINUS1 / Zero in link
JMS PUSH
JMP EXNV
NEADDR, NE1
NUMERR, TAD DP / Print out offending word
DCA REG10
JMS I DOTQAUX / It's at the dictionary pointer
TAD C40 / Print a space
JMS SEROUT
TAD NEADDR / Print out WHAT?
DCA REG10
JMS I DOTQAUX
NE1, 5
"W;"H;"A;"T;"?
JMP EXNV
/ Interpreter
INTERP, JMP COLON
INT0, FIND
DUP / Zero if we couldn't find it
JUMPZ / Couldn't find it - try number
INT3
INT1, AT / Found the word in dictionary
DUP / Returns with head addr (TOS) and ex addr
JUMPMI / Minus at head addr means end of text
INT4 / Quietly exit
NR / Dig out the immediate bit
2000 / Bit 2 set means immediate
FAND
JUMPNZ / Not set - go execute it
INT2
LDSTATE / Ask if we are compiling
JUMPZ
INT2 / Not compiling - go execute it
COMMA / Compile the word's ex addr
JUMP
INT0 / And go back for another word
INT2, EXWOS / Exec word on stack
JUMP / And go back for another word
INT0
INT3, DROP / Drop the zero we duped
HERE
NUMBER / Didn't find it, try number
DUP
VALIDN / If valid, put on the stack
JUMPZ / if zero - an invalid number