|
DataMuseum.dkPresents historical artifacts from the history of: IBM System/3 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about IBM System/3 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 10414 (0x28ae)
Types: s3xseg
Names: »SXRF04«
└─⟦811594a0b⟧ Bits:30009185 5702-sc1.V16.pgm
└─⟦8223a6838⟧
└─⟦this⟧ »SXRF04«
└─⟦990ba7470⟧ Bits:30009182 5702-PP1
└─⟦efad88270⟧
└─⟦this⟧ »SXRF04«
H C 014 XRF04 0000
F* 0010
F****************************************************** 0020
F* 5798-NKG COPYRIGHT IBM CORP. 1977. REFER TO * 0030
F* INSTRUCTIONS ON COPYRIGHT NOTICE FORM NO. 120-2083* 0040
F****************************************************** 0050
F* 0060
F*********************************************************** 0070
F* THIS PROGRAM IS USED TO LOAD RPG PROGRAMS AND SORTS TO * 0080
F* 'SORCDECK' FOR USE BY VARIOUS ANALYSIS PROGRAMS. * 0090
F* SOURCE DECKS LOADED NEED NOT BE FREE OF TERMINAL * 0100
F* COMPILE ERRORS FOR USE THROUGHOUT THIS GROUP OF PRO- * 0110
F* GRAMS. HOWEVER, ERRORS MAY CAUSE UNPREDICTABLE RESULTS* 0120
F* THE INPUT FILE, PROGRAMS, MUST LOOK LIKE IT WAS CREATED* 0130
F* BY A $MAINT 'LIBRARY-TO-FILE' RUN. * 0140
F* XRFSEL. * 0150
F*********************************************************** 0160
F* 0170
FPROGRAMSIPE F 960 96 DISK40 0180
FSLIBRFILIC F 92R12AI 81 DISK40 U1 0190
FSORCDECKO F2520 84 DISK40 0200
E IND 6 2 0210
E FILS 15 8 0220
E DVCS 20 7 0230
E LOOK 88 1 0240
E HLDL 8 1 0250
E DEV 10 20 7 0260
IPROGRAMSNS 88 1 C/ 2 C/ 0270
I/COPY R1,AUX084 0280
I NS 97 1 C* 2NC* 0290
I OR 7 C* 0300
I OR 10 1 C* 2 C* 0310
I NS 09 7 C/ 8 CC 0320
I/COPY R1,AUX086 0330
I NS 01 6 CH 0340
I/COPY R1,AUX088 0350
I PROGRM 14 0360
I NS 02 6 CF 7NC 0370
I/COPY R1,AUX090 0380
I ADD 15 0390
I NS 03 6 CE 27NC 0400
I OR 05 6 CI 53NC 0410
I OR 06 6 CC 51NC 0420
I OR 08 6 CO 32NC 0430
I OR 6 CO 45NC 0440
I 1 80 DATA80 0450
I NS 04 6 CI 7NC 0460
I/COPY R1,AUX094 0470
I NS 07 6 CO 7NC 0480
I/COPY R1,AUX098 0490
I NS 0500
ISLIBRFILNS 97 7 C* 0510
I NS 03 6 CE 27NC 0520
I OR 05 6 CI 53NC 0530
I OR 06 6 CC 51NC 0540
I OR 08 6 CO 32NC 0550
I OR 6 CO 45NC 0560
I 1 80 DATA80 0570
I NS 02 6 CF 7NC 0580
I/COPY R1,AUX090 0590
I NS 04 6 CI 7NC 0600
I/COPY R1,AUX094 0610
I NS 07 6 CO 7NC 0620
I/COPY R1,AUX098 0630
I NS 0640
C***INDICATOR USAGE************************************ 0650
C* 01-10 INPUT IDENTIFYING INDICATORS * 0660
C* 01 RPG OR SORT HEADER * 0670
C* 02 FILE SPEC WITH FILE NAME OR SORT 'F' * 0680
C* 03 'E' SPEC W/ ARRAY NAME * 0690
C* 04 'I' SPEC WITH A FILE NAME OR SORT INCLUDE * 0700
C* 05 'I' SPEC W/ FIELD NAME * 0710
C* 06 'C' SPEC W/ DEFINED RESULT FIELD * 0720
C* 07 'O' SPEC WITH FILE NAME OR SORT OMIT * 0730
C* 08 'O' SPEC W/ FIELD NAME OR CONSTANT * 0740
C* 09 RPG /COPY RECORD * 0750
C* 10 START OF COMP TIME TABLE/ARRAY * 0760
C* 11 READING THROUGH COMP TIME TABLE/ARRAY* 0770
C* 14 PROGRAM NAME MISSING IN H SPEC CARD * 0780
C* 15 COL 66 OF 'F' SPEC IS BLANK * 0790
C* 16 FILE NAME FOUND IN LOOKING FOR DEVICE * 0800
C* CODE ON I & O CARDS IN RPG DECK. * 0810
C* 17 THIS CARD IS TO BE WRITTEN TO DISK. * 0820
C* 18 WORKING ON $D OR $TSORT DECK * 0830
C* 19 WORKING ON A $TSORT DECK * 0840
C* 24 DISK OUT 'F' SPEC W/ ' ' IN COL 66. * 0850
C* 29 END OF SCAN OF A // FILE CARD * 0860
C* 31 'NAME-' FOUND IN FILE CARD * 0870
C* 32 'LABEL-' FOUND IN FILE CARD * 0880
C* 33 END OF LABEL FOUND * 0890
C* 34 LOOP CONTROL * 0900
C* 36 LOOP CONTROL * 0910
C* 37 NAME IN FILE CARD IS 'INPUT' * 0920
C* 38 NAME IN FILE CARD IS 'WORK' * 0930
C* 39 NAME IN FILE CARD IS 'OUTPUT' * 0940
C* 41 // LOAD CARD * 0950
C* 42 // COPY CARD * 0960
C* 43 // FILE CARD * 0970
C* 88 SOME OCL CARD- I.E. COL 1 IS A '/' * 0980
C* 97 RPG COMMENT CARD-BYPASS IT * 0990
C* 99 BAD CHAIN TO SLIBRFIL. BOOK END FOUND * 1000
C* OR BOOK NOT THERE AT ALL. * 1010
C****************************************************** MAIN LINE 1020
C EXSR DETCLR 1030
C 88 SETOF 11 1040
C 10 SETON 11 1050
C N88 10 ADD LINE LINE 1060
C 11 1070
COR 97 GOTO END 1080
C* SEE IF THIS // RECORD IS A COPY, LOAD OR FILE AND 1090
C* PROCESS IT ACCORDINGLY. 1100
C 88 EXSR SLASH 1110
C 01 EXSR NEWJOB 1120
C N09 EXSR GETTYP 1130
C* ADD TO COMPILER LINE COUNT, OUTPUT APPROPRIATE RECORDS 1140
C N09N88 EXSR CHKOUT 1150
C* READ IN AUTO-COPIED LINES OF CODE. 1160
C 09 MOVE 'C' COPY 1 1170
C 09 U1 EXSR COPI 1180
C MOVE '00' LINE 1190
C END TAG 1200
C****************************************************** 1210
CLR MOVE '5798-NKG'COIBM 8 * 1220
CLR MOVE 'COPYRIGH'COIBM * 1230
CLR MOVE 'T IBM CO'COIBM * 1240
CLR MOVE 'RP. 1977'COIBM * 1250
C****************************************************** DETCLR 1260
CSR DETCLR BEGSR 1270
CSR SETOF 414243 1280
CSR SETOF 99 1290
CSR ENDSR 1300
C**************SUBR SLASH****************************** SLASH 1310
CSR SLASH BEGSR 1320
CSR LOAD COMP 'LOAD' 41 1330
CSR 41 EXSR SORTYP 1340
CSR LOAD COMP 'COPY' 42 1350
CSR 42 EXSR JOBCLR 1360
CSR LOAD COMP 'FILE' 43 1370
CSR 43 18 EXSR SRTFIL 1380
CSR ENDSR 1390
C****************************************************** GETTYP 1400
CSR GETTYP BEGSR 1410
CSR 02N18 EXSR FILECD 1420
CSR 04N18 1430
COR 07N18 EXSR GETDEV 1440
CSR 09N99 EXSR CHKOUT 1450
CSR ENDSR 1460
C**************SUBR SORTYP***************************** SORTYP 1470
CSR SORTYP BEGSR 1480
CSR DSORT COMP '$DSORT' 18 1490
CSR DSORT COMP '$TSORT' 19 1500
CSR 19 SETON 18 1510
CSR ENDSR 1520
C**************SUBR JOBCLR**************************** JOBCLR 1530
CSR JOBCLR BEGSR 1540
CSR Z-ADD1 LINA 72 1550
CSR Z-ADD2 LINB 72 1560
CSR SETOF 18 1570
CSR ENDSR 1580
C***************SUBR SRTFIL**************************** SRTFIL 1590
C* SCAN RECORD LOOKING FOR 'NAME OR 'LABEL' KEYWORDS 1600
CSR SRTFIL BEGSR 1610
CSR SETOF 333437 1620
CSR SETOF 3839 1630
CSR Z-ADD0 C 20 1640
CSR LOOP2 TAG 1650
CSR 1 ADD C C 1660
CSR C COMP 88 29 1670
CSR 29 GOTO ENDSRT 1680
CSR MOVEALOOK,C HLD5 5 1690
CSR HLD5 COMP 'NAME-' 31 1700
CSR HLD5 COMP 'ABEL-' 32 1710
CSR 31 SETON 33 1720
CSR 32 SETON 34 1730
CSR 31 EXSR NAMCHK 1740
CSR 32 EXSR GETLAB 1750
C* FORGET THE SORT WORK // FILE. 1760
CSR 31 38 GOTO ENDSRT 1770
C* IF EITHER 'NAME' OR 'LABEL' HASN'T BEEN FOUND YET 1780
C* CONTINUE TO LOOK. 1790
CSRN33 1800
CORN34 GOTO LOOP2 1810
CSR ENDSRT TAG 1820
C* END OF RECORD REACHED OR BOTH NAME AND LABEL FOUND. 1830
C* GET THE LABEL BEING HELD AND PUT INTO INL OR OUTL 1840
C* HOLDING FIELDS AS APPROPRIATE. 1850
CSR EXSR ARRANG 1860
CSR ENDSR 1870
C****************************************************** ARRANG 1880
C* PUT THE LABEL IN THE CORRECT HOLDING FIELD DEPENDING 1890
C* ON WHETHER THIS WAS THE INPUT OR OUTPUT // FILE. 1900
CSR ARRANG BEGSR 1910
CSR 37 MOVEAHLDL FILNM 1920
CSR 39 MOVEAHLDL FILNMO 8 1930
C* 'LABEL' PARAMETER WAS OMITTED - DEFAULT TO 'NAME'. 1940
CSRN34 37 MOVEL'INPUT' FILNM 1950
CSRN34 39 MOVEL'OUTPUT' FILNMO 1960
CSR 37 MOVE 'IP' USAGE 1970
CSR 39 MOVE 'OL' USAGEO 2 1980
CSR 18 MOVE 'DISK ' DEVICE 1990
CSR 19 MOVE 'TAPE ' DEVICE 2000
CSR ENDSR 2010
C****************************************************** NAMCHK 2020
C* NAME FOUND--WHICH FILE IS IT, INPUT, WORK OR OUTPUT. 2030
CSR NAMCHK BEGSR 2040
CSR 31 C ADD 5 C 2050
CSR 31 LOOK,C COMP 'I' 37 2060
CSR 31 LOOK,C COMP 'W' 38 2070
CSR 31 LOOK,C COMP 'O' 39 2080
C* SKIP PAST THE FILE NAME FOLLOWING KEYWORD 'NAME' 2090
C* GO ON LOOKING FOR THE KEYWORD 'LABEL', HOWEVER. 2100
CSR 31 37 C ADD 6 C 2110
CSR 31 39 C ADD 7 C 2120
CSR ENDSR 2130
C***************SUBR GETLAB**************************** GETLAB 2140
C* EXTRACT LABEL FROM RECORD-START OF IT AT 'C' 2150
C* SUPPLIED BY SUBRROUTINE SRTFIL. 2160
CSR GETLAB BEGSR 2170
CSR C ADD 5 C 2180
CSR SETOF 35 2190
CSR Z-ADD0 E 10 2200
CSR MOVEALOOK,C HLDL 2210
CSR LOOP3 TAG 2220
CSR 1 ADD E E 2230
CSR E COMP 8 36 2240
CSRN35N36 HLDL,E COMP ',' 35 2250
CSRN35N36 HLDL,E COMP ' ' 35 2260
CSR 35N36 MOVE ' ' HLDL,E 2270
CSRN36 GOTO LOOP3 2280
CSR ENDSR 2290
C***************SUBR NEWJOB**************************** NEWJOB 2300
CSR NEWJOB BEGSR 2310
CSR LINE SUB LINE LINE 72 2320
CSR Z-ADD0 A 20 2330
CSR 01 18 MOVE 'F' SPEC 1 2340
CSR 01 14N181 ADD RCTR RCTR 20 2350
CSR 01 14N18 MOVEL'*RPG' PROGRM 6 2360
CSR 01 14N18 MOVE RCTR PROGRM 2370
CSR 01 14 181 ADD SCTR SCTR 20 2380
CSR 01 14 18 MOVEL'*SRT' PROGRM 2390
CSR 01 14 18 MOVE SCTR PROGRM 2400
CSR MOVE PROGRM PRGSAV 6 2410
CSR ENDSR 2420
C**************SUBR FILECD***************************** FILECD 2430
CSR FILECD BEGSR 2440
CSR 1 ADD A A 2450
CSR MOVE FILNM FILS,A 2460
C* IF DISK FILE SPEC IS FOR OUTPUT AND COL 66 IS EMPTY 2470
C* PUT AN L IN COL 66 SIGNIFYING 'LOAD' 2480
CSR MOVELDEVICE IOTYP 1 2490
CSR IOTYP COMP 'D' 24 2500
CSR MOVELUSAGE HOW 1 2510
CSR 24 HOW COMP 'O' 24 2520
CSR 15 24 MOVE 'L' USAGE 2530
CSRN15 MOVE ADD USAGE 2540
CSR Z-ADD1 B 2550
CSR DEVICE LOKUPDEV,B 20 2560
CSR 20 MOVE DEVICE DVCS,A 2570
CSRN20 MOVE 'XXXXXXX' DVCS,A 2580
CSR ENDSR 2590
C**************SUBR GETDEV***************************** GETDEV 2600
C* FOR I OR O SPEC WITH A FILE NAME GET THE FILE'S 2610
C* DEVICE TYPE 2620
CSR GETDEV BEGSR 2630
CSR Z-ADD1 B 20 2640
CSR FILNM LOKUPFILS,B 16 2650
CSR MOVE DVCS,B DEVC 7 2660
CSR ENDSR 2670
C**************SUBR CHKOUT***************************** CHKOUT 2680
CSR CHKOUT BEGSR 2690
C* BUMP LINE COUNTER ON ALL BUT // RECORDS, 'H' SPECS, 2700
C* AND 'I' SPECS HARD-CODED TO MODIFY A '/COPY'ED IN 2710
C* 'I' SPEC. 2720
C* SET UP TO OUTPUT THE SELECTED RECORD TYPES. ALL 2730
C* RECORDS FOR A SORT ARE OUTPUT BASED ON THE 'H' REC. 2740
CSR 01 H CARD 2750
COR 02N18 F W/ NAME 2760
COR 03N18 E W/ ARRAY NAME 2770
COR 05N18 I W/ FLD NAME 2780
COR 06N18 C W/ FACT 3 2790
COR 08N18 SETON 17 O W/ FLD NAME 2800
C* OR CONSTANT 2810
CSR MOVE PRGSAV PROGRM 2820
CSR 17 EXCPT 2830
CSR SETOF 17 2840
CSR ENDSR 2850
C/COPY R1,AUX004 2860
C****************************************************** 2870
OSORCDECKE 17 2880
O DATA80 80 2890
O 05 FILNM 14 2900
O 08 FILNM 14 2910
O 02 USAGE 16 2920
O 05 16 DEVC 25 2930
O 08 16 DEVC 25 2940
O PROGRM 80 2950
O LINE 84P 2960
O 09 COPY 5 2970
O* SORT INPUT FILE DUMMY 'F' SPEC 2980
O E 01 17 18 2990
O SPEC 6 3000
O FILNM B 14 3010
O USAGE 16 3020
O DEVICE 46 3030
O PROGRM 80 3040
O LINA 84P 3050
O* SORT OUTPUT FILE DUMMY 'F' SPEC 3060
O E 01 17 18 3070
O SPEC 6 3080
O FILNMO B 14 3090
O USAGEO 16 3100
O DEVICE 46 3110
O PROGRM 80 3120
O LINB 84P 3130
** DEV ARRAY OF VALID DEVICE TYPES 3130
DISK DISK40 DISK45 MFCU1 PRINTERCONSOLEDISKET TAPE SPECIALREAD42 3140
MFCU2 BSCA READ01 CRT77 MFCM1 MFCM2 PRINTR2PRINT84 3150