ibm:vm370-lib:cms:dmssrt.assemble_src
Table of Contents
DMSSRT Source
References
- Fixes Applied : 3
- This Source Date : Tuesday, December 12, 1978
- Last Fix ID : [HRC323DS]
Source Listing
- DMSSRT.ASSEMBLE.txt
- SRT TITLE 'DMSSRT (CMS) VM/370 - RELEASE 6' 00001000
- SPACE 2 00002000
- *. 00003000
- * 00004000
- * 00005000
- * 00006000
- * 00007000
- * MODULE NAME: 00008000
- * 00009000
- * DMSSRT (SORT) 00010000
- * 00011000
- * FUNCTION: 00012000
- * 00013000
- * TO ARRANGE RECORDS WITHIN A FILE IN A DESCENDING 00014000
- * SEQUENTIAL ORDER. 00015000
- * 00016000
- * ATTRIBUTES: 00017000
- * 00018000
- * DISK RESIDENT 00019000
- * 00020000
- * ENTRY POINTS: 00021000
- * 00022000
- * DMSSRT - 00023000
- * 00024000
- * ENTRY CONDITIONS: 00025000
- * 00026000
- * GPR1 = A(PLIST) 00027000
- * 00028000
- * PLIST DC CL8'SORT' 00029000
- * DC CL16'FILEID1' FILENAME,FILETYPE,FILEMODE 00030000
- * DC CL16'FILEID2' FILENAME,FILETYPE,FILEMODE 00031000
- * DC XL8'FENCE' 00032000
- * 00033000
- * EXIT CONDITIONS: 00034000
- * 00035000
- * NORMAL - GPR15 = 0 00036000
- * 00037000
- * ERROR - GPR15 = NON-ZERO 00038000
- * 20 INVALID '*' IN FILEID 00039000
- * 24 INVALID PARAMETER 00040000
- * 24 INCOMPLETE FILEID 00041000
- * 28 INPUT FILE1 NOT FOUND 00042000
- * 24 INCOMPLETE SORT FIELD PAIR DEFINITION 00043000
- * 24 SORT COLUMN EXCEEDS RECORD LENGTH 00044000
- * 32 INPUT FILE NOT FIXED FORMAT 00045000
- * 24 FILEID 1 & 2 IDENTICAL 00046000
- * 24 NO LIST ENTERED 00047000
- * 24 INVALID DISK MODE 00048000
- * 36 OUTPUT DISK IS READ/ONLY 00049000
- * 36 TARGET DISK NOT ACCESSED @VA12416 00049250
- * 40 MAX NUMBER OF RECORDS EXCEEDED 00049500
- * 100 ERROR READING/WRITING FILE 00050000
- * 00051000
- * EXTERNAL REFERENCES: 00052000
- * 00053000
- * DMSCWR, DMSBWR, DMSBRD, DMSSTT 00054000
- * DMSFRE, DMSFNS, DMSCRD, DMSERR 00055000
- * 00056000
- * REGISTER USAGE: 00057000
- * 00058000
- * BASE = GPR12 00059000
- * WORK REGISTER = ALL OTHERS 00060000
- * 00061000
- * OPERATION: 00062000
- * 00063000
- * FROM THE REQUESTED FIELD DEFINITIONS, SORT SETS UP AN 00064000
- * ORDERED SERIES OF MVC'S AT THE BEGINNING OF THE FREE 00065000
- * AREA, IN WHICH THE 'FROM' FIELD IS INPUT RECORD FIELD 00066000
- * LOCATION, THE LENGTH IS THE LENGTH OF THE FIELD, AND 00067000
- * THE 'TO' LOCATION IS THE START OF THE DISTRIBUTION 00068000
- * BUFFER PLUS THE LENGTH OF ANY FIELDS WHICH HAVE COME 00069000
- * BEFORE. THUS, A PRIMARY FIELD OF LENGTH 5 WOULD BE 00070000
- * MOVED INTO DISTRIBUTION BUFFER LOCATION 0, WHILE THE 00071000
- * SECONDARY FIELD, IF ANY WOULD BE MOVED INTO 00072000
- * DISTRIBUTION BUFFER LOCATION 0 PLUS 5. THUS A SINGLE 00073000
- * CONTIGUOUS SORT ELEMENT IS CREATED WHOSE LENGTH IS 00074000
- * THE TOTAL LENGTH OF ALL THE FIELDS. 00075000
- * 00076000
- * RECORDS ARE READ IN ONE AT A TIME INTO CONTIGUOUS 00077000
- * AREAS OF STORAGE. A SORT ELEMENT IS CREATED WHICH IS 00078000
- * THEN PLACED IN ASCENDING ORDER IN A SORT TREE, WHERE 00079000
- * EACH ENTRY HAS THE FOLLOWING FORMAT: 00080000
- * 00081000
- * DC AL3(LOW) 00082000
- * DC AL3(HIGH) 00083000
- * DC AL3(BACK) 00084000
- * DC XL1(FLAG) 00085000
- * DC AL2(CNT) 00086000
- * DC AL ELEMENT LENGTH PLUS 2 BYTES FOR ITEM NO. 00087000
- * 00088000
- * LOW IS ADDRESS OF NEXT LOWER ENTRY 00089000
- * HIGH IS ADDRESS OF NEXT HIGHER ENTRY 00090000
- * BACK IS BACK POINTER TO PREVIOUS ENTRY 00091000
- * FLAG IS USED IN UNWINDING THE TREE TO MARK A DELETED ELEM 00092000
- * CNT INDICATES NUMBER OF DUPLICATES 00093000
- * 00094000
- * WHEN THE TREE HAS BEEN COMPLETED, THE CHAIN IS 00095000
- * SEARCHED FOR THE LOWEST ELEMENT, WHICH IS SIGNIFIED 00096000
- * BY A LOW FIELD OF ALL ZEROS. THE FLAG IS SET TO 00097000
- * 'USED'. RDBUF IS CALLED WITH THE ITEMNO WHICH WAS 00098000
- * SAVED IN THE MODE. WRBUF WRITES THE RECORD OUT ON 00099000
- * DISK. THE CHAIN IS THEN UNWOUND UPWARDS, WITH EACH 00100000
- * DELETED ENTRY BEING FLAGGED AND THE CORRESPONDING 00101000
- * RECORD WRITTEN OUT, UNTIL THE ENTIRE TREE IS 00102000
- * EXHAUSTED AND THE SORTED FILE IS WRITTEN. THE INPUT 00103000
- * AND OUTPUT FILES ARE CLOSED, STORAGE IS RELEASED, THE 00104000
- * PAGES RELEASED, AND CONTROL IS PASSED BACK TO THE 00105000
- * CALLER. 00106000
- * 00107000
- *. 00108000
- EJECT 00109000
- DMSSRT START X'0' 00110000
- USING DMSSRT,R12 00111000
- LR R12,R15 00112000
- ST R14,CMSRET 00113000
- DMSKEY NUCLEUS DISABLE NUCLEUS PROTECT 00114000
- USING NUCON,R0 00115000
- MVC DOSF(1),DOSFLAGS SAVE CURR. SET OF DOSFLAGS @V305001 00115100
- NI DOSFLAGS,255-DOSSVC TURN DOSSVC FLAF OFF @V305001 00115200
- CLI 8(1),X'FF' 00116000
- BE ERR54E 00117000
- CLI 8(R1),C'*' 00118000
- BE ERR62I '*' IS NO-NO IN FILEID 00119000
- CLI 16(1),X'FF' 00120000
- BE ERR54E 00121000
- CLI 16(R1),C'*' 00122000
- BE ERR62I 00123000
- CLI 24(1),X'FF' 00124000
- BE ERR54E 00125000
- CLI 32(1),X'FF' RAM 00126000
- BE ERR54E 00127000
- CLI 32(R1),C'*' 00128000
- BE ERR62O NO '*' IN OUT FILEID EITHER 00129000
- CLI 40(R1),X'FF' 00130000
- BE ERR54E 00131000
- CLI 40(R1),C'*' 00132000
- BE ERR62O 00133000
- CLI 48(R1),X'FF' 00134000
- BE ERR54E 00135000
- CLC 48(2,R1),RDMODE CHECK WRITE MODE FOR '*' 00136000
- BNE GARCHK 00137000
- MVC 48(2,R1),WRMODE IF SO, FORCE 'A1' MODE 00138000
- GARCHK CLI 56(R1),X'FF' CHEK XTRA OPTIONS 00139000
- BNE ERR70E ERROR IF ANY MORE 00140000
- * 00141000
- LR R2,R1 SAVE COMMAND PLIST PTR 00142000
- MVC RDFN(18),8(R1) MOVE IN THE INPUT FILEID 00143000
- MVC WRFN(18),32(R1) MOVE IN OUTPUT FILEID 00144000
- LA 1,RDPLST CALL STATE FOR INPUT 00145000
- SVC 202 00146000
- DC AL4(*+4) 00147000
- LTR R15,R15 00148000
- BZ FSTAD FILE FOUND WITH NO PROBLEMS 00149000
- CH R15,=H'28' 00150000
- BE ERR2E FILE NOT FOUND 00151000
- CH R15,=H'36' DISK NOT ACCESSED @VA12416 00151100
- LA R2,RDMODE POINT TO DISK MODE @VA12416 00151200
- BE ERRMSG36 YES, ISSUE MSG69E @VA12416 00151300
- B ERET DISK OR SYNTAX ERROR 00152000
- FSTAD L 2,DATABF GET FST ADDRESS 00153000
- CLI 30(2),C'F' IS IT FIXED LENGTH? 00154000
- BNE ERR34E 00155000
- L 3,32(,2) GET RECORD SIZE 00156000
- ST 3,INSIZE PUT IT INTO PLIST 00157000
- STATEOUT LA 1,WRPLST NOW FIND OUT IF OUTPUT ALREADY EXISTS 00158000
- SVC 202 00159000
- DC AL4(*+4) 00160000
- LTR R15,R15 00161000
- BZ CHKSAME FILE FOUND, ERASE IT 00162000
- CH R15,=H'28' 00163000
- BE NOTTHERE FILE NOT FOUND 00164000
- CH R15,=H'36' DISK NOT ACCESSED @VA12416 00164100
- LA R2,WRMODE POINT TO DISK MODE @VA12416 00164200
- BE ERRMSG36 YES, ISSUE MSG69E @VA12416 00164300
- B ERET DISK OR SYNTAX ERROR 00165000
- CHKSAME EQU * @VA09700 00166000
- CLC WRFN(17),RDFN INPUT/OUTPUT FILES THE SAME.? @VA09700 00166500
- BE ERR19E YES 00167000
- MVC WROPTN(8),=CL8'ERASE' 00168000
- L 2,WRBUF GET FST ADDRESS 00169000
- LA 1,WRPLST GO ERASE THE OLD FILE 00170000
- SVC 202 00171000
- DC AL4(*+4) 00172000
- B SAMESIZE 00173000
- NOTTHERE LA R1,WRPLST 00174000
- L R15,VCADTLKW GET ADDRESS OF ADTLKW. @VM03093 00175100
- BALR R14,R15 00176000
- BC 2,ERR37E 00177000
- SAMESIZE MVC WRSIZE(4),INSIZE AND SAME RECORD SIZE 00178000
- LR R1,R2 RESTORE PLIST POINTR 00179000
- * 00180000
- CLI WRMODE+1,C' ' BLANK MODE NUMBER? P3037 00181000
- BNE SKIP P3037 00182000
- MVI WRMODE+1,C'1' IF SO, DEFAULT '1' P3037 00183000
- SKIP EQU * P3037 00184000
- CLI WRMODE,C'*' CAN'T WRITE TO '*' 00185000
- BNE R604 00186000
- MVC WRMODE(2),=CL2'A1' FORCE WRITES TO A-DISK 00187000
- R604 DS 0H HRC323DS 00187020
- LH R15,NUMFINRD get number of lines in the stack HRC323DS 00187040
- LTR R15,R15 HRC323DS 00187060
- BNZ NOTYPE skip next msg if line in stack HRC323DS 00187080
- DMSERR NUM=604,LET=R,TEXT='Enter sort fields: ',DOT=NO RC323DS 00188000
- * WHILE TYPING, SETUP FREE CORE 00189000
- NOTYPE DS 0H HRC323DS 00189020
- L R15,ASTRINIT CALL 'STRINIT 00190000
- BALR 14,15 00191000
- GETMAIN VU,LA=LENGTHS,A=GENBUF GET ALL STORAGE WE CAN @VA04199 00196000
- L R1,GENBUF GET STARTING FREE ADDRESS @VA04199 00197000
- A 1,FREESIZE COMPUTE END OF CORE 00198000
- BCTR 1,0 SUBTRACT 1 00199000
- ST 1,AFREEND PLACE IT INTO THE 'TREE' PLIST 00200000
- LA R1,CONRDLST READ FIELDS FROM TERMINAL 00201000
- SVC 202 00202000
- DC AL4(*+4) 00203000
- B CONTINUE 00204000
- CONRDLST DS 0D 00205000
- DC CL8'WAITRD' 00206000
- DC AL1(1) 00207000
- DC AL3(CONBUF) 00208000
- DC C'U' 00209000
- NCH DC AL3(0) 00210000
- CONTINUE DS 0H 00211000
- LH 3,NCH+1 GET NUMBER OF CHARACTERS READ 00212000
- LTR 3,3 00213000
- BZ ERR63E IF ZERO, NULL LINE 00214000
- ST 3,SCNCH NON-ZERO, SET LENGTH FOR SCAN 00215000
- LA 1,SCNCH SET R1 FOR 'SCAN' 00216000
- L 15,ASCANO CALL SCAN 00217000
- BALR 14,15 00218000
- EJECT 00219000
- L 5,GENBUF 00220000
- SR 6,6 SET STARTING 'TO' DISPLACEMENT 00221000
- GENLP CLI 0(1),X'FF' DOES FIRST OF PAIR EXIST? 00222000
- BE ENDLINE NO, GO CLEANUP AND START 00223000
- CLI 8(1),X'FF' DOES SECOND OF PAIR EXIST? 00224000
- BE ERR53E NO, ERROR 00225000
- L 4,0(,1) GET 'SC' 00226000
- BAL 14,BD2BN GO CONVERT IT 00227000
- ST 4,SC SAVE IT 00228000
- L 4,8(,1) GET 'EC' 00229000
- BAL 14,BD2BN GO CONVERT IT 00230000
- S 4,SC COMPUTE 'MVC' COUNT FIELD 00231000
- BM ERR53E IF MINUS, ERROR 00232000
- MVC 0(L'MVC,5),MVC MOVE INTO FREE CORE THE MVC 00233000
- STC 4,1(,5) INSERT THE COUNT FIELD 00234000
- STC 6,3(,5) SET 'TO' DISPLACEMENT 00235000
- LA 6,1(4,6) UPDATE THE TO DISP. 00236000
- L 7,SC GET 'SC' 00237000
- BCTR 7,0 REDUCE BY 1 00238000
- LH 8,4(,5) GET MVC FROM FIELD 00239000
- OR 8,7 'OR' IN THE FROM DISP. 00240000
- STH 8,4(,5) PUT IT BACK INTO THE 'MVC' 00241000
- LA 5,L'MVC(,5) 00242000
- LA 1,16(,1) UPDATE PARAM POINTER 00243000
- B GENLP 00244000
- * 00245000
- MVC MVC *-*(*-*,3),*-*(2) DUMMY MVC FOR GENERATION 00246000
- BR BR 9 DUMMY BR FOR GENERATION 00247000
- SC DS F SUBFIELD STARTING CHARACTER 00248000
- EJECT 00249000
- ENDLINE MVC 0(L'BR,5),BR MOVE THE BRANCH CODE INTO CORE 00250000
- LA 5,L'BR(,5) UPDATE R5 00251000
- ST 5,AFREES SAVE NEW FREE ADDRESS 00252000
- L 3,INSIZE SETUP BUFFER SPACE 00253000
- L 4,AFREES 00254000
- ST 4,DATABF 00255000
- ST 4,WRBUF 00256000
- AR 4,3 COMPUTE NEW FREE AREA ADDRESS 00257000
- MVC RDOPTN,=CL8'RDBUF' SET PLIST FOR READ 00258000
- MVC WROPTN,=CL8'WRBUF' AND WRITE 00259000
- ST 4,DBUF SET DISTRIBUTION BUFFER ADDRESS 00260000
- C R6,=F'253' SORT FIELD > 253 00261000
- BH ERR53E YES, ERROR 00262000
- ST 6,FLDLEN SAVE ACTUAL SORT FIELD LENGTH 00263000
- STC 6,MVCITMNO+3 SET DISP. FOR ITMNO MVC 00264000
- LA 6,2(,6) UPDATE BUFFER LENGTH FOR ITMNO 00265000
- STC 6,DBUF SET IT INOT THE 'TREE' PLIST 00266000
- AR 4,6 COMPUTE NEW FREE ADDRESS 00267000
- ST 4,AFREES 00268000
- LA 9,MVCITMNO SET R9 FOR GENERATED 'BR' 00269000
- L 10,GENBUF SET R10 FOR BRANCH INTO GENERATED 'MVC'S 00270000
- EJECT 00271000
- L 3,DBUF GET DISTRIBUTION BUFFER ADDRESS 00272000
- L 2,DATABF GET DATA BUFFER ADDRESS 00273000
- RDLP LA 1,RDPLST CALL RDBUF FOR AN INPUT RECORD 00274000
- SVC 202 .. 00275000
- DC AL4(*+4) .. 00276000
- LH 4,RCNT UPDATE INPUT ITEM NO. 00277000
- LA 4,1(,4) .. 00278000
- STH 4,RCNT .. 00279000
- LTR 15,15 ANY READ ERRORS? 00280000
- BCR 8,10 NO, GO MOVE SORT FIELDS TO 'DBUF' 00281000
- CH 15,=H'12' YES, IS IT EOF? 00282000
- BNE ERR104S NO, BAD NEWS 00283000
- BCTR 4,0 REDUCE COUNT BY ONE 00284000
- EOF L 2,FLDLEN YES, SET R2 TO TOTAL SORT FIELD LENGTH 00285000
- WRTLP LA 1,ATREE GET 'TSRCH' PLST ADDRESS 00286000
- BAL R14,TSRCH 00287000
- LTR 15,15 WAS AN ELEMENT GOTTEN? 00288000
- BNZ FINIS NO, WE ARE ALL FINISHED 00289000
- LA 3,12(1,2) YES, SET R3 TO ADDRESS OF ITEMNO 00290000
- MVC INITMNO(2),0(3) AND MOVE IT TO READ PLIST 00291000
- LA 1,RDPLST NOW GO READ THAT ITEM INTO CORE 00292000
- SVC 202 .. 00293000
- DC AL4(ERR104S) ANY ERRORS NOW ARE BAD 00294000
- LA 1,WRPLST NOW WRITE THE RECORD OUT SEQUENTALLY 00295000
- SVC 202 .. 00296000
- DC AL4(ERR105S) SO ARE WRITE ERRORS 00297000
- B WRTLP GO BACK FOR NEXT RECORD 00298000
- * 00299000
- MVCITMNO MVC *-*(2,3),RCNT SORT FIELD MOVED, GET CURRENT ITMNO 00300000
- LA 1,TPLST NOW CALL 'TREE' WITH ITS PLIST 00301000
- BAL 14,TREE 00302000
- LTR 15,15 WAS ELEMENT PROCESSED CORRECTLY? 00303000
- BZ RDLP YES, GO GET RECORD FOR NEXT ELEMENT 00304000
- B ERR212E @VA01057 00305000
- FINIS MVC RDOPTN,=CL8'FINIS' CLOSE INPUT FILE 00306000
- LA 1,RDPLST .. 00307000
- SVC 202 00308000
- DC AL4(*+4) .. 00309000
- MVC WROPTN,=CL8'FINIS' CLOSE OUTPUT FILE 00310000
- LA 1,WRPLST .. 00311000
- SVC 202 .. 00312000
- DC AL4(*+4) .. 00313000
- FREEMAIN V,A=GENBUF RELEASE OUR FREE STORAGE @VA04199 00315000
- RET SR 15,15 CLEAR ERROR FLAGS 00317000
- ERET LR R4,R15 SAVE RETURN CODE 00318000
- OI MISFLAGS,RELPAGES TURN PAGE REL. FLAG ON 00319000
- MVC DOSFLAGS(1),DOSF RESET DOSFLAGS @V305001 00319100
- DMSKEY RESET RESTORE NUCLEUS PROTECT 00320000
- L R14,CMSRET 00321000
- LR R15,R4 RESTORE RETURN CODE 00322000
- BR 14 00323000
- BD2BN EQU * DELETE TRAILING BLANKS AND CVB 00324000
- LA R2,4 4-BYTE LIMIT (REGISTER CONTENTS) 00325000
- ST R4,SAV5 SAVE IT FOR COMPARES 00326000
- LA R3,SAV5 00327000
- VALNUM CLI 0(R3),C' ' WE'RE LOOKING FOR INVALID CHARS 00328000
- BE NEXTD BLANKS WILL BE STRIPPED LATER 00329000
- CLI 0(R3),C'0' 00330000
- BL ERR53E HAS TO BE A NUMERIC 00331000
- CLI 0(R3),C'9' BETWEEN 0 AND 9 00332000
- BH ERR53E OR IT'S AN ERROR 00333000
- NEXTD LA R3,1(,R3) LOOK AT NEXT CHARACTER 00334000
- BCT R2,VALNUM 00335000
- * EVRYTHING IS O.K. AT THIS POINT 00336000
- ST R5,SAV5 SAVE FREE STORAGE POINTR 00337000
- CVTLP SR R5,R5 00338000
- SRDL R4,8 00339000
- CL R5,=X'40000000' DROP TRAILING BLANKS AFTER ENTRY 00340000
- BE CVTLP TRY ANOTHER BLANK 00341000
- SLDL R4,8 ALL BLANKS OUT, SHIFT BACK 00342000
- O R4,=C'0000' ZONE THE ZEROES 00343000
- ST R4,DEC SET UP ZONED DIGITS 00344000
- PACK DECD(8),DEC(4) FOR PACKING AND 00345000
- CVB R4,DECD CONVERSION TO BINARY 00346000
- C R4,INSIZE SORT ENTRY > LRECL? 00347000
- BH ERR9E YES, ERROR 00348000
- LTR R4,R4 SORT ENTRY OF '0' ILLEGAL 00349000
- BZ ERR53E 00350000
- L 5,SAV5 RESTORE FREE STORAGE POINTR 00351000
- BR 14 00352000
- SAV5 DS F 00353000
- EJECT 00354000
- * 00355000
- * SUBROUTINE NAME - 00356000
- * 00357000
- * TREE 00358000
- * 00359000
- * FUNCTION- 00360000
- * 00361000
- * TO SEARCH AN ORDERED DISTRIBUTION TREE FOR A PARTICULAR 00362000
- * ELEMENT. 00363000
- * 00364000
- * ENTRY CONDITIONS - 00365000
- * 00366000
- * GPR15 - A($$$SRRA) 00367000
- * GPR1 - A(PLIST) 00368000
- * PLIST - AL1(LENGTH),AL3(ELEMENT) 00369000
- * XL1'TFLAG' 00370000
- * AL3(ATREE) 00371000
- * A(STRTFREE) 00372000
- * A(ENDFREE) 00373000
- * 00374000
- * WHERE: 00375000
- * LENGTH - NO. OF CHARACTERS IN ELEMENT FIELD 00376000
- * ELEMENT - ADDRESS OF ELEMENT TO SEARCH FOR 00377000
- * TFLAG - A SWITCH FLAG TO INDICATE: 00378000
- * 80 - THE TREE HAS AT LEAST ONE ENTRY 00379000
- * 00 - THE TREE IS EMPTY 00380000
- * ATREE - STARTING ADDRESS OF THE SEARCH TREE; 00381000
- * WILL BE SET BY 'TREE' DURING FIRST 00382000
- * ENTRY TO VALUE IN 'STRTFREE'. 00383000
- * STRTFREE - ADDRESS OF LOWEST FREE CORE BYTE 00384000
- * INTO WHICH 'ATREE' MAY EXPAND. 'TREE' 00385000
- * WILL UPDATE THIS ADDRESS EACH TIME A 00386000
- * NEW ELEMENT IS BUILT. 00387000
- * ENDFREE - ADDRESS OF HIGHEST FREE CORE BYTE 00388000
- * INTO WHICH 'ATREE' MAY EXPAND. 00389000
- * 00390000
- * EXIT CONDITIONS - 00391000
- * 00392000
- * NORMAL - 00393000
- * GPR15 = 0 : ELEMENT PROCESSED CORRECTLY 00394000
- * 00395000
- * ERROR - 00396000
- * GPR15 = 4 : ELEMENT NOT FOUND AND NO CORE AVAILABLE 00397000
- * TO CREATE A NEW ELEMENT IN THE TABLE 00398000
- * 00399000
- * 00400000
- * TABLES | WORKAREAS - 00401000
- * 00402000
- * TREE TABLE ENTRY FORMAT: 00403000
- * 00404000
- * AL3(LOW) ADDRESS OF LOWER ELEMENT OR ZERO 00405000
- * AL3(HIGH) ADDRESS OF HIGHER ELEMENT OR ZERO 00406000
- * AL3(BACK) ADDRESS OF PREVIOUS NODE 00407000
- * XL1(FLAG) ATTACHED|DETACHED FLAG 00408000
- * AL2(CNT) FREQUENCY COUNT FOR ELEMENT 00409000
- * CL(LENGTH)'EE...EE' 00410000
- * 00411000
- * REGISTER USAGE - 00412000
- * 00413000
- * GPR2 - A(ELEMENT) 00414000
- * GPR3 - LENGTH OF ELEMENT 00415000
- * GPR4 - A(TREE) 00416000
- * GPR5 - A(FREE) FOR TREE BUILD 00417000
- * GPR14 - RETURN 00418000
- * GPR15 - ERROR CODE RETURN 00419000
- * 00420000
- * OPERATION - 00421000
- * 00422000
- * IF THE ELEMENT IS FOUND DURING THE SEARCH, A FREQUENCY COUNT 00423000
- * IS UPDATED; IF IT IS NOT FOUND, A NEW ELEMENT IS CREATED. 00424000
- * 00425000
- * 00426000
- TREE DS 0H 00427000
- STM R0,R14,SAVEAREA 00428000
- USING TREED,4 00429000
- SR 15,15 CLEAR ERROR FLAG 00430000
- SR 3,3 AND R3 00431000
- L 2,0(,1) R2 = A(ELEMENT) 00432000
- IC 3,0(,1) R3 = LENGTH 00433000
- BCTR 3,0 DECRIMENT FOR 'EX' MASK 00434000
- CLI 4(1),0 NEW TREE? 00435000
- BE BUILD YES, GO INSERT FIRST ENTRY 00436000
- L 4,4(,1) R4 = A(TREE) 00437000
- LOOP LA 6,3 SET R6 WITH HIGH FLAG 00438000
- EX 3,COMPARE COMPARE SEARCH/TREE ELEMENTS 00439000
- BE FOUND EQUAL? 00440000
- BL GOLOW NO, LOW? 00441000
- MVC NXTADR+1(3),HIGH NO, GET HIGH ELEM. ADDRESS 00442000
- B JOIN 00443000
- GOLOW MVC NXTADR+1(3),LOW IS LOW, GET LOW ELEM. ADDR. 00444000
- SR 6,6 RESET R6 WITH LOW FLAG 00445000
- JOIN L 5,NXTADR DOES NEXT TREE ELEMENT 00446000
- LTR 5,5 EXIST? 00447000
- BZ BUILD NO, GO BUILD ONE 00448000
- LR 4,5 YES, SET R4 00449000
- B LOOP AND LOOP 00450000
- * 00451000
- FOUND MVC ADDER,CNT ELEMENTS MATCHED 00452000
- LH 6,ADDER UPDATE 00453000
- LA 6,1(,6) TREE 00454000
- STH 6,ADDER FREQUENCY 00455000
- MVC CNT,ADDER COUNT 00456000
- RET2 LM R2,R14,SAVEAREA+8 00457000
- BR 14 00458000
- EJECT 00459000
- USING TREED,5 00460000
- BUILD L 5,8(,1) ELEM. NOT IN TREE, R5=A(FREE) 00461000
- LA 7,13(5,3) SET R7 TO NEW FREE ADDRESS 00462000
- C 7,12(,1) CORE OVERFLOW? 00463000
- BH FULL YES, GO SET ERROR FLA 00464000
- ST 7,8(,1) NO, RESET A(FREE) 00465000
- MVC TREED(12),INIT INITIALIZE FIXED ENTRY PORTION 00466000
- EX 3,MOVE MOVE INTO ENTRY THE ELEMENT FIELD 00467000
- CLI 4(1),X'80' FIRST ENTRY? 00468000
- BE NORMAL NO, BRANCH 00469000
- ST 5,4(,1) SET TREE ADDRESS FOR NEXT ENTRY 00470000
- MVI 4(1),X'80' SET TREE CREATED SWITCH 00471000
- B RET2 00472000
- * 00473000
- NORMAL EQU * 00474000
- ST 4,BKADR 00475000
- MVC BACK,BKADR+1 00476000
- ST 5,NXTADR SET NEW TREE ENTRY ADDRESS 00477000
- LA 4,0(6,4) IN CORRECT OLD 00478000
- MVC 0(3,4),NXTADR+1 ENTRY FIELD 00479000
- B RET2 00480000
- FULL MVI 4(1),0 RESET TREE EXISTANCE SWITCH 00481000
- LA 15,4 INDICATE FULL TABLE 00482000
- B RET2 00483000
- EJECT 00484000
- * CONSTANTS AND FORMATS 00485000
- * 00486000
- NXTADR DC A(0) 00487000
- BKADR EQU NXTADR 00488000
- ADDER DS H 00489000
- INIT DC XL12'1' 00490000
- * 00491000
- MOVE MVC ELEM,0(2) 00492000
- DROP 5 00493000
- USING TREED,4 00494000
- COMPARE CLC 0(1,2),ELEM 00495000
- EJECT 00496000
- * 00497000
- * SUBROUTINE NAME - 00498000
- * 00499000
- * TSRCH 00500000
- * 00501000
- * FUNCTION - 00502000
- * 00503000
- * TO FIND THE LOWEST VALUED ELEMENT IN AN ORDERED DISTRIBUTION 00504000
- * TREE. 00505000
- * 00506000
- * ENTRY CONDITIONS - 00507000
- * 00508000
- * GPR15 - A($$$SRSA) 00509000
- * GPR1 - A(PLIST) 00510000
- * PLIST - XL1'TFLAG',A(ATREE) 00511000
- * 00512000
- * WHERE: 00513000
- * TFLAG - A SWITCH FLAG TO INDICATE: 00514000
- * 80 - THE TREE HAS AT LEAST ONE ENTRY 00515000
- * 00 - THE TREE IS EMPTY 00516000
- * ATREE - STARTING ADDRESS OF THE SEARCH TREE 00517000
- * 00518000
- * EXIT CONDITIONS - 00519000
- * 00520000
- * NORMAL - 00521000
- * GPR15 = 0 : ELEMENT FOUND 00522000
- * GPR1 = A(ELEMENT) 00523000
- * 00524000
- * ERROR - 00525000
- * GPR15 = 4 : TREE IS EMPTY 00526000
- * 00527000
- * 00528000
- * TABLES | WORKAREAS - 00529000
- * 00530000
- * TREE TABLE ENTRY FORMAT: 00531000
- * 00532000
- * AL3(LOW) ADDRESS OF LOWER ELEMENT OR ZERO 00533000
- * 00534000
- * AL3(HIGH) ADDRESS OF HIGHER ELEMENT OR ZERO 00535000
- * AL3(BACK) ADDRESS OF PREVIOUS NODE 00536000
- * XL1(FLAG) ATTACHED|DETACHED FLAG 00537000
- * AL2(CNT) FREQUENCY COUNT FOR ELEMENT 00538000
- * CL(LENGTH)'EE...EE' 00539000
- * 00540000
- * REGISTER USAGE - 00541000
- * 00542000
- * GPR2 - A(TREE) 00543000
- * GPR14 - RETURN 00544000
- * GPR15 - ERROR CODE RETURN 00545000
- * 00546000
- * OPERATION - 00547000
- * 00548000
- * WHEN THE ELEMENT IS FOUND DURING THE TREE SEARCH, IT IS 00549000
- * DETACHED FROM THE TREE, AND THE TREE ELEMENT ADDRESS IS 00550000
- * RETURNED IN GPR1. 00551000
- * 00552000
- TSRCH DS 0H 00553000
- STM R0,R14,SAVEAREA 00554000
- DROP 4 00555000
- USING TREED,2 00556000
- L 2,0(,1) SET R2 TO BEGINNING OF TREE 00557000
- CKLOW TM FLAG,USED HAS CURRENT ENTRY BEEN DETACHED? 00558000
- BO TAKEN YES, BRANCH 00559000
- MVC A+1(3),LOW NO, DOES A 00560000
- L 3,A LOWER ENTRY 00561000
- LTR 3,3 EXIST? 00562000
- BZ FOUND2 NO, ELEMENT FOUND, GO RETURN IT 00563000
- CKLOW1 LR 2,3 YES, RESET ENTRY BASE 00564000
- B CKLOW AND LOOP 00565000
- * 00566000
- TAKEN EQU * CURRENT ENTRY HAS BEEN DETACHED 00567000
- MVC A+1(3),HIGH THERE CANNOT BE ANY LOWER ENTRIES 00568000
- L 3,A DOES A HIGHER ENTRY EXIST? 00569000
- LTR 3,3 00570000
- BZ BKCHN NO, GO BACK-CHAIN 00571000
- LR 2,3 YES, RESET ENTRY BASE 00572000
- TM FLAG,USED HAS THIS NODE BEEN DETACHED? 00573000
- BO TAKEN YES, BRANCH 00574000
- MVC A+1(3),LOW NO, DOES IT 00575000
- L 3,A HAVE A LOWER NODE? 00576000
- LTR 3,3 00577000
- BNZ CKLOW1 YES, GO CHECK IT 00578000
- * 00579000
- FOUND2 EQU * ELEMENT FOUND 00580000
- LR 1,2 LOAD ITS ADDRESS IN R1 00581000
- MVI FLAG,USED DETACH IT FROM THE TREE 00582000
- SR 15,15 CLEAR ERROR FLAG 00583000
- B RET3 00584000
- BKCHN1 TM FLAG,USED IS ELEMENT USED? 00585000
- BZ FOUND2 NO, RETURN THIS ELEMENT TO CALLER 00586000
- BKCHN EQU * SEARCH BACKWARD 00587000
- MVC A+1(3),BACK THROUGH THE TREE 00588000
- L 3,A FOR A NON-DETACHED 00589000
- LTR 2,3 NODE. 00590000
- BNZ BKCHN1 00591000
- * 00592000
- EMPTY LA 15,4 00593000
- RET3 LM R2,R14,SAVEAREA+8 00594000
- BR 14 00595000
- EJECT 00596000
- * CONSTANTS AND FORMATS 00597000
- * 00598000
- USED EQU X'80' 00599000
- A DC F'0' 00600000
- * 00601000
- EJECT 00602000
- ERR2E DMSERR NUM=2,LET=E,SUB=(CHAR8A,RDFN), *00603000
- TEXT='File ''....................'' not found' HRC323DS 00604000
- LA R15,28 RETURN CODE = 28 00605000
- B ERET 00606000
- SPACE 2 00607000
- ERR9E DMSERR NUM=9,LET=E,SUB=(DEC,(R4)),TEXT='Column ''...'' exceeds*00608000
- record length' HRC323DS 00609000
- LA R15,24 RETURN CODE = 24 00610000
- B ERET 00611000
- SPACE 2 00612000
- ERR19E DMSERR NUM=19,LET=E,TEXT='Identical fileids' HRC323DS 00613000
- LA R15,24 RETURN CODE = 24 00614000
- B ERET 00615000
- SPACE 2 00616000
- ERR34E DMSERR NUM=34,LET=E,SUB=(CHAR8A,RDFN), *00617000
- TEXT='File ''....................'' is not fixed length' 00618000
- LA R15,32 RETURN CODE = 32 00619000
- B ERET 00620000
- SPACE 2 00621000
- ERR37E DMSERR NUM=37,LET=E,SUB=(CHARA,WRMODE), *00622000
- TEXT='Disk ''..'' is read/only' HRC323DS 00623000
- LA R15,36 RETURN CODE = 36 00624000
- B ERET 00625000
- SPACE 2 00626000
- SPACE 2 00627000
- ERR53E DMSERR NUM=53,LET=E,TEXT='Invalid sort field pair defined' 00628000
- LA R15,24 RETURN CODE = 24 00629000
- B ERET 00630000
- SPACE 2 00631000
- ERR54E DMSERR NUM=54,LET=E,TEXT='Incomplete fileid specified' RC323DS 00632000
- LA R15,24 RETURN CODE = 24 00633000
- B ERET 00634000
- SPACE 2 00635000
- ERR62I LA R2,8(,R1) POINT TO INPUT FILEID 00636000
- B ERR62E 00637000
- ERR62O LA R2,32(,R1) POINT TO OUTPUT FILEID 00638000
- * 00639000
- ERR62E DMSERR NUM=62,LET=E,SUB=(CHAR8A,(R2)),TEXT='Invalid ''*'' in f*00640100
- ileid ''....................''' HRC323DS 00641000
- LA R15,20 RETURN CODE = 20 00642000
- B ERET 00643000
- ERRMSG36 EQU * @VA12416 00643100
- DMSERR TEXT='DISK ''..'' NOT ACCESSED',NUM=69, X00643200
- LET=E,SUB=(CHARA,((R2),1)) @VA12416 00643300
- LA R15,36 RETURN CODE = 36 @VA12416 00643400
- B ERET @VA12416 00643500
- SPACE 2 00644000
- ERR70E LA R2,56(,R1) POINT TO XTRA PARM 00645000
- DMSERR NUM=70,LET=E,SUB=(CHARA,(R2)),TEXT='Invalid parameter '*00646000
- '........''' 00647000
- LA R15,24 RETURN CODE = 24 00648000
- B ERET 00649000
- SPACE 2 00650000
- ERR63E DMSERR NUM=63,LET=E,TEXT='No list entered' HRC323DS 00651000
- LA R15,40 RETURN CODE = 40 00652000
- B ERET 00653000
- SPACE 2 00654000
- ERR104S LR R0,R15 SAVE ERROR CODE V0314 00655000
- DMSERR NUM=104,LET=S,SUB=(DEC,(R0),CHAR8A,RDFN), *00655100
- TEXT='Error ''..'' reading file ''....................''*00655200
- from disk',RENT=NO HRC323DS 00655300
- LA R15,100 RETURN CODE = 100 00658000
- B ERET 00659000
- SPACE 2 00660000
- ERR105S LR R0,R15 00661000
- DMSERR NUM=105,LET=S,SUB=(DEC,(R0),CHAR8A,WRFN), *00662000
- TEXT='Error ''...'' writing file ''....................'*00663000
- ' on disk',RENT=NO HRC323DS 00664000
- LA R15,100 RETURN CODE = 100 00665000
- B ERET 00666000
- ERR212E DMSERR NUM=212,LET=E,TEXT='Maximum number of records exceeded' 00666100
- LA R15,40 RETURN CODE = 40 @VA01057 00666300
- B ERET @VA01057 00666500
- SPACE 2 00667000
- EJECT 00668000
- RDPLST DS 0D 00669000
- RDOPTN DC CL8'STATE' 00670000
- RDFN DS CL8 00671000
- RDFT DS CL8 00672000
- RDMODE DC CL2'*' 00673000
- INITMNO DC H'0' 00674000
- DATABF DC A(0) 00675000
- INSIZE DC F'0' 00676000
- DC CL2'F' 00677000
- DC H'1' 00678000
- DC F'0' 00679000
- * 00680000
- WRPLST DS 0D 00681000
- WROPTN DC CL8'STATEW' CKECK FOR EXISTING FILE ON R/W DISK 00682000
- WRFN DS CL8 00683000
- WRFT DS CL8 00684000
- WRMODE DC CL2'A1' 00685000
- DC H'0' 00686000
- WRBUF DC A(0) 00687000
- WRSIZE DC F'0' 00688000
- DC CL2'F' 00689000
- DC H'1' 00690000
- DC F'0' 00691000
- * 00692000
- TPLST DS 0F 00693000
- DBUF DC AL1(*-*),AL3(*-*) 00694000
- ATREE DC A(0) 00695000
- AFREES DC A(0) 00696000
- AFREEND DC A(0) 00697000
- * 00698000
- DECD DS D 00699000
- DEC DS F 00700000
- GENBUF DS F 00701000
- FREESIZE DS F 00702000
- FLDLEN DS F 00703000
- RCNT DC H'0' 00704000
- SCNCH DS F 00705000
- CONBUF DS 130C 00706000
- * 00707000
- SAVEAREA DC 14F'-1' 00708000
- LENGTHS DC F'4096',F'8343600' MIN/MAX LENGTHS FOR GETMAIN @VA04199 00709000
- CMSRET DS F 00710000
- DOSF DS X SAVE AREA FOR DOSFLAGS @V305001 00710100
- * 00711000
- TREED DSECT 00712000
- LOW DS AL3 00713000
- HIGH DS AL3 00714000
- BACK DS AL3 00715000
- FLAG DS XL1 00716000
- CNT DS AL2 00717000
- ELEM DS C 00718000
- * 00719000
- EJECT 00720000
- REGEQU 00721000
- NUCON 00722000
- EJECT 00723000
- END 00724000
ibm/vm370-lib/cms/dmssrt.assemble_src.txt · Last modified: 2023/08/06 13:35 by Site Administrator