-
Notifications
You must be signed in to change notification settings - Fork 12
Expand file tree
/
Copy pathmon1982.ass
More file actions
3268 lines (3268 loc) · 258 KB
/
Copy pathmon1982.ass
File metadata and controls
3268 lines (3268 loc) · 258 KB
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 'PASCSP, PASCAL RUNTIME SUPPORT AND STANDARD PROCS' 00000010
*********************************************************************** 00000020
* 00000030
* 00000040
* 00000050
* PASCAL ENVIRONMENT AND ENTRY SETUP 00000060
* ------------------------------------ 00000070
* 00000080
* 00000090
* COPYRIGHT 1976, STANFORD LINEAR ACCELERATOR CENTER. 00000100
* 00000110
* 00000120
* THE FOLLOWING PROGRAMS CREATE THE RUN-TIME ENVIRONMENT AND 00000130
* PROVIDE THE I/O INTERFACE FOR THE SLAC 'PASCAL' COMPILER. 00000140
* 00000150
* EXCEPT FOR THE FEW POINTS EXPLAINED IN THIS BOX, THE INTERNALS 00000160
* OF THESE ROUTINES SHOULD BE INVISIBLE (AND INCONSEQUENTIAL) TO 00000170
* THE 'PASCAL' USER. 00000180
* 00000190
* 00000200
* 00000210
* 1) THE USER MAY SPECIFY THE SIZE OF THE RUN TIME STACK/HEAP, 00000220
* THE SIZE OF THE AREA RETURNED TO THE OPERATING SYSTEM FOR I/O 00000230
* BUFFERS, THE MAXIMUM COUNT OF RUN TIME ERRORS, THE RUNNING 00000240
* TIME OF THE PROGRAM, REQUEST AN OPTIONAL MEMORY DUMP AND 00000250
* SPECIFY OTHER SPECIAL CONTROL OPTIONS AS FOLLOWS: 00000260
* 00000270
* // EXEC USERPROG, 00000280
* // PARM='USER PARMS /STACK=XXXK,IOBUF=YYYK, & 00000290
* TIME=TTTS,NOSPIE,NOSNAP,NOCC,DUMP' # 00000300
* 00000310
* 'USER PARMS': THE PARAMETER LIST TO BE PASSED TO THE USER 00000320
* PROGRAM (IF ANY). 00000330
* 'XXX' : STORAGE AREA (IN K BYTES) FOR STACK+HEAP. 00000340
* 'YYY' : STORAGE AREA (IN K BYTES) TO BE RETURNED TO SYSTEM. 00000350
* 'TTT' : PROGRAM RUNNING TIME (IN SECONDS). 00000360
* 'DUMP': TO GENERATE AN OS STYLE MEMORY DUMP IN CASE OF AN 00000370
* ABNORMAL PROGRAM TERMINATION. 00000380
* 'NOSPIE': TO PREVENT INTERCEPTION OF ERROR INTERRUPTS # 00000390
* 'NOSNAP': TO STOP USE OF SNAPSHOT RT. AFTER AN ERROR # 00000400
* 'NOCC': TO STOP FIRST CHARACTER ON EACH LINE FROM BEING # 00000410
* TAKEN AS A CONTROL CHARACTER # 00000420
* DEFAULT VALUE FOR 'XXXK' IS THE JOB 'REGION' SIZE. 00000430
* DEFAULT VALUE FOR 'YYYK' IS 36K. 00000440
* 00000450
* 2) THE VALUE OF THE RETURN CODE 'RC', IF OTHER THAN GENERATED 00000460
* BY THE USER PROGRAM, MAY BE INTERPRETED ACCORDING TO THE 00000470
* FOLLOWING TABLE. FOR MORE DETAILED EXPANATION OF THE ERROR 00000480
* CONDITION, SEE THE CONTENTS OF THE 'OUTPUT' FILE WHICH HAVE 00000490
* THE APPROPRIATE MESSAGES. NOTE THAT THIS FILE (OUTPUT) SHOULD 00000500
* BE INCLUDED IN THE USER PROGRAM IN ORDER TO GET THE RUN TIME 00000510
* DIAGNOSTICS AND RELATED MESSAGES. 00000520
* 00000530
* RETURN CODE: IMPLIES: 00000540
* 00000550
* 1001 INDEX VALUE OUT OF RANGE 00000560
* 1002 SUBRANGE VALUE OUT OF RANGE 00000570
* 1003 ACTUAL PARAMETER OUT OF RANGE 00000580
* 1004 SET MEMBER OUT OF RANGE 00000590
* 1005 POINTER VALUE INVALID 00000600
* 1006 STACK/HEAP COLLISION 00000610
* 1007 ILLEGAL INPUT/RESET OPERATION 00000620
* 1008 ILLEGAL OUTPUT/REWRITE OPERATION 00000630
* 1009 SYNCHRONOUS I/O ERROR 00000640
* 1010 PROGRAM EXCEEDED SPECIFIED RUNNING TIME 00000650
* 1011 ILLEGAL FILE DEFINITION (I.E., TOO MANY FILES) 00000660
* 1012 NOT ENOUGH STACK SPACE 00000670
* 1013 UNDEFINED OR OBSOLETE CSP CALL # 00000680
* 1014 LINELIMIT EXCEEDED FOR A FILE # 00000690
* 1015 BAD FILE CONTROL BLOCK @ 00000700
* 1016 INPUT RECORD TOO LARGE @ 00000710
* 1020 READ PAST END OF FILE # 00000720
* 1021 BAD BOOLEAN INPUT # 00000730
* 1022 BAD INTEGER INPUT # 00000740
* 1023 BAD REAL INPUT # 00000750
* 1024 OVER-LARGE INTEGER INPUT & 00000760
* 00000770
* 200X PROGRAM INTERRUPTION CODE 'X' 00000780
* 00000790
* 3001 MISC. EXTERNAL ERROR CONDITIONS. 00000800
* 00000810
* X1XX UNABLE TO RUN SNAPSHOT, OTHER DIGITS AS ABOVE 00000820
* 00000830
* 00000840
* 3) THE CONDITIONAL ASSEMBLY FLAG &SYSTEM DETERMINES WHETHER # 00000850
* CERTAIN SECTIONS OF CODE ARE INCLUDED IN THE PROGRAM. # 00000860
* WITH &SYSTEM=1, SOME CHECKING CODE, REAL NUMBER INPUT AND THE # 00000870
* FORTRAN INTERFACE IS OMITTED. THIS RESULTS IN A SMALLER # 00000880
* FASTER PROGRAM BUT WHICH CAN ONLY BE USED WITH "SAFE" # 00000890
* PROGRAMS THAT DO NOT USE MATHEMATICAL ROUTINES - SUCH AS THE # 00000900
* COMPILER AND THE P-ASSEMBLER. # 00000910
* WITH &SYSTEM=0, THE FULL PROGRAM IS PRODUCED AND THIS IS THE # 00000920
* VERSION THAT SHOULD NORMALLY BE COMBINED WITH USER PROGRAMS. # 00000930
* THE CONDITIONAL ASSEMBLY FLAG &IBM370 DETERMINES WHETHER @ 00000940
* IBM370 INSTRUCTIONS MAY BE GENERATED. WHEN &IBM370=1, @ 00000950
* THESE INSTRUCTIONS (E.G. MVCL) ARE USED FOR SPEED IN A FEW @ 00000960
* CASES. WHEN &IBM370=0, ONLY IBM360 INSTRUCTIONS ARE USED. @ 00000970
* 00000980
* 00000990
* 4) THIS PROGRAM MAY BE ASSEMBLED WITH MOST STANDARD IBM # 00001000
* ASSEMBLERS. # 00001010
* 00001020
* 00001030
* 5) IF THE RUN PROFILE SWITCH IS ENABLED IN THE PASCAL PROGRAM 00001040
* (I.E. 'K+'), THE RUN TIME SYSTEM WILL 'REWRITE' THE 'RAW' 00001050
* EXECUTION COUNTS ON THE PREDEFINED 'QRR' FILE AFTER RUNNING 00001060
* THE USER PROGRAM. IN SUCH CASES THE USER PROGRAM SHOULD NOT 00001070
* USE THE 'QRR' FILE BUT THE 'DD' STATEMENT FOR THIS FILE SHOULD 00001080
* BE INCLUDED IN THE 'GO' STEP. THE SUBMONITOR WILL SUBSEQUENTLY 00001090
* INVOKE THE "PASPROF" LOAD-MODULE TO PRINT THE PROFILE. 00001100
* 00001110
* 00001120
* 00001130
* 00001140
* THESE PROGRAMS INCLUDE SOME CONTRIBUTIONS BY KEITH RICH, JOHN 00001150
* BANNING AND NIGEL HORSPOOL. 00001160
* 00001170
* 00001180
* 00001190
* SASSAN HAZEGHI, 00001200
* 00001210
* COMPUTATION RESEARCH GROUP 00001220
* STANFORD LINEAR ACCELERATOR CENTER 00001230
* P. O. BOX 4349 00001240
* STANFORD, CALIFORNIA 94305. 00001250
* 00001260
* 00001270
* 00001280
* LAST UPDATE: 00001290
* MAR. 15, 76. 00001300
* SEPT. 8, 76. 00001310
* JAN. 20, 77. 00001320
* JULY 28, 77. 00001330
* MAY 21, 77. 00001340
* JULY 6, 78. 00001350
* SEPT. 15, 78. 00001360
* NOV. 11, 78. 00001370
* AUG. 09, 79. 00001380
* 00001390
* FURTHER MODIFICATIONS MADE AT MCGILL UNIVERSITY, # 00001400
* # 00001410
* R. NIGEL HORSPOOL # 00001420
* APRIL 7, 1982 & 00001430
*
* Minor mods made by Dave Edwards (DE), Jan/2007 - see below.
*
* See also: $psc:pascal.mon.notes
* $psc:pascal.lib.notes
*
* *** This module, assembled with &SYSTEM set to 0, also forms
* part of $psc:pascal.lib (run-time library object).
*
* 28jan2007 - JCL added an top of file, and module reassembled.
* No change to the source. See $psc:pascal.mon.notes . (DE)
* 28jan2007 - Fix year-2000 problem when setting PASDATE (for the
* Pascal predefined variable DATE e.g. '01-28-2007'): set correct
* century if actual year is 20yy and this seems to be a MUSIC/SP
* system. Previously, year 20nn would be reported as 19nn.
* (But coding is still incorrect for years like 2100, because
* that year is not a leap year.) (DE)
* 00001440
*********************************************************************** 00001450
EJECT 00001460
************************************************************** 00001470
* 00001480
* I/O (FILE) HANDLING MACROS 00001490
* 00001500
************************************************************** 00001510
* 00001520
MACRO , 00001530
&L FILADR , 00001540
.* TO COMPUTE FILE BUFFER ADDRESS ETC. 00001550
GBLB &SYSTEM @ 00001560
&L L AE,PFILPTR(AD) LOAD FILE BLOCK ADDR @ 00001570
AIF (&SYSTEM).NOCHK @ 00001580
C AD,FILPAS(AE) CHECK THAT FILE BLOCK POINTS @ 00001590
BNE BADFILE TO PASCAL FILE VARBL. @ 00001600
.NOCHK L AF,FILBUF(AE) SET I/O BUFFER POINTER @ 00001610
MEND , 00001620
* 00001630
MACRO , # 00001640
FILDEF &NAME,&DIRECT,&KIND,&LINK @ 00001650
.* DEFINE A FILE @ 00001660
LCLC &NAM,&OPT1,&OPT2 00001670
DS 0D # 00001680
&NAM SETC '&NAME'(1,3) # 00001690
FIL&NAM DC CL8'&NAME' PASCAL FILE IDENTIFIER @ 00001700
DC A(&LINK) PTR TO NEXT FILE BLOCK @ 00001710
DC A(0) PTR TO PASCAL FILE VRBL. @ 00001720
DC A(0) I/O BUFFER ADDRESS @ 00001730
DC F'0' LINE-LIMIT FOR FILE (ON OUTPUT) @ 00001740
DC H'0' CURRENT RECORD LENGTH (TEXTFILE) @ 00001750
AIF ('&KIND' NE 'TEXT').FD2 @ 00001760
&OPT1 SETC 'PL' LOCATE-MODE OUTPUT NEEDED @ 00001770
AIF ('&DIRECT' EQ 'OUTPUT').FD1 @ 00001780
&OPT1 SETC 'GL' LOCATE-MODE INPUT NEEDED @ 00001790
AIF ('&DIRECT' EQ 'INPUT').FD1 @ 00001800
&OPT2 SETC 'PL' BOTH LOCATE MODE INPUT & OUTPUT @ 00001810
.FD1 DC AL1(TEXTFLAG,0) OPEN/TEXT FLAGS, EOF FLAG @ 00001820
DC H'0',H'0' CHAR PTR, CHAR START POS @ 00001830
AGO .FD3 @ 00001840
.FD2 DC AL1(0,0) OPEN/TEXT FLAGS, EOF FLAG @ 00001850
DC H'0',H'0' MAX REC SIZE, FILE COMP. SIZE @ 00001860
&OPT1 SETC 'GM' MOVE-MODE INPUT AND @ 00001870
&OPT2 SETC 'PM' MOVE-MODE OUTPUT NEEDED @ 00001880
.FD3 ANOP , @ 00001890
DCB DSORG=PS,DDNAME=&NAME,EODAD=EOD,SYNAD=SYNADRT, @ X00001900
EXLST=XL&DIRECT,BFTEK=A,MACRF=(&OPT1,&OPT2) @ 00001910
MEND , @ 00001920
* # 00001930
EJECT 00001940
GBLB &SYSTEM,&IBM370 @ 00001950
&SYSTEM SETB 1 TRUE INDICATES A COMPACT 'CSP' 00001960
&IBM370 SETB 0 TRUE INDICATES AN IBM-370 @ 00001970
* 00001980
AIF (&SYSTEM).SYS1 00001990
* GENERAL SETUP FOR USER PROGRAM(S). 00002000
AGO .USE1 00002010
.SYS1 ANOP 00002020
* COMPACT SETUP, OMITS FORTRAN INTERFACE & TRACING 00002030
.USE1 ANOP 00002040
* 00002050
* 00002060
* 00002070
EJECT 00002080
*************************************************************** 00002090
* 00002100
* STACK (AND SAVE AREA) LAYOUT 00002110
* 00002120
*************************************************************** 00002130
* 00002140
* 00002150
PRINT NOGEN 00002160
DCBD DSORG=PS 00002170
PRINT GEN 00002180
* 00002190
DYNSTORE DSECT , 00002200
DS 20F PASCAL ENVIRONMENT SAVE AREA 00002210
STACK DS 18F BOTTOM OF RUNTIME STACK 00002220
CLOCK EQU STACK CLOCK LOCATION 00002230
NEWPTR DS A PASCAL 'NEW' POINTER 00002240
HEAPLIM DS A UPPER LIMIT OF HEAP ( +1 ) 00002250
* ALSO POINTS TO DYN2STOR 00002260
DISPREGS DS 10F RUN TIME DISPLAY REGISTERS 00002270
DISPLAY EQU DISPREGS,*-DISPREGS 00002280
FL1 DS D R/W FIX/FLOAT CONVERSION HELPS 00002290
FL2 DS D R ONLY 00002300
FL3 DS D R/W 00002310
FL4 DS D R ONLY 00002320
CHKSUBS DS 0F ENTRY TO RUN TIME CHECK ROUTINES 00002330
INXCHK DS 3F INDEX CHECK 00002340
RNGCHK DS 3F SUBRANGE CHECK 00002350
PRMCHK DS 3F PARAMETER VALUE CHECK 00002360
PTRCHK DS 3F POINTER CHECK 00002370
PTACHK DS 3F SET MEMBER CHECK 00002380
SETCHK DS 3F 00002390
STKCHK DS 3F 00002400
TRACER DS 3F & 00002410
INPUT DS 3F @ 00002420
OUTPUT DS 3F @ 00002430
PRD DS 3F @ 00002440
PRR DS 3F @ 00002450
QRD DS 3F @ 00002460
QRR DS 3F @ 00002470
CLEARBUF DS XL8 BUFFER TO CLEAR ACTIVATION RECORDS 00002480
PASDATE DS CL10 PREDEFINED VARIABLE DATE 00002490
PASTIME DS CL10 PREDEFINED VARIABLE TIME 00002500
OSPRMPTR DS A POINTER TO O.S. PARM STRING # 00002510
FRSTGVAR DS 0D FOR ALIGNMENT PURPOSES 00002520
* 00002530
* DYNAMIC STORAGE AREA POINTED TO BY HEAPLIM 00002540
* 00002550
DYN2STOR DSECT , 00002560
DYNRUNC DS F # OF RUN TIME FREQUENCY COUNTERS 00002570
DS 0D 00002580
DYNCOUNT DS 0F 00002590
AIF (&SYSTEM).SYS3 00002600
DYN2LEN EQU 128 EXTRA MARGIN FOR PATHOLOGICAL CALL PARMS 00002610
AGO .USE3 00002620
.SYS3 ANOP 00002630
DYN2LEN EQU *-DYN2STOR 00002640
.USE3 ANOP 00002650
* 00002660
EJECT 00002670
************************************************************** 00002680
* 00002690
* PASCAL ENTRY POINT AND PROGRAM PROLOGUE 00002700
* 00002710
************************************************************** 00002720
* 00002730
* 00002740
$PASENT CSECT , 00002750
ENTRY $PASENT,$PASCSP,$PASINT,$TRACER & 00002760
* 00002770
* 00002780
USING *,15 00002790
SAVE (14,12),,* 00002800
LR R10,R15 00002810
DROP R15 00002820
USING $PASENT,R10 00002830
ST R1,OSPARMS SAVE ADDRESS OF O.S. PARMS # 00002840
L R1,0(R1) 00002850
SPACE 00002860
* 00002870
* R1 POINTS TO THE PARAMETER LIST THE FIRST HALF WORD OF 00002880
* WHICH GIVES THE LENGTH OF THE LIST 00002890
* 00002900
LH R2,0(R1) 00002910
LTR R2,R2 00002920
BNH NOPARM NO PARAMETER LIST SPECIFIED 00002930
LA R0,256 SET MAX STRING LENGTH # 00002940
CR R2,R0 # 00002950
BNH *+6 JUMP IF LENGTH OK # 00002960
LR R2,R0 ENFORCE THE LIMIT # 00002970
LA R8,1 INCREMENT FOR BXLE & BXH # 00002980
LA R9,1(R1,R2) LIMIT FOR BXLE & BXH # 00002990
LA R1,2(,R1) POINT AT FIRST CHAR # 00003000
ST R1,OSPARMAD SAVE ADDRESS FOR LATER # 00003010
* 00003020
PARMRTRY CLI 0(R1),C'/' 00003030
BE PARMSLSH SEPARATOR FOUND ? # 00003040
BXLE R1,R8,PARMRTRY # 00003050
* 00003060
PARMSLSH LR R3,R1 # 00003070
SL R3,OSPARMAD COMPUTE STRING LENGTH # 00003080
STH R3,OSPARML SAVE IT FOR LATER # 00003090
BXH R1,R8,NOPARM JUMP IF STRING END # 00003100
GOTPARM SR R0,R0 CLEAR NEGATE FLAG & 00003110
CLI 0(R1),C',' 00003120
BNE *+8 00003130
LA R1,1(,R1) 00003140
CLC 0(2,R1),=C'NO' TEST FOR NEGATION OF KEYWORD & 00003150
BNE *+12 & 00003160
LA R0,X'FF' SET NEGATION FLAG & 00003170
LA R1,2(,R1) & 00003180
LA R5,KWRDTAB & 00003190
SR R3,R3 & 00003200
KWRDSRCH IC R3,2(,R5) LOAD KEYWORD LENGTH-1 & 00003210
LTR R3,R3 ZERO FLAGS TABLE END & 00003220
BZ NXTPARM SO EXIT & 00003230
EX R3,KWRDCLC COMPARE NEXT KEYWORD & 00003240
BE KWRDFND JUMP IF MATCHED & 00003250
LA R5,4(R3,R5) STEP TO NEXT ENTRY & 00003260
B KWRDSRCH AND REPEAT & 00003270
KWRDCLC CLC 0(*-*,R1),3(R5) & 00003280
KWRDFND LA R1,1(R3,R1) ADVANCE IN PARM STRING & 00003290
CLI 1(R5),0 TEST NUMERIC INPUT FLAG & 00003300
BE KWRDNON JUMP IF NOT WANTED & 00003310
LTR R0,R0 TEST IF "NO" SPECIFIED & 00003320
BNZ KWRDNON IF SO, NO INTEGER FOLLOWS & 00003330
BAL R7,GETNUM GET AN INTEGER & 00003340
LTR R4,R4 TEST FOR VALIDITY & 00003350
BNP NXTPARM AND IGNORE IF NO GOOD & 00003360
SR R3,R3 RE-CLEAR R3 (USED BY GETNUM) & 00003370
KWRDNON IC R3,0(,R5) GET RELATIVE ADDRESS & 00003380
B KWRDSTAK(R3) AND GO TO THIS ROUTINE & 00003390
* 00003400
KWRDSTAK LTR R0,R0 TEST "NO" OPTION & 00003410
BNZ NXTPARM IF SO, IGNORE & 00003420
SLA R4,10 CONVERT TO K 00003430
ST R4,REQSTORE RESET REGION SIZE 00003440
ST R4,REQSTORE+4 AND SET MAXIMUM STORAGE 00003450
B NXTPARM 00003460
* 00003470
KWRDIOB LTR R0,R0 TEST "NO" OPTION & 00003480
BNZ NXTPARM IF SO, IGNORE & 00003490
SLA R4,10 CONVERT TO K 00003500
ST R4,BUFSTORE SET I/O BUFFER AMOUNT 00003510
B NXTPARM 00003520
* 00003530
KWRDDUMP STC R0,DUMPFLAG SET THE DUMP FLAG & 00003540
XI DUMPFLAG,X'FF' BUT R0 WAS REVERSED & 00003550
B NXTPARM 00003560
* 00003570
KWRDTIME LTR R0,R0 TEST "NO" OPTION & 00003580
LH R5,=H'-1' SET FOR UNLIMITED EXECUTION & 00003590
BNZ KWRDTIM2 & 00003600
LR R5,R4 00003610
M R4,=F'38400' CONVERT TO TIMER UNITS & 00003620
CLI 0(R1),C'M' TEST FOR TIME IN & 00003630
BNE KWRDTIM2 THOUSANDTHS OF A SECOND & 00003640
D R4,=F'1000' IF SO, CONVERT & 00003650
KWRDTIM2 ST R5,EXECTIME AND SAVE FOR STIMER & 00003660
B NXTPARM 00003670
* 00003680
KWRDCC L R15,=A(CCFLAG) FLAG NOT DIRECTLY ADDRESSABLE & 00003690
STC R0,0(,R15) SET THE FLAG & 00003700
B NXTPARM 00003710
* 00003720
KWRDSPIE STC R0,SPIEFLAG SET THE FLAG & 00003730
B NXTPARM & 00003740
* 00003750
KWRDSNAP STC R0,SNAPFLAG SET THE FLAG & 00003760
B NXTPARM 00003770
* 00003780
NXTPARM BXLE R1,R8,GOTPARM STEP TO NEXT CHAR # 00003790
* # 00003800
* # 00003810
* DDNAME-LIST PARAMETER PROCESSING # 00003820
* # 00003830
NOPARM EQU * # 00003840
L R1,OSPARMS # 00003850
TM 0(R1),X'80' TEST IF DDNAME LIST PROVIDED # 00003860
BO NODDPARM # 00003870
L R1,4(,R1) ADDRESS OF DDNAME LIST PARM # 00003880
LH R2,0(,R1) LENGTH OF LIST IN BYTES # 00003890
L AE,=A(FILLIST) POINT AT FIRST FILE IN @ 00003900
L AE,0(,AE) THE CHAIN OF FILE BLOCKS @ 00003910
DDLOOP SH R2,=H'8' CHECK FOR END OF DDNAME LIST # 00003920
BM NODDPARM # 00003930
TM 2(R1),X'FF' CHECK FOR BINARY ZEROS @ 00003940
BZ DDDFLT IF SO, DONT CHANGE DDNAME # 00003950
USING IHADCB-FILDCB,AE # 00003960
MVC DCBDDNAM(8),2(R1) MOVE NEW DDNAME INTO DCB # 00003970
DDDFLT LA R1,8(,R1) ADVANCE THROUGH LIST # 00003980
L AE,FILLNK(AE) ADVANCE TO NEXT FILE IN CHAIN @ 00003990
LTR AE,AE TEST FOR END OF CHAIN @ 00004000
BNZ DDLOOP IF NOT END, REPEAT @ 00004010
NODDPARM EQU * # 00004020
* 00004030
* 00004040
* GET SPACE FOR THE RUN TIME STACK 00004050
* 00004060
L R0,BUFSTORE 00004070
A R0,REQSTORE COMPUTE THE SIZE OF THE SMALLEST 00004080
ST R0,REQSTORE AREA THAT WILL MEET THE DEMAND 00004090
C R0,REQSTORE+4 00004100
BL *+8 UPPER BOUND OK ? 00004110
ST R0,REQSTORE+4 ADJUST IT IF NEEDED. 00004120
* 00004130
* GET ENOUGH SPACE FOR STACK+IOBUF NOW 00004140
* 00004150
GETMAIN VU,LA=REQSTORE,A=ALOSTORE 00004160
SPACE , 00004170
* 00004180
L R1,ALOSTORE GET ADDRESS OF ALLOCATED AREA 00004190
LR R12,R1 00004200
A R1,ALOSTORE+4 ADD SIZE OF THE AREA 00004210
S R1,BUFSTORE BEGINNIG (ENDING !) OF THE HEAP 00004220
S R1,=A(8) NAME FIELD OF THE HEAP 00004230
USING DYNSTORE,GBR @ 00004240
AIF (&SYSTEM).SYS32 00004250
* 00004260
LR R2,R1 00004270
SR R2,R12 R2 <-- SIZE OF THE USABLE AREA 00004280
L R3,=A(FRSTGVAR-STACK) @ 00004290
CLR R2,R3 @ 00004300
BNH NOCLR SKIP IF NOT LARGE ENOUGH 00004310
AIF (&IBM370).M720 @ 00004320
LR R2,R3 @ 00004330
LD FPR0,=XL8'8181818181818181' 00004340
SRA R2,3 CONVERT BYTE COUNT TO D_WORD COUNT 00004350
LA R3,STACK @ 00004360
STD FPR0,0(R3) 00004370
LA R3,8(R3) 00004380
BCT R2,*-8 00004390
AGO .M620 @ 00004400
.M720 LR R2,R12 ADDRESS OF STACK @ 00004410
LA R15,X'81' @ 00004420
SLL R15,24 SET PADDING CHAR FOR MVCL @ 00004430
MVCL R2,R14 CLEAR THE AREA @ 00004440
.M620 ANOP @ 00004450
* 00004460
.SYS32 ANOP 00004470
NOCLR ST R13,4(R12) BACK LINK OF NEW SAVE AREA 00004480
ST R12,8(R13) FRWRD LINK OF OLD SAVE AREA 00004490
LR R13,R12 RESET SAVE AREA POINTER 00004500
* 00004510
MVC STACK-8(8),=CL8' STACK' 00004520
MVC 0(8,R1),=CL8'HEAP ' 00004530
LA R12,STACK GLOBAL (STACK BOTTOM) POINTER 00004540
USING STACK,R12 00004550
ST R1,NEWPTR SET PASCAL 'NEW' PONTER 00004560
* 00004570
* CLEAR DISPLAY PSEUDO REGISTERS 00004580
* 00004590
MVI DISPLAY,X'FF' SET DISP REGS TO '-1' 00004600
MVC DISPLAY+1(L'DISPLAY-1),DISPLAY 00004610
SPACE , @ 00004620
* @ 00004630
* LINK PASCAL FILE VARIABLES TO FILE CONTROL @ 00004640
* BLOCKS IN THIS SUBMONITOR PROGRAM @ 00004650
* @ 00004660
L AE,=A(FILLIST) @ 00004670
L AE,0(,AE) POINT TO FIRST FILE CONTROL BLOCK @ 00004680
LA AD,INPUT POINT TO FIRST FILE VARIABLE @ 00004690
FILLP ST AD,FILPAS(AE) SET LINK FROM HERE TO THERE @ 00004700
ST AE,PFILPTR(AD) AND FROM THERE TO HERE @ 00004710
MVI PFILEOF(AD),TRUE INITIALIZE EOF FLAG IN PASCAL @ 00004720
MVI PFILEOL(AD),TRUE INITIALIZE EOL FLAG IN PASCAL @ 00004730
LA AD,PFILTSIZ(AD) ADVANCE TO NEXT BUILT IN VRBL. @ 00004740
L AE,FILLNK(AE) ADVANCE TO NEXT FILE CONTROL BLOCK@ 00004750
LTR AE,AE TEST FOR END OF LIST @ 00004760
BNZ FILLP REPEAT @ 00004770
SPACE , 00004780
L R0,BUFSTORE SIZE OF THE AREA TO BE RETURNED 00004790
LA R1,8(R1) ADDRESS OF THE AREA TO BE RETURNED 00004800
LR R2,R1 00004810
SR R2,R12 R2 <-- SPACE LEFT FOR THE STACK 00004820
C R2,USESTORE 00004830
LA R2,SPCERR ERROR CODE FOR LACK OF SPACE 00004840
BL QUIT1 00004850
* 00004860
* FREE SOME SPACE FOR O/S FILE BUFFERS (4K/FILE !) 00004870
* 00004880
FREEMAIN R,LV=(R0),A=(R1) 00004890
L R1,ALOSTORE+4 KEEP TRACK OF HOW MUCH CORE # 00004900
S R1,BUFSTORE TO RETURN TO THE O.S. # 00004910
ST R1,ALOSTORE+4 AT END OF EXECUTION # 00004920
SPACE , 00004930
* 00004940
* INITIALIZE FORTRAN ENVIRONMENT (IF THERE ARE FORTRAN 00004950
* ROUTINES IN THE LOAD MODULE) 00004960
* 00004970
AIF (&SYSTEM).SYS325 00004980
L R15,=V(IBCOM#) SEE IF FORTRAN ENVIRONMENT INCLUDED 00004990
LTR R15,R15 00005000
BZ NOFORT 00005010
BAL R14,IBCOMINI(R15) IF SO CALL IBCOM# INIT ENTRY POINT 00005020
* 00005030
* NOTE: THIS CALL SAVES R13 FOR IBCOMXIT, BE SURE TO HAVE 00005040
* THE SAVE AREA CONSISTENT PRIOR TO CALLING IBCOMXIT 00005050
* 00005060
.SYS325 ANOP 00005070
* 00005080
* SET THE 'SPIE' TO TRAP PROGRAM INTERRUPTS 00005090
* 00005100
NOFORT CLI SPIEFLAG,X'00' TEST IF SPIE TO BE ISSUED # 00005110
BNE NOSPIE # 00005120
SPIE MF=(E,PASSPIE) OTHERWISE TRAP TO $PASINT # 00005130
ST R1,OLDPICA SAVE PRVIOUS PICA ADDRESS 00005140
NOSPIE EQU * 00005150
* 00005160
* SETUP DYN2STOR AREA 00005170
* 00005180
L R1,NEWPTR TOP OF HEAP 00005190
S R1,=A(DYN2LEN) LESS SIZE OF DYN2 00005200
ST R1,HEAPLIM AND LIMIT 00005210
USING DYN2STOR,R1 00005220
SR R0,R0 00005230
ST R0,DYNRUNC CLEAR '# OF COUNTERS' FIELD 00005240
LH R2,OSPARML # 00005250
LTR R2,R2 # 00005260
BZ OSPARM1 JUMP IF NO PARM STRING # 00005270
SLR R1,R2 # 00005280
SL R1,=F'4' ALLOCATE PARM STRING RECORD # 00005290
SRL R1,3 FORCE TO DOUBLE-WORD BOUNDARY # 00005300
SLL R1,3 # 00005310
ST R2,0(,R1) PUT STRING LENGTH IN RECORD # 00005320
L R3,OSPARMAD # 00005330
BCTR R2,0 # 00005340
EX R2,OSPRMMVC MOVE STRING INTO RECORD # 00005350
ST R1,OSPRMPTR SET POINTER TO RECORD # 00005360
B OSPARM2 # 00005370
OSPRMMVC MVC 4(0,R1),0(R3) # 00005380
OSPARM1 BCTR R2,0 SET POINTER TO NIL # 00005390
ST R2,OSPRMPTR # 00005400
OSPARM2 ST R1,NEWPTR # 00005410
DROP R1 # 00005420
* 00005430
* 00005440
* 00005450
* DISABLE INTEGER OVERFLOW, EXPONENT UNDERFLOW AND 00005460
* SIGNIFICANCE INTERRUPTS. 00005470
* 00005480
SR R6,R6 00005490
SPM R6 DISABLE ALL MASKABLE INTERRUPTS @ 00005500
SPACE , 00005510
MVC FL1,=X'4E00000000000000' INITIALIZE FIX-FLOAT-FIX 00005520
MVC FL2,=X'4E00000080000000' CONVERSION VALUES 00005530
MVC FL3,=X'0000000000000000' 00005540
MVC FL4,=X'4F08000000000000' 00005550
SPACE , 00005560
MVC CHKSUBS(L'CALLSUBS),CALLSUBS INIT. RUN TIME CHECK AREA 00005570
MVC CLOCK,EXECTIME SET THE ALARM CLOCK 00005580
STIMER TASK,$TIMEOUT,TUINTVL=CLOCK 00005590
* 00005600
* INITIALIZE DATE/TIME PREDEFINED VARIABLES 00005610
* 00005620
TIME DEC GET TOD IN TU 00005630
ST R1,DATESAV PUT DATE IN WORK AREA 00005640
CP DATESAV+2(2),=PL2'59' 00005650
BNH LY 00005660
TM DATESAV+1,1 LEAP YEAR? 00005670
BNZ NLY NO 00005680
TM DATESAV+1,X'12' LEAP YEAR? 00005690
BNM LY YES 00005700
NLY AP DATESAV+2(2),=P'1' 00005710
LY LA R4,JAN 00005720
LA R3,12 00005730
ZAP MONTH(3),=P'0' 00005740
MDLP AP MONTH(3),=P'1000' BUMP MONTH 00005750
CP DATESAV+2(2),0(2,R4) THIS MONTH? 00005760
BNH MDEND BR IF SO 00005770
SP DATESAV+2(2),0(2,R4) TRY NEXT 00005780
LA R4,2(R4) 00005790
BCT R3,MDLP 00005800
MDEND L R3,DATESAV 00005810
N R3,=X'00FF0000' GET YEAR 00005820
O R3,MONTH-2 INSERT MONTH 00005830
L R4,DATESAV GET DAY 00005840
SRL R4,4 00005850
N R4,=X'000000FF' 00005860
OR R3,R4 00005870
ST R3,DATESAV PREPARE TO REFORMAT DATE 00005880
UNPK DATESAV(9),DATESAV(5) 00005890
MVC PASDATE(10),=X'04050B06070B00010203' @ 00005900
TR PASDATE(10),DATESAV RE-ORDER THE CHARACTERS @ 00005910
*** QUICK YEAR-2000 FIX (MUSIC/SP ONLY): THE CORRECT 4-DIGIT YEAR
*** IS 4 CHARS AT LOWCORE ADDR X'3AC'+12 ($NOWDATE+12).
*** NOTE: STILL, ABOVE LEAP-YEAR CODING IS WRONG STARTING IN THE
*** YEAR 2100, SINCE THAT YEAR IS NOT A LEAP YEAR.
$NOWDATE EQU X'3AC'
CLC =C'20',$NOWDATE+12
BNE Y2KB1 19XX OR MAYBE NOT MUSIC/SP: LEAVE AS IS
MVC PASDATE+6(2),$NOWDATE+12 FIX 1ST 2 DIGITS OF YEAR
Y2KB1 DS 0H
*** END OF YEAR-2000 FIX.
* 00005920
* FIX TIME OF DAY STRING 00005930
* 00005940
ST R0,DATESAV 00005950
UNPK DATESAV(7),DATESAV(4) CONVERT TO EBCDIC 00005960
MVC PASTIME(10),=X'00010A02030A04054040' @ 00005970
TR PASTIME(8),DATESAV RE-ORDER THE CHARACTERS @ 00005980
* 00005990
* FINALLY CALL THE USER PROGRAM 00006000
* 00006010
LA 1,STACK 00006020
L LINK,=A($MAINBLK) 00006030
BALR RET,LINK 00006040
* 00006050
* CLOSE THE OPEN FILES AND RETURN TO OS 00006060
* 00006070
SR R2,R2 RETURN CODE = ZERO ! 00006080
QUIT1 LA R1,PXIT CLOSE OPEN FILES / RETURN TO OS 00006090
L LINK,=A($PASCSP) 00006100
BR LINK EXIT PASCAL PROGRAM 00006110
* 00006120
* 00006130
* GET THE NEXT INTEGER IN THE PARAMETER LIST 00006140
* 00006150
BXH R1,R8,NOPARM QUIT IF NO MORE CHARS # 00006160
GETNUM CLI 0(R1),C'=' 00006170
BNE GETNUM-4 SKIP UNTIL THE FIRST '=' 00006180
* 00006190
SR R3,R3 00006200
SR R4,R4 CLEAR ACCUMULATOR 00006210
* 00006220
NXTDIG BXH R1,R8,0(R7) RETURN IF NO MORE CHARS # 00006230
CLI 0(R1),C'9' 00006240
BHR R7 OR IF A NON DIGIT 00006250
IC R3,0(R1) 00006260
SH R3,=Y(C'0') 00006270
BLR R7 IS ENCOUNTERED 00006280
MH R4,=H'10' 00006290
AR R4,R3 OTHERWISE KEEP ACCUMULATING 00006300
B NXTDIG 00006310
* 00006320
EJECT 00006330
**************************************************************** 00006340
* 00006350
* TABLE OF CALLS FOR RUN TIME CHECK ROUTINES. TO BE COPIED 00006360
* ,EXACTLY AS IS, ONTO THE RUN TIME STACK. 00006370
* 00006380
**************************************************************** 00006390
* 00006400
CALSUB DS 0F 00006410
CALLINX L R15,INXCHK+8 00006420
BR R15 00006430
DC A($INXCHK) 00006440
* 00006450
CALLRNG L R15,RNGCHK+8 00006460
BR R15 00006470
DC A($RNGCHK) 00006480
* 00006490
CALLPRM L R15,PRMCHK+8 00006500
BR R15 00006510
DC A($PRMCHK) 00006520
* 00006530
CALLPTR L R15,PTRCHK+8 00006540
BR R15 00006550
DC A($PTRCHK) 00006560
* 00006570
CALLPTA L R15,PTACHK+8 00006580
BR R15 00006590
DC A($PTACHK) 00006600
* 00006610
CALLSET L R15,SETCHK+8 00006620
BR R15 00006630
DC A($SETCHK) 00006640
* 00006650
CALLSTK L R15,STKCHK+8 00006660
BR R15 00006670
DC A($STKCHK) 00006680
* 00006690
CALLTRC L R15,TRACER+8 & 00006700
BR R15 & 00006710
DC A($TRACER) & 00006720
* 00006730
CALLSUBS EQU CALSUB,*-CALSUB 00006740
* 00006750
DROP R10 00006760
EJECT 00006770
* 00006780
BUFSTORE DC A(IOBUFSZE) 00006790
REQSTORE DC A(MINSTORE,MAXSTORE) 00006800
ALOSTORE DS 2A 00006810
OSPARMS DS A ADDRESS OF O.S. PARAMETERS # 00006820
OSPARMAD DC A(0) POINTER TO O.S. STRING # 00006830
USESTORE DC A(8000) 00006840
OLDPICA DC A(1) # 00006850
EXECTIME DC XL4'7FFFFFFF' DEFAULT TIME LIMIT 00006860
PASSPIE SPIE $PASINT,((1,7),9,11,12,15),MF=L # 00006870
OSPARML DC H'0' LENGTH OF PARM STRING # 00006880
DUMPFLAG DC X'00' X'FF' IF DUMP REQUESTED 00006890
SPIEFLAG DC X'00' X'FF' IF SPIE NOT TO BE ISSUED # 00006900
SNAPFLAG DC X'00' X'FF' IF SNAPSHOT NOT TO BE CALLED# 00006910
* 00006920
DATESAV DS 2F # THESE LOCATIONS TO SUCCEED WITH NO GAPS @ 00006930
DC C' :-' # (UNPACKING BUFFERS ETC.) @ 00006940
DC X'1900' # 00006950
MONTH DS 3X # 00006960
JAN DC P'31,29,31,30,31,30,31,31,30,31,30,31' 00006970
KWRDTAB DC AL1(0,1,4),C'STACK' & 00006980
DC AL1(KWRDIOB-KWRDSTAK,1,4),C'IOBUF' & 00006990
DC AL1(KWRDDUMP-KWRDSTAK,0,3),C'DUMP' & 00007000
DC AL1(KWRDTIME-KWRDSTAK,1,3),C'TIME' & 00007010
DC AL1(KWRDCC-KWRDSTAK,0,1),C'CC' & 00007020
DC AL1(KWRDSPIE-KWRDSTAK,0,3),C'SPIE' & 00007030
DC AL1(KWRDSNAP-KWRDSTAK,0,3),C'SNAP' & 00007040
DC AL1(0,0,0) END-OF-TABLE MARKER & 00007050
* 00007060
LTORG , 00007070
EJECT 00007080
*********************************************************************** 00007090
* 00007100
* 00007110
* INTERRRUPT PROCCESSING FOR PASCAL PROGRAMS 00007120
* 00007130
* ONLY FIXED/FLOAT DIVISION BY ZERO AND EXPONENT OVERFLOW 00007140
* INTERRUPTS ARE EXPECTED TO BE CAUGHT HERE, OTHER INTERRUPTS 00007150
* IN GENERAL ARE CAUSED BY STACK/HEAP OVER FLOW OR A BAD I/O 00007160
* FILE SPECIFICATION AND OR MISSING APPROPRIATE DD STATEMENTS. 00007170
* 00007180
*********************************************************************** 00007190
USING $PASINT,R15 00007200
$PASINT B *+12 00007210
DC X'7',C'$PASINT' 00007220
MVC INTDATA(12),0(R1) SAVE ALL INTERRUPT DATA * 00007230
MVC INTDATA+12(20),20(R1) * 00007240
STM R3,R13,INTDATA+24 * 00007250
MVC INTDATA+68(8),12(R1) * 00007260
LA R0,PASINT1 GO TO PASINT1 VIA THE CONTROL # 00007270
ST R0,8(R1) PROGRAM TO CANCEL SPIE EXIT # 00007280
BR R14 # 00007290
DROP R15 # 00007300
* 00007310
PASINT1 BALR R11,0 RE-ESTABLISH ADDRESSABILITY # 00007320
USING *,R11 # 00007330
L R1,=A(OLDPICA) CANCEL THE SPIE TRAP # 00007340
L 1,0(R1) THAT IS IN EFFECT # 00007350
SPIE MF=(E,(1)) # 00007360
* # 00007370
* GET INTERRUPT CODE AND POINT TO THE APPROPRIATE ERROR MESSAGE 00007380
* 00007390
SR R4,R4 00007400
IC R4,INTDATA+7 GET THE INTERRUPT CODE # 00007410
LA R8,2000(R4) SET THE RETURN CODE 00007420
IC R4,MSGTBL(R4) 00007430
LA R3,MSGTXT+1(R4) R3 --> ERROR MESSAGE 00007440
IC R4,MSGTXT(R4) R4 --> MESSAGE LENGTH 00007450
L R14,INTDATA+8 GET LOCATION OF INTERRUPT # 00007460
CLI SPUSERSA,X'FF' SEE IF INTERR. IN SP MODULE 00007470
BE NOTINSP 00007480
* 00007490
* IF INTERRUPTION OCCURED WITHIN THE '$PASCSP' ROUTINE PATCH UP 00007500
* A SAVE AREA TO POINT TO CALLERS SAVE AREA FOR A MEANINGFULL 00007510
* ERROR MESSAGE. 00007520
* 00007530
L R5,=A(SPUSERSA) GET USER REGS 00007540
LM R12,R15,(R12-R1)*4(R5) GET IMPORTANT VALUES 00007550
LR R10,R15 SET PROC ENTRY POINT ADR 00007560
ST R13,FAKESA+4 SET SAVE AREA CHAIN 00007570
STM R14,R15,FAKESA+12 SET RETURN ADR FIELD 00007580
LA R13,FAKESA 00007590
L R14,INTDATA+8 RESET INTERRUPT LOCATION # 00007600
B KNOWNPRC 00007610
* 00007620
* SEE IF R10 POINTS TO THE BEGINING OF A PROC. 00007630
* 00007640
NOTINSP L R12,=A(ALOSTORE) GET THE STACK ADDRESS 00007650
L R12,0(R12) 00007660
LA R12,STACK-DYNSTORE(R12) POINT TO BASE OF THE STACK 00007670
LA R10,0(R10) 00007680
* C R10,=A($PASCSP) # 00007690
* BL FIXENTRY IF R10 IS OUT OF BOUND, SKIP # 00007700
* C R10,=A($MAINBLK) # 00007710
* BH FIXENTRY # 00007720
LH R5,0(R10) R10 IS WITHIN BOUND, SEE IF 00007730
CH R5,=XL2'47F0' IT POINTS TO A PROC ENTRY POINT 00007740
BNE FIXENTRY 00007750
CR R13,R12 SEE IF SAVE AREA PTR IS 00007760
BL FIXENTRY WITHIN BOUNDS 00007770
C R13,NEWPTR-STACK(R12) 00007780
BH FIXENTRY 00007790
C R10,16(R13) CONSISTANCY CHECK 00007800
BE KNOWNPRC THIS IS A USER PROCEDURE ? 00007810
* 00007820
* R10 POINTS TO NOWHERE, FAKE A PROCEDURE HEADING 00007830
* 00007840
FIXENTRY ST R12,4+FAKESA CHAIN THE FAKE SAVE AREA 00007850
L R5,16(R12) POINT TO $MAINBLK ENTRY POINT 00007860
ST R5,12+FAKESA SET RET. ADR. FROM FAKE PROC 00007870
LA R10,FAKEPROC POINT TO THE ENTRY OF FAKEPROC 00007880
AR R14,R10 ALSO SET THE ERROR LOCATION ADR 00007890
LA R13,FAKESA 00007900
* 00007910
* THIS IS THE ENTRY TO A FAKE PROC TO BE USED IF 00007920
* NO MEANINGFULL PROC IS FOUND AFTER AN INTRRUPT 00007930
* 00007940
KNOWNPRC L R15,=A($CHKMSG) & 00007950
BR R15 GO TO PRINT ERROR MESSAGE 00007960
* 00007970
USING *,R15 00007980
FAKEPROC B *+12 00007990
DC AL1(7),C'UNKNOWN' 00008000
* 00008010
FAKESA DC 6F'0' 00008020
* # 00008030
DC CL8'INTDATA' # 00008040
INTDATA DC 19F'0' INTERRUPT DATA & 00008050
* 00008060
MSGTBL DC AL1(0,IMSG1,IMSG1,IMSG1,IMSG1,IMSG1,IMSG1,IMSG1,IMSG1) 00008070
DC AL1(IMSG2,IMSG1,IMSG2,IMSG3,IMSG1,IMSG1,IMSG2) 00008080
* 00008090
MSGTXT DS 0C 00008100
IM1 DC AL1(L'IMSG1),C' PROGRAM INTERRUPT, SEE RETURN CODE.' 00008110
IMSG1 EQU IM1-MSGTXT,*-IM1-1 00008120
IM2 DC AL1(L'IMSG2),C' DIVISION BY ZERO ' 00008130
IMSG2 EQU IM2-MSGTXT,*-IM2-1 00008140
IM3 DC AL1(L'IMSG3),C' EXPONENT OVERFLOW ' 00008150
IMSG3 EQU IM3-MSGTXT,*-IM3-1 00008160
DC C' ' 00008170
DROP R11 00008180
* 00008190
*************************************************************** 00008200
* 00008210
* END OF INTERRUPT HANDLING ROUTINE 00008220
* 00008230
*************************************************************** 00008240
EJECT 00008250
AIF (&SYSTEM).SYS900 00008260
* 00008270
* $TRACER IS CALLED FROM THE PASCAL CODE IN ORDER TO 00008280
* ENTER A CONTROL TRANSFER INTO THE TRANSFER TABLE 00008290
* AND (IF DESIRED) PRINT THIS TRANSFER. 00008300
* 00008310
* CALLING CODE: 00008320
* BAL 14,TRACER 00008330
* DC AL2( PARAMETER ) 00008340
* 00008350
* THE ROUTINE 'TRACER' IS ONE OF THE CHECK ROUTINES 00008360
* INCLUDED ON THE PASCAL RUN STACK. ITS STRUCTURE IS 00008370
* SIMPLY: 00008380
* TRACER L 15,=V($TRACER) 00008390
* BR 15 00008400
* 00008410
* THE HALFWORD PARAMETER TO TRACER HAS THE FOLLOWING 00008420
* INTERPRETATIONS: 00008430
* 00008440
* 1. POSITIVE VALUE IS TAKEN TO MEAN A BRANCH TO THIS 00008450
* ADDRESS RELATIVE TO THE START OF THE CURRENT 00008460
* PROCEDURE (WHOSE BASE ADDRESS IS IN REG 10). 00008470
* THIS IS THE USAGE FOR ALL BRANCHES INTERNAL TO A 00008480
* PROCEDURE. 00008490
* 00008500
* 2. ZERO VALUE IMPLIES A PROCEDURE RETURN TO THE 00008510
* ADDRESS IN REG. 0. NOTE: THIS IS ALSO THE USAGE 00008520
* FOR A GOTO THAT EXITS THE CURRENT PROCEDURE. 00008530
* 00008540
* 3. NEGATIVE VALUE IMPLIES A PROCEDURE CALL TO THE 00008550
* ABSOLUTE ADDRESS WHICH IS HELD IN A LOCAL V-TYPE 00008560
* ADDRESS CONSTANT WITHIN THE CURRENT PROCEDURE. 00008570
* THE ADDRESS CONSTANT'S OFFSET WITHIN THE CURRENT 00008580
* PROCEDURE IS THE NEGATIVE OF THE PARAMETER VALUE. 00008590
* 00008600
DROP , 00008610
USING $TRACER,R15 00008620
$TRACER STM R0,R2,TRACESA+4 00008630
L R2,TRPTR LOAD AND ADVANCE 00008640
LA R2,8(,R2) THE CYCLIC POINTER 00008650
N R2,=F'127' 00008660
ST R2,TRPTR 00008670
LH R1,0(,R14) LOAD AND TEST PARAMETER 00008680
LTR R1,R1 00008690
BNP TRACE4 JUMP IF PROC. CALL/RETURN 00008700
LA R1,0(R1,R10) R1 = DESTINATION ADDRESS 00008710
TRACE2 ST R1,TRTABL(R2) PUT IN TABLE 00008720
ST R14,TRTABL+4(R2) PUT ORIGIN ADDRESS+4 IN TABLE 00008730
L R0,TRLINES 00008740
BCT R0,TRACE6 JUMP TO PRINT TRANSFER 00008750
TRRET BC 0,TRACE3 00008760
LR R14,R1 00008770
LM R0,R2,TRACESA+4 00008780
BR R14 00008790
TRACE3 NI TRRET+1,X'0F' CLEAR BRANCH CONDITION 00008800
LA R14,2(,R14) 00008810
ST R1,TRACESA 00008820
LM R15,R2,TRACESA 00008830
BR R15 JUMP TO CALLED PROCEDURE 00008840
TRACE4 BZ TRACE5 JUMP IF PROC. RETURN 00008850
OI TRRET+1,X'F0' FORCE LATER JUMP TO TRACE3 00008860
LPR R1,R1 MAKE OFFSET POSITIVE 00008870
L R1,0(R1,R10) LOAD THE ADDRESS CONSTANT 00008880
O R1,TRACEFL1 SET FLAG BYTE (FOR CALL) 00008890
B TRACE2 00008900
TRACE5 LR R1,R0 00008910
LA R1,0(,R1) CLEAR HIGH BYTE 00008920
O R1,TRACEFL2 SET FLAG BYTE (FOR RETURN) 00008930
B TRACE2 00008940
TRACE6 ST R0,TRLINES STORE UPDATED LINE COUNT 00008950
L R15,=A(TRPR1) 00008960
BALR R14,R15 CALL PRINT ROUTINE 00008970
USING *,R14 00008980
L R15,=A($TRACER) RESTORE BASE REG. 00008990
DROP R14 00009000
L R14,TRTABL+4(R2) RESTORE RETURN REG 00009010
B TRRET 00009020
* 00009030
* TRDUMP IS CALLED IN CASE OF ABNORMAL PROGRAM TERMINATION 00009040
* TO PRINT OUT THE CONTENTS OF THE TRACE TABLE. 00009050
* 00009060
TRDUMP LR R10,R15 00009070
DROP , 00009080
USING TRDUMP,R10 00009090
USING STACK,GBR 00009100
TM TRPTR,X'80' 00009110
BOR R14 RETURN IF TABLE IS EMPTY 00009120
ST R14,TRDUMPSV SAVE RETURN ADDRESS 00009130
L R15,=A($PASCSP) 00009140
LA AD,OUTPUT 00009150
L AE,=A(FILOUT) 00009160
TM FILOPN(AE),WRITEOPN 00009170
BNZ TRDUMP1 JUMP IF OUTPUT FILE OPEN 00009180
LA R1,PREW FORCE THE FILE TO BE OPEN 00009190
B TRDUMP2 00009200
TRDUMP1 LA R1,PSKP DOUBLE-SPACE 00009210
LA R2,2 00009220
TRDUMP2 BALR R14,R15 00009230
LA R2,TRDUMPMS 00009240
LA R3,L'TRDUMPMS 00009250
LR R4,R3 00009260
LA R1,PWRS PUT OUT HEADING 00009270
BALR R14,R15 00009280
LA R6,16 LOAD NO. OF TABLE ENTRIES 00009290
TRDUMP3 L R2,TRPTR 00009300
LA R2,8(,R2) 00009310
N R2,=F'127' CYCLICALLY ADVANCE POINTER 00009320
ST R2,TRPTR 00009330
LA R15,TRPR1 00009340
L R1,TRTABL(R2) LOAD TABLE ENTRY 00009350
LTR R1,R1 TEST IF EMPTY 00009360
BZ *+6 00009370
BALR R14,R15 PRINT NON-EMPTY ENTRY 00009380
XC TRPRFST(4),TRPRFST FORCE NEXT ITEM ON NEW LINE 00009390
BCT R6,TRDUMP3 00009400
L R14,TRDUMPSV 00009410
BR R14 RETURN 00009420
* 00009430
* TRPR1 OUTPUTS ONE ENTRY IN THE TRACE TABLE. THE INDEX 00009440
* OF THIS ENTRY IS GIVEN BY REG 2. 00009450
* 00009460
DROP , 00009470
USING TRPR1,R15 00009480
USING STACK,GBR 00009490
TRPR1 STM R0,R15,TRPRSAV 00009500
LR R10,R15 00009510
USING TRPR1,R10 00009520
DROP R15 00009530
LA R3,TRTABL(R2) 00009540
MVC TRPRDLIM(3),=C' ->' & 00009550
MVC TRPRTAG(1),0(R3) & 00009560
LR R6,R2 00009570
SR R0,R0 00009580
TM 0(R3),X'FF' 00009590
BZ TRPR3 JUMP FOR NORMAL BRANCH 00009600
BM TRPR2 JUMP IF PROC. RETURN 00009610
MVC TRPRMSG(10),=C' CALL FROM' 00009620
LA R0,10 00009630
B TRPR3 00009640
TRPR2 MVC TRPRMSG(12),=C' RETURN FROM' 00009650
LA R0,12 00009660
TRPR3 STH R0,TRPRLEN SAVE STRING LENGTH SO FAR 00009670
L R1,TRTABL+4(R6) LOAD ORIGIN ADDRESS 00009680
SH R1,=H'4' 00009690
LA R15,TRLN & 00009700
BALR R5,R15 CONVERT TO TEXT & 00009710
LTR R0,R0 TEST RETURN CODE 00009720
BNZ TRPR6 JUMP IF INCOMPLETE INFO. 00009730