-
Notifications
You must be signed in to change notification settings - Fork 0
/
rc.mac
1771 lines (1746 loc) · 54.3 KB
/
rc.mac
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
TITLE RC,<ALGOL RUNTIME SUPPORT/INTERPRETER>,08,06-SEP-80,TG/GPK
; ENTRY POINTS TO THIS MODULE:
;+
; INTERP - MAIN INTERPRETER
; SBR - JUMP FROM INIT
; STEST -
;-
; ROUTINES CALLED FROM THIS MODULE:
.GLOBL COM02,COM03,COM04,COM05,COM06
.GLOBL COM07,COM10,COM11,COM12,COM13
.GLOBL COM14,ERROR,GETIT,INDEX,FORGET
.GLOBL GETARY,RETDSK,SYSTEM,ALLOC1
.GLOBL ALLOC2,ALLOCS
ORG RC
.SBTTL OPERATOR DISPATCH TABLE
; THIS TABLE CONTAINS THE ADDRESSES OF THE ROUTINES
; WHICH CAN BE CALLED AS OPERATORS UNDER THE ALGOL
; SYSTEM. THE ORDER HERE HAD BETTER CORRESPOND TO
; THAT USED IN THE COMPILER!!!
ORG OPTBL
IADD ;INTEGER ADD
AOC ;ARRAY OPERAND CALL
ASD ;ARRAY STORE DESTRUCTIVE
ASN ;ARRAY STORE NON-DESTRUCTIVE
BRUN ;BRANCH NON-CONDITIONAL
BRTR ;BRANCH ON TRUE CONDITION
BRFL ;BRANCH ON FALSE CONDITION
ENTR ;ENTER BLOCK
CHS ;CHANGE SIGN
COMM ;TALK TO THE MCP
DEL ;DELETE TOP OF STACK
IDIV ;INTEGER DIVIDE
DUP ;DUPLICATE TOP OF STACK
NEQ ;NOT EQUAL COMPARE
EQL ;EQUAL COMPARE
GEQ ;GREATER THAN OR EQUAL COMPARE
LSS ;LESS THAN COMPARE
GTR ;GREATER THEN THOU COMPARE
LEQ ;LESS THAN OR EQUAL COMPARE
LOD ;LOAD
LOR ;LOGICAL OR
LND ;LOGICAL AND
MKS ;MARK STACK
REP ;REPLACE
IMUL ;INTEGER MULTIPLY
LNG ;LOGICAL NEGATE
REL ;RELEASE
RTN ;RETURN
SAV ;SAVE
SBR ;SUBROUTINE
SHL ;SHIFT LEFT
SHR ;SHIFT RIGHT
STOD ;STORE DESTRUCTIVE
STON ;STORE NON-DESTRUCTIVE
ISUB ;INTEGER SUBTRACT
XCH ;EXCHANGE
SCAN ;SCAN
IMOD ;MOD FUNCTION
XADC ;ARRAY DESCRIPTOR CALL
FDI ;FIELD ISOLATE
BPS ;BUMP STACK POINTER
SWP ;SWAP TWO ARRAYS
EXP ;EXPONENTIATE
FID ;FIELD ISOLATE DYNAMIC
RSDN ;ROTATE STACK DOWN
RSUP ;ROTATE STACK UP
INOP ;IN TRUTHSET TEST
OCX ;OCCURS INDEX (FOR CASES)
LODB ;LOAD BYTE OPERATOR
IDIVT ;INTEGER DIVIDE TRUNCATE
FISO ;FIELD ISOLATE
FISD ;FIELD ISOLADE DYNAMIC
FIND ;FIND RCW FOR ADDRESSING
ONES ;COUNT # OF BITS ON
FONE ;GET LEFT MOST BIT THATS ON
B1D ;BUILD 1-DIMENSIONAL ARRAY DESCRIPTOR
B2D ;"" BUT 2-DIM
DPL ;DUPLICATE ARRAY DESC AND LOAD
BLD ;BUILD ARRAY
PLOAD ;LOAD WHAT POINTER POINTS TO
PART ;PARTIAL WORD
PSTN ;POINTER STORE NON-DESTRUCTIVE
PSTD ;POINTER STORE DESTRUCTIVE
SCMP ;STRING COMPARE
PLNK ;LINK POINTERS
DPT = OPTBL-1200
.SBTTL LODB, FIND ROUTINES
;
; LOAD BYTE OPERATOR
;
ORG RC
LODB: MOVB @(SP)+,-(SP) ;LOAD BYTE THAT TOS POINTS TO
CLRB 1(SP) ;AND CLEAR UPPER BYTE
JMP INTERP ;AND EXIT
;
; F I N D
; FIND IS USED FOR ACCESSING IDENTIFIERS GLOBAL TO ONE PROC AND LOCAL
; TO ANOTHER.
; 1ST WORD (TOS) - LEVEL OF PROC IDENTIFIER DECLARED IN
; 2ND WORD - OFFSET FROM RCW.
;
; WE DO A STACK SEARCH TO FIND THE IDENTIFIER
;
FIND: MOV (SP)+,R1 ;GET LEVEL
MOV R4,R0 ;GET CURRENT RCW
10$: CMP -10(R0),R1 ;SEE IF IN THE PROPER LEVEL YET
BLE 20$ ;YES
MOV (R0),R0 ;NO, GET NEXT RCW
BR 10$
20$: ADD R0,(SP) ;ADD ADDRESS OF RCW TO OFFSET FOR ADDRESS
JMP INTERP ;EXIT
.SBTTL EQL, NEQ, GTR, GEQ, LSS, LEQ, SHR, SHL ROUTINES
;
; R E L A T I O N A L O P E R A T O R S
;
; THESE OPERATORS RELATE BETWEEN THEMSELVES AND THE TOP TWO OPERANDS
; ON STACK PRODUCING A RESULT OF EITHER 0 (FALSE) OR 1 (TRUE)
; FROM 2(SP) ROP (SP)
;
.ENABL LSB
EQL: CMP (SP)+,(SP)+ ;EQUAL TEST
BEQ 20$
BR 10$
NEQ: CMP (SP)+,(SP)+ ;NOT EQUAL TEST
BNE 20$
BR 10$
GTR: CMP (SP)+,(SP)+ ;GREATER THAN TEST
BLT 20$
BR 10$
GEQ: CMP (SP)+,(SP)+ ;GREATER THAN OR EQUAL TEST
BLE 20$
BR 10$
LSS: CMP (SP)+,(SP)+ ;LESS THAN TEST
BGT 20$
BR 10$
LEQ: CMP (SP)+,(SP)+ ;LESS THAN OR EQUAL TEST
BGE 20$
; BR 10$ ;
10$: CLR -(SP) ;RESULT IS FALSE
JMP INTERP
20$: MOV #1,-(SP) ;RESULT IS TRUE
JMP INTERP
.DSABL LSB
;
; S H I F T O P E R A T O R S
;
; 1ST WORD (TOS) IS # OF BITS TO SHIFT
; 2ND WORD IS VALUE TO BE SHIFTED
;
SHR: NEG (SP) ;HAVE TO NEGATE TOS FOR RIGHT SHIFT
SHL: MOV (SP)+,R2
MOV (SP)+,R1 ;SHIFT LEFT ENTERS HERE BECAUSE TOS IS ALL SET
ASH R2,R1 ;NOW SHIFT A FEW BITS
MOV R1,-(SP) ;PUSH ANSWER
JMP INTERP
.SBTTL INOP, PART ROUTINES
;
; T R U T H S E T S E T T E S T I N G
; THE IN OPERATOR TESTS TO SEE IF A VALUE IS IN A PARTICULAR TRUTHSET
; 1ST WORD (TOS) - ADDRESS OF 1ST ELEMENT OF TRUTHSET
; 2ND WORD - VALUE WE ARE TESTING
INOP: MOV #INTERP,-(SP) ;TRUTHSET TESTS ALSO NEEDED BY OTHER ROUTINES
IN: MOV (SP)+,R2 ;SAVE RETURN ADDRESS
MOV (SP)+,R0 ;GET ADDRESS OF TRUTHSET
MOV (SP),R1 ;GET VALUE
CLR (SP) ;INITIALIZE BOOLEAN TO FALSE
MOV R2,-(SP) ;PUT RETURN ADDRESS BACK ON STACK
BIT #177600,R1 ;SEE IF TOO BIG OR TOO SMALL
BNE 10$ ;YES
MOV R1,R2 ;DUP A COPY TO WORK WITH
ASH #-3,R1 ;OPTIMIZE FOR 45'S & 50'S
BIC #1,R1 ;AND CLEAR BOTTOM BIT (WORD INDEX)
ADD R1,R0 ;ADDRESS OF WORD IN TRUTHSET
MOV #1,R1 ;BIT TO BE MOVED TO LEFT
BIC #177760,R2 ;MOD BY 16
ASH R2,R1 ;SHIFT BIT TO PROPER PLACE
BIT R1,(R0) ;SEE IF ENTRY IN TRUTHSET IS ON
BEQ 10$ ;NOT ON
INC 2(SP) ;MAKE ENTRY TRUE
10$: RTS PC ;RETURN TO CALLER
;
; P A R T I A L W O R D S
;
PART: MOV (SP)+,R2 ;# OF BITS
BMI INVOP ;MUST BE POS
MOV (SP)+,R1 ;LEFT MOST BIT #
BMI INVOP ;ALSO MUST BE >0
CMP #20,R2 ;SEE IF TO BIG
BLT INVOP ;YEP
CMP #20,R1 ;HERE TO
BLE INVOP
MOV R1,R0 ;SAVE IT
10$: INC R0 ;LINE UP # OF BITS WITH LEFTMOST BIT #
CMP R2,R0 ;CHECK FOR LINED UP NESS
BEQ 20$
BIC #177760,R0 ;MOD 16.
CMP #77777,(SP) ;SET CARRY TO SAME AS BIT #15
ROL (SP) ;PULL INTO BIT #0
BR 10$
20$: MOV #-1,R0 ;MASK OF WHICH BITS TO CLEAR
ASH R2,R0 ;SHIFT BIT
BIC R0,(SP) ;CLEAR OUT THE UNWANTED BITS
JMP INTERP
.SBTTL FISD, FISO ROUTINES
;
; F I E L D M A N E U V E R S
;
; THESE TWO OPERATORS ARE USED FOR THE CONCATENATION OPERATOR
; THERE ARE TWO FORMS:
; FISD & [LEFT-BIT-TO:NUMBER-OF-BITS]
; FISO & [LEFT-BIT-TO:LEFT-BIT-FROM:NUMBER-OF-BITS]
; THE FIELD ISOLATE DYNAMIC IS ASSUMED THAT THE LEFT-BIT-FROM
; IS THE SAME AS THE # OF BITS - 1. (AND IS FAKED AS SUCH)
;
; 1ST WORD (TOS) - # OF BITS
; 2ND WORD - LEFT-BIT FROM (FISO ONLY)
; 3RD WORD - LEFT-BIT TO
; 4TH WORD - VALUE TO BE STUFFED THERE
; 5TH WORD - VALUE TO GET STUFFED INTO
;
; FIELD ISOLATE DYNAMIC
FISD: MOV (SP),-(SP) ;DUP THE # OF BITS
DEC 2(SP) ;LEFT-BIT FROM = # OF BITS - 1
; FIELD ISOLATE
FISO: MOVB #1,RWT5 ; SET CONCAT TOG
CMP (SP),#20 ;SEE IF TOO BIG
BGT INVOP
MOV #1,R1 ;PUT A 1 INTO R1
MOV (SP),R0 ;SEE IF NEGATIVE & GET #
BMI INVOP ;TOO BAD !
BEQ 20$ ;DONE ALIGNMENT
10$: ASL R1 ;(I.E. GET 2**R0)
SOB R0,10$
20$: DEC R1 ;MASK OF WHICH BITS ARE GOOD
MOV (SP)+,R0 ;NUMBER OF BITS
MOV (SP),R2 ;LEFT-BIT FROM
BMI INVOP ;NOT ALLOWED TO BE NEGATIVE
CMP R2,#20
BGE INVOP ;TOO BIG
30$: INC R2 ;ALIGN MASK UP WITH LEFT-BIT FROM
CMP R0,R2 ;WHEN LEFT-BIT FROM = # OF BITS
BEQ 40$ ;THEN WE ARE ALIGHNED
BIC #177760,R2 ;MOD 16.
SEC ;ASSUME BIT #0 SET !
ROR R1 ;PULL BIT #0 TO BIT #15
BCS 30$ ;GOOD GUESS
BIC #100000,R1 ;WOOPS!
BR 30$
40$: MOV (SP)+,R2 ;GET LEFT-BIT FROM
TST (SP) ;SEE IF LEFT-BIT TO IS LEGIT
BMI INVOP
CMP (SP),#20 ;TOO BIG?
BGE INVOP ;YES
SUB (SP)+,R2 ;SHIFT COUNT FOR FDI
NEG R2 ;WE WANT LEFT-BIT-TO - LEFT-BIT-FROM
BGE 50$ ;>=0
CLR R2 ;DON'T WRAP THIS ONE
50$: MOV SP,R0 ;NEXT 3 INSTRUCTIONS
TST (R0)+ ;DUE TO INCOMPATIBILITY
MOV R0,-(SP) ;OF 11'S (ADDRESS OF 5TH WORD)
MOV R1,-(SP) ;MASK
MOV R2,-(SP) ;SHIFT COUNT
JMP FDI ;LET FDI TAKE IT FROM HERE
.SBTTL IADD, ISUB, IMUL, IEXP
;
; A R I T H M E T I C O P E R A T O R S
;
;
; THE ARITHEMETIC OPERATORS WORK OVER THE TOP TWO VALUES
; ON THE STACK TO PRODUCE A RESULT WHICH IS LEFT ON THE
; STACK IN PLACE OF THE TWO OPERANDS
;
; ADD
;
IADD: ADD (SP)+,(SP) ;ADD TOP OF STACK, POP, TO TOP OF STACK
JMP INTERP
;
; SUBTRACT
;
ISUB: SUB (SP)+,(SP) ;SUBTRACT TOP OF STACK, POP, FROM TOP OF STACK
JMP INTERP
;
; MULTIPLY
;
.ENABL LSB
IMUL: MOV (SP)+,R0
MOV (SP)+,R2
JSR PC,10$ ;MULTIPLIES R2 BY R0,
MOV R1,-(SP) ;LEAVES RESULT IN R1
JMP INTERP
10$: MUL R2,R0 ;DO THE MULTIPLY
TST R1 ;DO A QUICK CHECK
SXT R2 ; FOR INTEGER OVERFLOW
CMP R0,R2 ;THEY SHOULD BE EQUAL
BNE 20$ ;NOPE, GOT A PROBLEM
RTS PC ;YEAH, EXIT
20$: QUIT <?Integer overflow>
INVOP: QUIT <?Invalid operand in code file>
;
; EXPONENTIATE
;
EXP: MOV 2(SP),R2 ;GET # TO BE RAISED TO POWER
CLR R1 ;NEGATIVE POWER YIELDS 0 RESULT
MOV (SP)+,(SP) ;MOVE POWER
BMI 40$ ;DONE IF NEGATIVE POWER
INC R1 ;START BY MULTIPLING BY 1
TST (SP) ;SEE IF DONE (POWER = 0)
BEQ 40$
30$: MOV R1,R0 ;MOVE PREVIOUS ANSWER TO MULTIPLICANDS POSITION
JSR PC,10$ ;MULTIPLY BY #
DEC (SP) ;REDUCE POWER BY ONE
BNE 30$ ;LOOP UNTIL POWER IS 0
40$: MOV R1,(SP) ;R1 SHOULD NOW CONTAIN RESULT
JMP INTERP
.DSABL LSB
.SBTTL IDIVT, IDIV, IMOD, CHS
;
; DIVIDE TRUNCATE
;
.ENABL LSB
IDIVT: MOV (SP)+,R2 ;FETCH THE DIVISOR
MOV (SP)+,R1 ; AND THE DIVIDEND
JSR PC,30$ ;GET OPERANDS AND DIVIDE
MOV R0,-(SP) ;QUOTIENT IS LEFT IN R0
BR INTERP
;
; DIVIDE ROUNDED
;
IDIV: MOV (SP)+,R2 ;FETCH THE DIVISOR
MOV (SP)+,R1 ; AND THE DIVIDEND
JSR PC,30$ ;GET OPERANDS AND DIVIDE
MOV R0,-(SP) ;QUOTIENT IS LEFT IN R0
MOV R2,R0 ;COPY DIVISOR
ASR R0 ;AND GET HALF OF IT
CMP R0,R1 ;CHECK IT AGAINST REMAINDER
BGT INTERP ;EXIT
10$: BLT 20$ ;ROUND UP
ROR R2 ;CHECK DIVISOR AGAIN
BCS INTERP ;DON'T ROUND
20$: INC (SP) ;ROUND
BR INTERP ;AND EXIT
;
; MOD FUNCTION
;
IMOD: MOV (SP)+,R2 ;FETCH THE DIVISOR
MOV (SP)+,R1 ; AND THE DIVIDEND
JSR PC,30$ ;GET OPERAND AND DIVIDE
MOV R1,-(SP) ;SAVE REMAINDER
BR INTERP
30$: SXT R0 ;AND EXTEND THE SIGN
DIV R2,R0 ;DO A DIVIDE
BCS 40$ ;CHECK FOR ZERO DIVIDE
RTS PC ;OK, SO EXIT
40$: QUIT <?Division by zero>
.DSABL LSB
;
; CHANGE THE SIGN
;
CHS: NEG (SP)
BR INTERP
.SBTTL LND, LOR, LNG, STOD, STON, PSTD, PSTN ROUTINES
;
; L O G I C A L O P E R A T O R S
;
; THESE OPERATORS TAKE THE TOP TWO OPERANDS ON THE STACK
; AND ANDS OR ORS THEM TOGETHER, WHICHEVER IS MORE APPROPRIATE
; TO THE SITUATION. LNG DOES A LOGICAL NEGATE ON TOS
;
; AND
;
LND: COM (SP) ;SWITCH STATUS OF BITS TO USE FOR A CLEAR MASK
BIC (SP)+,(SP) ;THIS COMPLETES THE 'AND'
BR INTERP
;
; OR
;
LOR: BIS (SP)+,(SP) ;PDP 11 HARDWARE 'OR' FUNCTION
BR INTERP
;
; NEGATION
;
LNG: COM (SP)
BR INTERP
;
; S T O R E O P E R A T O R S
;
; THE STORE OPERATORS STORE THE SECOND WORD IN THE STACK (VALUE)
; IN THE WORD POINTED TO BY THE TOS (ADDRESS).
; BOTH ARE DELETED FROM THE STACK EXCEPT IN A STON WHERE THE
; VAULE IS LEFT ON THE STACK
;
; STORE DESTRUCT BOTH ADDRESS AND VALUE ARE REMOVED
;
STOD: MOV 2(SP),@(SP)+ ;STORE AND POP ADDRESS
TST (SP)+ ;POP VALUE
BR INTERP
;
; STORE NON-DESTRUCT ADDRESS POPPED ONLY
;
STON: MOV 2(SP),@(SP)+ ;STORE AND POP ADDRESS
BR INTERP
;
; P O I N T E R S T O R E O P E R A T O R S
;
; ADDRESS (ON TOS) IS WHERE POINTER BELOW IT IS STORED
; POINTER IS INDEX ON TOP OF ARRAY DESCRIPTOR
;
; POINTER STORE DESTRUCT - REMOVE ALL 3 WORDS
;
PSTD: MOV (SP)+,R0 ;GET ADDRESS OF POINTER
MOV 2(SP),(R0)+ ;STORE ARRAY PART
MOV (SP)+,(R0) ;STORE INDEX PART
TST (SP)+ ;POP ARRAY PARY
BR INTERP ;DONE
;
; POINTER STORE NON-DESTRUCT - REMOVE ONLY ADDRESS OF POINTER
;
PSTN: MOV (SP)+,R0 ;ADDRESS OF POINTER
MOV 2(SP),(R0)+ ;STORE ARRAY PART
MOV (SP),(R0) ;STORE INDEX PART
BR INTERP
.SBTTL FID ROUTINE
;
; B I T O P E R A T O R S
;
; THESE TWO OPERATORS DEAL WITH STORING BIT CONFIGURATIONS
;
; FIELD ISOLATE DYNAMIC
; THIS ONE DOES SOME CHECKING AND SETS UP THE STACK FOR THE NEXT ONE
;
; WORD 1 IN STACK (TOS) = DESCRIPTOR (ADDRESS OF ID)
; WORD 2 IN STACK = VALUE OF WORD TO BE WORKED OVER
; WORD 3 IN STACK = # OF BITS THAT GET STORED
; WORD 4 IN STACK = LEFT MOST BIT #
;
FID: MOV 6(SP),R0 ;LEFT MOST BIT # INTO R0
BMI INVOP
CMP #20,R0 ;TOO BIG?
BLE INVOP ;YES
MOV 4(SP),R2 ;# OF BITS IN R2
BMI INVOP ;TO SMALL!
CMP R2,#20 ;TO BIG?
BGT INVOP ;YES
SUB R2,R0 ;TO GET SHIFT COUNT
INC R0
BGE 10$ ;DON'T WRAP THIS ONE
CLR R0
10$: MOV (SP)+,2(SP) ;MOVE ADDRESS AROUND
MOV (SP),4(SP) ;MOVE VALUE AROUND
MOV R0,-(SP) ;SAVE SHIFT COUNT FOR FDI
MOV #1,R1
ASH R2,R1 ;MOVE BIT TO PROPER PLACE
DEC R1 ;MAKE 2** # OF BITS - 1
MOV R1,2(SP) ;SAVE MASK
.SBTTL FDI ROUTINE
;
; FIELD ISOLATE
; WORD 1 IN STACK (TOS) = SHIFT COUNT
; WORD 2 IN STACK = MASK
; WORD 3 IN STACK = ADDRESS OF WHERE TO STORE
; WORD 4 IN STACK = VALUE TO BE SHIFTED
;
FDI: MOV 6(SP),R0 ;GET VALUE TO BE STORED
MOV (SP)+,R2 ;GET SHIFT COUNT
MOV (SP)+,R1 ;GET MASK
COM R1 ;COMPLIMENT TO TURN OFF BITS NOT TO BE STORED
BIC R1,R0 ;CLEAR OUT BITS NOT TO BE USED
COM R1 ;TO GET ORIG MASK
TST R2 ;NON-ZERO SHIFT COUNT?
BEQ 20$ ;NOPE. DONE!
10$: CMP #77777,R0 ;PUT BIT #15 OF VALUE INTO CARRY
ROL R0 ;THEN INTO BIT #0
CMP #77777,R1 ;PUT BIT #15 OF MASK INTO CARRY
ROL R1 ;THEN INTO BIT #0
SOB R2,10$ ;LINE THEM UP
20$: BIC R1,@(SP) ;WHERE TO PUT NEW VALUE
;TURN OFF BITS TO BE STORED INTO
BIS R0,@(SP)+ ;PUT NEW VALUE THERE
MOV R0,(SP) ;& LEAVE ON TOS
CON.SW: TSTB RWT5 ; IS IT ZERO
BEQ 10$ ; NOPE
TST (SP)+ ;ONLY EXECUTED FOR CONCATS
10$: CLRB RWT5 ; SET SWITCH INCASE IT WAS RESET
BR INTERP
.SBTTL >>>>>> INSTRUCTION DECODER
;
;
; I N S T R U C T I O N D E C O D E R
;
; REGISTER ALLOCATION FOR THE INTERPRETER:
;
; R6 - REAL STACK POINTER
; R5 - IPC (INTERPRETIVE PROGRAM COUNTER)
; R4 - F REGISTER (STACK HISTORY POINTER)
; R3 - RELOCATION REGISTER (PRT BASE)
; R2 - R0 FREE FOR ALL
;
.ENABL LSB
OPDC: JSR PC,DECODE ;FETCH THE ADDRESS
MOV (R0),-(SP) ;AND THE DATA STORED THERE
BR INTERP ;LOOP THRU INTERPRETER
OP: ASR R0 ;MAKE INTO A DISPATCH ADDRESS
JMP @DPT(R0) ;AND OFF TO THE ROUTINE
INTERP::
.IF DF DEBUG
JSR PC,SEGCHK ;SEE IS THIS ADDRESS IS FLAGGED
.ENDC
MOV (R5)+,R0 ;FETCH NEXT INSTRUCTION
MOV R0,R1 ;COPY IT AND
BIC #-3-1,R1 ;MASK OUT THE TYPE CODE
ASL R1 ;MAKE INTO A WORD INDEX
ADD R1,PC ;AND GO TO THE PROPER PLACE
BR LITC ; LITERAL CALL
BR OP ; OPERATOR CALL
BR OPDC ; OPERAND CALL
; BR DESC ; DESCRIPTOR CALL
DESC: JSR PC,DECODE ;FIND OUT THE ADDRESS
10$: MOV R0,-(SP) ; AND STACK IT
BR INTERP ;AND LOOP
LITC: ROR R0 ;DIVIDE BY TWO
ROR R0 ; AND TWO MORE
BR 10$ ;AND GO STACK IT
DECODE: BIC #3,R0 ;GET RID OF TYPE FIELD
ASR R0 ;AND MOVE OVER A BIT
BMI 20$ ;NOT PRT ADDRESSING
ADD R3,R0 ;OFFSET INTO PRT
RTS PC ; AND EXIT
20$: BIT #20000,R0 ;IS IT F ADDRESSING?
BNE 30$ ;YES
BIC #140000,R0 ;CLEAR THOSE BITS
ADD R5,R0 ;IPC RELATIVE ADDRESS
RTS PC ; AND EXIT
30$: ADD #10000,R0 ;SET + OR - INTO C
BIC #170000,R0 ;THAT MAKES F+ WORK
BCS 40$
NEG R0 ;NOW F- SHOULD WORK
40$: ADD R4,R0 ;NOW STACK OFFSET
RTS PC ; AND EXIT
.DSABL LSB
.SBTTL BRUN, BRTR, BRFL, OCX, ENTR ROUTINES.
;
; B R A N C H O P E R A T O R S
;
; BRANCHING IS DONE RELATIVE TO PROGRAM BASE ADDRESS (-2)
; CONDITIONAL BRANCHS TAKE BRANCH ON APPROPRIATE CONDITION
; AND CLEAN THE STACK OTHERWISE
;
;
BRUN: MOV (SP)+,R5 ;SET PC
ADD PBASE,R5 ;MAKE RELATIVE
BR INTERP ;NEXT
BRTR: MOV (SP)+,R0 ;GET ADDRESS
ROR (SP)+ ;BRANCH IF BIT #0 = 1
BCS $BR ;LIKE SO
BR INTERP ;AND SKIPS IF FALSE (0)
BRFL: MOV (SP)+,R0 ;GET ADDRESS
ROR (SP)+ ;BR-FALSE TAKES BRANCH IF BIT #0 = 0
BCS INTERP ;AND SKIPS IF = 1
$BR: MOV R0,R5 ;SET NEW PC
ADD PBASE,R5 ;MAKE IT RELATIVE
BR INTERP ;DONE THIS WAY FOR SPEED
;
; O C C U R E S I N D E X
;
; USED FOR INDEXING INTO CODE SEGMENT.
; TOS IS INDEX INTO CASE BODY
; 2ND WORD IS MAX VALUE ALLOWED (0 IS MINIMAL VALUE ALLOWED)
; 3RD WORD IS ADDRESS OF TABLE OF SEGMENT ADDRESSES
; IF RESPECTIVE ADDRESS IS < 0 THEN THAT INDEX IS ILLEGAL ALSO
; OTHERWISE THAT ADDRESS IS ADDRESS WITHIN THIS SEGMENT TO GO TO
; SO USE THE BRUN OPERATOR
;
OCX: MOV (SP)+,R0 ;GET INDEX
BMI INVIDX ;< 0 => NO GOOD
CMP R0,(SP)+ ;SEE IF TOO BIG
BGT INVIDX ;YES. ALSO AN ERROR
ASL R0 ;MULTIPLY INDEX BY 2
ADD (SP),R0 ;TO INDEX INTO CASE BODY
MOV (R0),(SP) ;GET ADDRESS OF STMT
BPL BRUN ;IT WAS GOOD
BR INVIDX ;INVALID CASE INDEX
;
; ENTR - ENTERS ANOTHER BLOCK OF SAME PROCEDURE
;
ENTR: MOV (SP)+,R0 ;SAVE ADDRESS OF DESCRIPTOR
JSR PC,GETIT ;MAKE THE SEGMENT PRESENT
+ TYPEPR ;CODE SEGMENT TYPE MEMORY
+ PROGFD ;FILE TO READ FROM IN CASE
MOV R0,PBASE ;SET NEW PROGRAM BASE REGISTER
MOV R0,R5 ;SET NEW PROGRAM COUNTER
TST (R5)+ ;BECAUSE R5 POINTS TO WORD BEFORE CODE
BR INTERP
.SBTTL DEL, DUP, MKS, XCH, BPS, LOD ROUTINES
;
; S T A C K O P E R A T O R S
;
; THESE OPERATORS MANIPULATE THE CONTENTS OF THE TOP OF THE STACK
; OR THE STACK POINTER IT SELF
;
; DELETE POPS THE TOS
;
DEL: TST (SP)+ ;POP TOS
BR INTERP
;
; DUPLICATE - PUSHES THE TOS ONTO THE STACK
;
DUP: MOV (SP),-(SP) ;LIKE THAT
BR INTERP
;
; MARK STACK - PUSHES PREVIOUS MSK (AT PRT+0) ONTO STACK
; - THEN PUTS STACK POINTER IN MKS (AT PRT+0)
;
MKS: MOV (R3),-(SP) ;R3 POINTS TO PRT
JSR PC,STKCHK ;PUSH AND CHECK FOR STACK OVERFLOW
MOV SP,(R3)
BR INTERP
;
; EXCHANGE EXCHANGES THE TOP WORD ON STACK WITH THE WORD BELOW IT
;
XCH: MOV (SP)+,R0 ;SAVE TOS
MOV (SP),-(SP) ;NEW TOS
MOV R0,2(SP) ;AND INSERT OLD TOS BELOW
BR INTERP ;THAT WASN'T HARD
;
; BUMP STACK POINTER TOP OF STACK CONTAINS THE # OF ZEROS TO PUSH -1
;
BPS: MOV (SP)+,R2 ;GET # OF ZEROS - 1
INC R2 ;NOW OK
MOV SP,R1 ;SAVE CURRENT STACK POINTER
ASL R2 ;DOUBLE FOR WORDS
SUB R2,SP ;WHERE NEW STACK POINTER WILL BE
JSR PC,STKCHK ;CHECK FOR STACK OVERFLOW
10$: CLR -(R1) ;CLEAR OUT THE STACK AREA
SOB R2,10$
BR INTERP
;
; LOAD REPLACES ADDRESS ON TOS BY CORRESPONDING VALUE.
;
LOD: BIT #1,(SP) ;TEST FOR ODD ADDRESS
BNE INVADD ;NO GOOD
MOV @(SP)+,-(SP) ;DO IT
BR INTERP
.SBTTL FONE, ONES, RSDN, RSUP ROUTINES
;
; M I S C E L L A N E O U S O P E R A T O R S
;
; ONES OPERATOR COUNTS THE # OF BITS ON IN A WORD
; FIRSTONE OPERATOR RETURNS THE LEFT-MOST BIT # THAT IS ON
; (-1 IF NONE ON)
;
; FIRSTONE
;
FONE: MOV (SP),R0 ;GET WORD TO FIND 1ST 1 IN
MOV #21,(SP) ;CAUSE WE DEC FIRST
10$: DEC (SP) ;NOT THIS BIT
BEQ INTERP ;MUST NOT HAVE FOUND A ONE!
ROL R0 ;PUSH BIT #15 INTO CARRY
BCC 10$ ;WASN'T ON
BR INTERP ;ANSWER ON TOS
;
; ONES
;
ONES: MOV (SP),R0 ;GET WORD TO COUNT THE # OF BITS ON
CLR (SP) ;ANSWER
10$: CLC ;CLEAR THE CARRY
ROR R0 ;PULL BIT #0 INTO THE CARRY
ADC (SP) ;ADD BIT IF IT WAS ON
TST R0 ;SEE IF ANY MORE ON
BNE 10$ ;YES
BR INTERP
;
; R O T A T E S T A C K O P E R A T O R S
;
; THESE TWO OPERATORS ROTATE THE STACK UP OR DOWN
; INITIAL STACK CONFIGURATION IS
; C
; B
; A (TOS)
;
; AFTER RSDN RSUP STACK LOOKS LIKE:
; B A
; A C
; C (TOS) B
;
; ROTATE STACK DOWN (IE TOS TO 4(SP))
;
RSDN: MOV 4(SP),-(SP) ;DUP C
MOV 2(SP),6(SP) ;MOV A TO ITS PLACE
MOV 4(SP),2(SP) ;MOV B TO ITS PLACE
MOV (SP)+,2(SP) ;PUT C IN ITS PLACE
JMP INTERP
;
; ROTATE STACK UP (IE 4(SP) TO TOS)
;
RSUP: MOV 4(SP),-(SP) ;DUP C
MOV 4(SP),6(SP) ;MOV B TO ITS PLACE
MOV 2(SP),4(SP) ;MOV A TO ITS PLACE
MOV (SP)+,(SP) ;PUT C WHERE IT BELONGS
JMP INTERP
INVIDX: QUIT <?Case index out of range>
INVADD: QUIT <?Illegal address in load operation>
; S T R I N G B O U N D R Y T E S T I N G
;
; STEST TESTS A POINTER TO SEE IF IT POINTS OUT OF THE ARRAY IT WAS
; ASSIGNED TO. IF SO, THIS CONSTITUTES AN ERROR CONDITION SIGNALED AS
; 'SEGMENTED ARRAY'. I.E. A POINTER WAS POINTING BEYOND THE SEGMENT
; LIMITS.
;
; FOR THIS ROUTINE, SOME INFORMATION IS STORED IN THE PRT. NAMELY
; A 4 WORD BLOCK CONTAINING THE FOLLOWING INFORMATION.
; WORD 1 - ADDRESS OF ARRAY DESCRIPTOR OF THE POINTER
; WORD 2 - INDEX OF THE POINTER
; WORD 3 - MEMORY DESCRIPTOR OF SEGMENT OF PREVIOUS CALL
; ASSOCIATED WITH THIS POINTER
; WORD 4 - ADDRESS OF WHERE WORD 3 CAME FROM AND GOES TO.
;
; THE 3RD AND 4TH WORDS ARE NECESSARY BECAUSE WE DON'T WANT AN ARRAY
; ROW TO GET SWAPPED OUT ON US. SO WE MAKE IT SAVED. BUT BEFORE WE
; DO, SAVE A COPY OF WHAT THE ORIGINAL SAVE-STATUS WAS AND WHERE
; IT WAS SO THAT WE CAN RESTORE IT PROPERLY.
;
; DURING EACH CALL (OTHER THAN THE 1ST). THE PREVIOUS SEGMENT DESCRIPTOR
; IS RESTORED.
; THE STACK, UPON ENTRANCE, LOOKS LIKE THE FOLLOWING:
; WORD 1 (TOS) - RETURN ADDRESS FOR RTS PC
; WORD 2 - OFFSET INTO THE PRT OF 4-WORD BLOCK
; THIS OFFSET IS SUCH THAT IF YOU ADD 6 PLUS THE PRT BASE
; YOU GET THE ADDRESS OF THE 1ST ELEMENT OF THE BLOCK
;
; UPON RETURN THE STACK LOOKS LIKE THE FOLLOWING
; WORD 1 (TOS) - ADDRESS OF WHERE POINTER POINTS TO.
; WORD 2 - LENGTH LEFT IN THIS ARRAY ROW BEFORE END OF ROW
;
; REGISTERS REMAIN UNCHANGED
; THIS ROUTINE AND THE SCMP,REP,SCAN OPERATORS WERE WRITTEN TO BE BOTH
; RE-ENTRANT AND AS FAST AS POSSIBLE
STEST:: MOV R2,-(SP) ;SAVE R2
MOV 4(SP),R2 ;GET OFFSET
ADD #6,R2 ;PLUS 6
ADD R3,R2 ;PLUS PRT BASE
MOV (SP),-(SP) ;DUP R2
MOV 4(SP),2(SP) ;DUP RETURN ADDRESS
MOV R0,-(SP) ;SAVE R0
MOV R1,-(SP) ;AND R1 ALSO
TST 4(R2) ;SEE IF 1ST TIME THRU
BEQ 10$ ;YES
MOV 6(R2),@4(R2) ;RESTORE OLD MEMORY DESCRIPTOR
10$: MOV (R2)+,R0 ;GET ADDRESS OF ARRAY DESCRIPTOR
BEQ INVOPP ;NO ARRAY! OH HOW HORRIBLE!!!
MOV (R2)+,R1 ;GET INDEX
BMI SEGARY ;TOO SMALL !
BIT #40000,(R0) ;SEGMENTED ?
BEQ 30$ ;NO
TST 4(R0) ;SEE IF DV ALLOCATED
BGT 20$ ;YES
JSR PC,ALLOCS ;NO. ALLOCATE IT
20$: CLR -(SP) ;FOR FIGURING INDEX MOD/DIV 256.
MOVB R1,(SP) ;INDEX MOD 256.
CLRB R1
SWAB R1 ;INDEX DIV R1
MOV (R0)+,-(SP) ;GET ARRAY SIZE
BIC #160000,(SP) ;MINUS SEG-BITS & PRES BIT
CMP R1,(SP)+ ;SEE IF TOO BIG
BGE SEGARY ;YES
ASH #3,R1 ;OPTIMIZE FOR THOSE WHO CAN HACK IT
MOV (R0),R0 ;ADDRESS OF BASE OF DV -2
TST (R0)+ ;GET TO BASE OF DV
ADD R1,R0 ;ADDRESS OF PROPER ENTRY
MOV (SP)+,R1 ;NEW INDEX
30$: TST 4(R0) ;ROW ALLOCATED YET?
BGT 40$ ;YES
JSR PC,ALLOC1 ;ALLOCATE ROW!
40$: MOV (R0),-(SP) ;GET SIZE (ROW IN CORE?)
BMI 50$ ;YES
JSR PC,GETIT ;MAKE IT PRESENT
+ TYPEAY ;DATA TYPE MEMORY
+ VMEMFD ;READ FROM OVERLAY FILE
MOV (R0),R0 ;GET ADDRESS OF DESCRIPTOR
50$: BIC #160000,(SP) ;GET TRUE SIZE
BIT #40000,4(R0) ;SEE IF FOR REAL!
BEQ 60$ ;NO. MUST BE BOOL OR INT
ASL (SP) ;DOUBLE ARRAY SIZE (2 WORDS/ENTRY)
60$: ASL (SP) ;TIMES 2 (# OF CHARS/WORD)
SUB R1,(SP) ;TO FIND THE # LEFT
BLE SEGARY ;NOT ENOUGH!
MOV (SP)+,12(SP) ;SAVE IN RETURN PARAMS
MOV 2(R0),R0 ;GET CA -2
SUB #6,R0 ;GET ADDRESS OF MEMORY DESCRIPTOR
MOV R0,(R2)+ ;STORE ADDRESS
MOV (R0),(R2) ;STORE WHAT WAS THERE
BIS #100000,(R0) ;MAKE IT SAVED
ADD #10,R0 ;BASE OF ROW
ADD R1,R0 ;ADDRESS OF POINTER
MOV R0,10(SP) ;PUT IN RETURN PARAMS
RETURN: MOV (SP)+,R1 ;RESTORE REGS
MOV (SP)+,R0
MOV (SP)+,R2 ;IN REVERSE OF ORDER SAVED
RTS PC ;RETURN TO CALLER
SEGARY: QUIT <?Segmented array>
INVOPP: JMP INVOP ;INVALID OPERATION
; C O N D I T I O N A L T E S T I N G
;
; THIS ROUTINE USED BY SCAN AND REPLACE OPERATORS TO SEE IF CONDITION
; IS TRUE. TOS IS RETURN ADDRESS, 2ND WORD IS ANSWER INITED TO TRUE.
; R2 BIT #5 0-IN, 1-ROP (REMAINS UNTOUCHED)
; R0 POINTS TO CHAR TO BE TESTED. R0 GETS UPDATED.
; 4(R3) IS <AEXP> FOR ROP AND ADDRESS OF TRUTHID FOR IN.
; BOOLEAN RESULT OF 0-FALSE OR 1-TRUE IS LEFT WHERE RETURN ADDRESS IS.
;
COND: MOV R2,-(SP) ;SAVE R2 (BOTH ROUTINES NEED IT THAT WAY)
BIT #40,R2 ;SEE IF ROP
BNE 10$ ;YES
MOV R0,-(SP) ;SAVE REGS
INC (SP) ;CAUSE WE'RE GOING TO INC R0
MOV R1,-(SP)
CLR -(SP) ;WHERE CHAR TO BE IN-TESTED GOES
MOVB (R0)+,(SP) ;CHAR TO TEST
MOV 4(R3),-(SP) ;ADDRESS OF TRUTHID
JSR PC,IN
MOV (SP)+,10(SP) ;PUT ANSWER IN
BR RETURN ;UNSTORE REGS
10$: MOV #20$,-(SP) ; ** KLUDGE TO FIX INSTR MOD **
MOV #137,-(SP) ; JMP @#XXXX
MOV #14.,-(SP) ;
MOV #5366,-(SP) ; DEC 2(SP)
MOV #2,-(SP) ; SKIP OVER DEC
MOVB 13(SP),1(SP) ; SET IN HIGH PART
CMPB (R0)+,4(R3) ;DO THE COMPARE
JMP @SP ; GO DO CODE
20$: ADD #12.,SP ; FIX UP STACK AND FALL THROUGH
RTS PC ;RETURN
.SBTTL SCMP ROUTINE
; S T R I N G C O M P A R E S
;
; THIS OPERATOR ALLOWS ONE TO COMPARE TWO STRINGS OF THE FORM
; <UPDATE><PE> <ROP> <UPDATE><PE> FOR <AE>
; <UPDATE><PE> <ROP> <QUOTED STRING> [ FOR <AE> ]
; TOS IS A CODE WORD IN WHICH THE FOLLOWING BITS HAVE THE FOLLOWING
; MEANING:
; BIT #0 - IF ON THEN QOUTED STRING COMPARISON
; BIT #1 - IF ON THEN 2ND POINTER IS UPDATED
; BIT #2 - IF ON THEN 1ST POINTER IS UPDATED
; BIT 10:3- ROP (NE-2,EQ-3, ECT.)
; WORD UNDERNEATH IS LENGTH TO DO COMPARE.
; 3RD WORD IS ADDRESS OF STRING
; OR
; 3RD-4TH IS 2ND POINTER
; NEXT TWO WORDS IS 1ST POINTER
; NEXT IS ADDRESS OF 2ND UPDATE POINTER
; NEXT IS ADDRESS OF 1ST UPDATE POINTER
;
; AFTER THE COMPARE STACK IS CLEARED AND THE BOOLEAN RESULT
; OF 0 (FALSE) OR 1 (TRUE) IS LEFT ON THE STACK.
; COMPARISON FOR 0 OR LESS RESULTS IN A TRUE IF ROP IS EQL,LEQ,GEQ
; AND FALSE OTHERWISE.
;
SCMP: MOV (SP)+,R0 ;SAVE CODE WORD
MOV (SP)+,R2 ;MAX LENGTH
BIT #1,R0 ;QUOTED STRING ?
BNE 10$ ;YES
MOV (SP)+,20(R3) ;SET UP 2ND POINTER
MOV (SP)+,16(R3) ;IN THE PRT
CLR 22(R3) ;INDICATE 1ST TIME THRU
BR 20$
10$: MOV (SP)+,R1 ;GET ADDRESS OF STRING
20$: MOV (SP)+,10(R3) ;SET UP 1ST POINTER
MOV (SP)+,6(R3) ;IN THE PRT
CLR 12(R3) ;INITIALIZE IT ALSO
MOV R0,-(SP) ;SAVE CODE WORD
CLR -(SP) ;LENGTH LEFT OF POINTERS = 0
CLR -(SP) ;OF 2ND ALSO
BIT #1,R0 ;SEE IF QUOTED STRING
BEQ 30$ ;NO
MOV R2,(SP) ;YES. RESET LENGTH
INC (SP) ;CAUSE WE CHECK BEFORE, NOT AFTER
30$: TST R2 ;SEE IF DONE YET
BLE SEQL ;YEP. THAT WAS QUICK
S.AGA: DEC 2(SP) ;1ST POINTER NEED RE-FILLING ?
BGT 10$ ;YES, IF IT WAS ZERO
CLR -(SP) ;YES. SET OFFSET
JSR PC,STEST
MOV (SP)+,R0 ;GET NEW ADDRESS
MOV (SP)+,2(SP) ;GET NEW LENGTH FIELD
10$: DEC (SP) ;SEE IF 2ND POINTER NEEDS RE-FILLING
BGT 20$ ;NOT IF THERE WAS AT LEAST 1 CHAR
MOV #10,(SP) ;INDICATE 2ND POINTER THIS TIME
JSR PC,STEST
MOV (SP)+,R1 ;GET ADDRESS OF 2ND POINTER
20$: INC 10(R3) ;INC 1ST POINTER INDEX
INC 20(R3) ;INC 2ND POINTER INDEX
CMPB (R0)+,(R1)+ ;SEE IF EQUAL
BNE SNEQ ;NOPE
SOB R2,S.AGA ;CONTINUE TO SCAN WHILE THEY ARE
SEQL: CMP (SP)+,(SP)+ ;CLEAN THE STACK
CLR R2 ;INITIALIZE ANSWER TO FALSE
;INCASE INITIAL R2 < 0
MOVB 1(SP),R0 ;GET ROP VALUE
CMP R0,#6 ;GTR OR LEQ ?
BGE 10$ ;YES, SO OK
CMP R0,#4 ;EQL OR NEQ ?
BLT 10$ ;YES, ALSO OK
DEC R0 ;ELSE COM BIT #0 FOR EQUALITY TEST
10$: ROR R0 ;SET BIT #0 INTO CARRY
ADC R2 ;BRING IN TRUE IF SO
BR S.DONE
SNEQ: CMP (SP)+,(SP)+ ;CLEAN THE STACK
MOV #1,R2 ;INITIALIZE BOOL RESULT TO TRUE
MOV #T2,-(SP) ; ** KLUDGE TO FIX INSTR MOD **
MOV #137,-(SP) ; JMP @#XXXX
MOV #5302,-(SP) ; DEC R2
MOV #1,-(SP) ; SKIP OVER DEC
MOVB 11(SP),1(SP) ; SET IN HIGH PART
CMPB -(R0),-(R1) ;COMPARE THE LAST TWO CHARS
JMP @SP ; GO DO CODE
T2: ADD #8.,SP ; FIX UP STACK AND FALL THROUGH
S.DONE: TST 12(R3) ;1ST POINTER USED?
BEQ NOT.1 ;NO
MOV 14(R3),@12(R3) ;RESTORE MEM-DESCRIPTOR
NOT.1: ROR (SP) ;STRING ?
BCS 10$ ;YES
TST 22(R3) ;2ND POINTER USED ?
BEQ 10$ ;NO
MOV 24(R3),@22(R3)
10$: ROR (SP) ;SECOND POINTER UPDATED ?
BCC 20$ ;NO
MOV 2(SP),R0 ;GET ADDRESS OF WHERE
MOV 16(R3),(R0)+ ;STORE ARRAY ADDRESS
MOV 20(R3),(R0) ;STORE INDEX
MOV (SP)+,(SP) ;PUSH CODE (WHATS LEFT OF IT)
20$: ROR (SP)+ ;1ST POINTER UPDATED ?
BCC 30$ ;NOPE
MOV (SP)+,R0 ;ADDRESS OF 1ST POINTER
MOV 6(R3),(R0)+ ;STORE ARRAY NAME
MOV 10(R3),(R0) ;STORE INDEX
30$: MOV R2,-(SP) ;STORE BOOLEAN RESULT
JMP INTERP
.SBTTL SCAN ROUTINE
;
; S C A N O P E R A T O R
;
; THIS OPERATOR IS USED FOR SCANNING PART OF AN ARRAY ROW EITHER
; FOR A CONDITION OR FOR A LENGTH. CONDITIONS ARE OF THE FORM:
; UNTIL <ROP> <AE>
; WHILE <ROP> <AE>
; UNTIL IN <TRUTHID>
; WHILE IN <TRUTHID>
; LENGTH IS OF THE FORM:
; FOR <AE> [CONDITION]
; TOP OF STACK IS A CODE WORD IN WHICH THE FOLLOWING BITS HAVE
; THE FOLLOWING MEANING:
; BIT #0 - IF 0 THEN UNCONDITIONAL SCAN (NO CONDITION PART)
; BIT #1 - IF 1 THEN THERE IS A MAXCOUNT & IT IS WORD 3 IN THE STACK
; OTHERWISE THE MAX COUNT IS ASSUMED TO BE 77777
; BIT #2 - IF 1 THEN RES-COUNT UPDATED. ADDRESS IS IN STACK
; BIT #3 - IF 1 THEN POINTER UPDATED. ADDRESS IS IN THE STACK
; BIT #4 - IF 1 THEN WHILE COND OTHERWISE UNTIL COND
; BIT #5 - IF 1 THEN ROP OTHERWISE IN
; BIT#10:3- ROP VALUE + 2 (NE-2,EQ-3,...)
; WORD 2 ARITH EXP OR ADDRESS OF TRUTHID IF CONDITIONAL
; NEXT - MAX-LENGTH (IF BIT #1 IS ON)
; NEXT 2 - POINTER EXPRESSION
; NEXT - RES-UPDATE ADDRESS IF BIT #2 IS ON
; NEXT - POINTER-UPDATE ADDRESS IF BIT #3 IS ON
;
SCAN: MOV (SP)+,R2 ;GET CODE WORD INTO R2
BIT #1,R2 ;SEE IF COND OR ADDRESS OF ID ON TOS
BEQ 10$ ;NO
MOV (SP)+,4(R3) ;YES. STORE IN PRT.
10$: MOV #77777,R1 ;DEFAULT SCAN LENGTH.
BIT #2,R2 ;SEE IF MAX LENGTH ON TOS
BEQ 20$ ;NO
MOV (SP)+,R1 ;YES. GET IT
20$: MOV (SP)+,10(R3) ;GET POINTER INDEX
MOV (SP),6(R3) ;GET ARRAY NAME
CLR 12(R3) ;INDICATE 1ST TIME THRU
MOV R1,(SP) ;PUT LENGTH ON TOS
BLE S.CNT ;FINISH WITH COUNT
S.RFL: CLR -(SP) ;TIME TO REFILL POINTER
JSR PC,STEST
MOV (SP)+,R0 ;ADDRESS
MOV (SP)+,R1 ;LENGTH
10$: BIT #1,R2 ;SEE IF CONDITIONAL