ERR TITLE 'DMSERR (CMS) VM/370 - RELEASE 6' 00001000 SPACE 2 00002000 *. 00003000 * 00004000 * 00005000 * 00006000 * 00007000 * MODULE NAME - 00008000 * 00009000 * DMSERR 00010000 * 00011000 * FUNCTION - 00012000 * 00013000 * HANDLE CALLS PRODUCED BY 'DMSERR' AND 'LINEDIT' 00014000 * MACROS. 00015000 * 00016000 * ATTRIBUTES - 00017000 * 00018000 * NUCLEUS RESIDENT, RE-ENTRANT 00019000 * 00020000 * ENTRY POINTS - 00021000 * 00022000 * DMSERR 00023000 * 00024000 * ENTRY CONDITIONS - 00025000 * 00026000 * R1 POINTS TO THE PLIST GENERATED BY THE 'DMSERR' OR 'LINEDIT' 00027000 * MACRO. THIS PLIST IS HIGHLY VARIABLE IN FORMAT. IN ADDITION, 00028000 * IF ONLY ONE SUBSTITUTION HAS BEEN SPECIFIED, THEN R0 WILL 00029000 * CONTAIN THE SUBSTITUTION PARAMETER. 00030000 * 00031000 * EXIT CONDITIONS - 00032000 * 00033000 * NORMAL - 00034000 * ALL REGISTERS RESTORED TO VALUE AT ENTRY, EXCEPT THAT R15=0. 00035000 * 00036000 * ERROR - 00037000 * ERRORS CAN OCCUR ONLY IN 'DISP=CPCOMM' OPTION, AND, IN THIS 00038000 * CASE, R15 CONTAINS THE CODE RETURNED BY DMSCPF. 00039000 * 00040000 * CALLS TO OTHER ROUTINES - 00041000 * 00042000 * DMSCWR (TYPLIN) -- TO TYPE OUT THE MESSAGE. 00043000 * 00044000 * DMSCPF (CPFUNC) -- TO PERFORM PROCESSING ASSOCIATED WITH 00045000 * 'DISP=CPCOMM' OPTION 00046000 * 00047000 * DMSCWT (CONWAIT) -- TO WAIT FOR CONSOLE OUTPUT TO BE 00048000 * COMPLETED, IN CASE 'DIE=YES' WAS SPECIFIED. 00049000 * 00050000 * PRINTR -- TO PRINT A LINE, IN CASE 00051000 * 'DISP=PRINT' WAS SPECIFIED. 00052000 * 00053000 * EXTERNAL REFERENCES - 00054000 * 00055000 * DMSERT -- ADDRESS OF DMSERR WORK AREA. 00056000 * 00057000 * SEE 'CALLS TO OTHER ROUTINES' FOR OTHER EXTERNAL REFERENCES. 00058000 * 00059000 * TABLES / WORKAREAS - 00060000 * 00061000 * DMSERT -- DMSERR WORK AREA 00062000 * 00063000 * REGISTER USAGE - 00064000 * 00065000 * R3 -> DMSERT (WORK AREA) 00066000 * R4 = 'FROM' POINTER FOR MESSAGE TEXT PROCESSING. 00067000 * R5 = 'END' POINTER FOR MESSAGE TEXT PROCESSING. 00068000 * R6 = 'TO' POINTER FOR MESSAGE TEXT PROCESSING. 00069000 * R7 IS USED TO COUNT THE NUMBER OF DOTS IN THE MESSAGE TEXT. 00070000 * R8 = LENGTH OF SUBSTITUTION. 00071000 * R9 = SCRATCH REGISTER 00072000 * R10 = INTERNAL SUBROUTINE RETURN REGISTER 00073000 * R12 = BASE REGSITER 00074000 * 00075000 * NOTES - 00076000 * 00077000 * NONE 00078000 * 00079000 * OPERATION - 00080000 * 00081000 * AT ENTRY, THE PLIST IS DECODED AND EXPANDED INSIDE THE WORK 00082000 * AREA, SO THAT IT WILL BE POSSIBLE TO EASILY ACCESS ALL ITS 00083000 * FIELDS. 00084000 * 00085000 * NEXT, THE MESSAGE HEADER IS CONSTRUCTED, IF 'DMSERR' (RATHER 00086000 * THAN 'LINEDIT') WAS SPECIFIED. 00087000 * 00088000 * THEN, THE MESSAGE TEXT IS SCANNED, BYTE BY BYTE. WHENEVER TWO 00089000 * OR MORE CONSECUTIVE DOTS ARE FOUND IN THE MESSAGE TEXT, AN 00090000 * ARGUMENT IS TAKEN FROM THE 'SUBS' PARAMETER LIST, THE 00091000 * APPROPRIATE CONVERSION IS PERFORMED, AND THE RESULT IS 00092000 * SUBSTITUTED FOR THE DOTS INTO THE MESSAGE TEXT. 00093000 * 00094000 * NEXT, IF A 'BUFFA' BUFFER ADDRESS WAS SPECIFIED, THEN THE 00095000 * RESULTING MESSAGE TEXT IS COPIED INTO THE SPECIFIED BUFFER. 00096000 * 00097000 * NEXT, THE 'DISP' FIELD IS EXAMINED, AND APPROPRIATE ACTION 00098000 * IS TAKEN. FOR DISP=TYPE, DMSCWR IS CALLED. FOR 'DISP=PRINT', 00099000 * PRINTR IS CALLED. FOR 'DISP=SIO', THE ROUTINE DOES ITS 00100000 * OWN SIO TO THE CONSOLE. FOR 'DISP=CPCOMM', DMSCPF IS 00101000 * CALLED. FOR 'DISP=NONE', NO ACTION IS PERFORMED. 00102000 * 00103000 * FINALLY, THE 'DIE' OPTION IS EXAMINED. IF 'DIE=YES' WAS 00104000 * SPECIFIED, THEN A DISABLED WAIT STATE PSW IS CREATED, CON- 00105000 * TAINING THE RETURN ADDRESS TO THE POINT WHERE DMSERR WAS 00106000 * CALLED. ALL REGISTERS ARE RESTORED, AND THE DISABLED WAIT 00107000 * STATE PSW IS LOADED. 00108000 * 00109000 * IF 'DIE=NO' (THE DEFAULT) WAS SPECIFIED, 00110000 * THEN A NORMAL RETURN IS MADE. 00111000 * P3071 00112000 *. P3071 00113000 EJECT P3071 00114000 DMSERR CSECT P3071 00115000 PUNCH ' LIBRARY *(DMSCWR,DMSCWRE,PRINTR,DMSCWT)' 00116000 * REGEQU 00117000 R0 EQU 0 00118000 R1 EQU 1 00119000 R2 EQU 2 00120000 R3 EQU 3 00121000 R4 EQU 4 00122000 R5 EQU 5 00123000 R6 EQU 6 00124000 R7 EQU 7 00125000 R8 EQU 8 00126000 R9 EQU 9 00127000 R10 EQU 10 00128000 R11 EQU 11 00129000 R12 EQU 12 00130000 R13 EQU 13 00131000 R14 EQU 14 00132000 R15 EQU 15 00133000 SPACE 5 00134000 TR EQU R3 POINTER TO DMSERS (ERDSECT) 00135000 IR EQU R4 'FROM' POINTER FOR TEXT 00136000 ER EQU R5 'END' POINTER FOR TEXT 00137000 OR EQU R6 'TO' PTR FOR TEXT 00138000 DR EQU R7 COUNT # DOTS IN SUBSTITUTE FIELD 00139000 LR EQU R8 COUNT LENGTH OF SUBSTITUTION 00140000 XR EQU R9 SCRATCH REGISTER 00141000 RR EQU R10 INTERNAL SUBR RETURN REG 00142000 BR EQU R12 BASE REGISTER 00143000 SPACE 5 00144000 USING DMSERR,BR 00145000 USING ERDSECT,TR 00146000 USING NUCON,R0 00147000 DMSERR CSECT 00148000 USING *,R15 00149000 L R15,=V(DMSERT) GET ADDRESS OF WORK AREA 00150000 USING ERDSECT,R15 00151000 STM R0,R14,ERSAVE SAVE REGISTERS IN WORK AREA 00152000 LR TR,R15 TR IS NORMAL WORK AREA PTR 00153000 BALR R15,0 GET ADDRESSABILITY 00154000 USING *,R15 00155000 L BR,=A(DMSERR) LOAD NORMAL BASE REGISTER 00156000 DROP R15 00157000 MVC ERSAVE+4*R15(4),=F'0' SET RETURN CODE TO 0 00158000 * IN THE PLIST PASSED TO THIS ROUTINE, EVERYTHING IS PACKED TOGETHER, 00159000 * AND, IN FACT, ANYTHING COULD BE ALMOST ANYWHERE. 00160000 * IN THE FOLLOWING CODE WE RECONSTRUCT THE PLIST IN THE WORK AREA SO 00161000 * THAT LATER WE WILL BE ABLE TO GET AT EVERYTHING EASILY. 00162000 * AT THIS POINT, R1 POINTS TO THE PASSED PLIST. 00163000 RP EQU * 00164000 SPACE 00165000 * IF THE PASSED PLIST BEGINS WITH 'DMSERR', THEN WE SKIP OVER THAT. 00166000 CLC =CL8'DMSERR',0(R1) BEGINS WITH DMSERR? 00167000 BNE *+8 SKIP IF NOT 00168000 LA R1,8(,R1) SKIP OVER IT IF SO 00169000 MVC ERPF1(2),0(R1) COPY TWO FLAG BYTES 00170000 LA R1,2(,R1) AND SKIP OVER THEM 00171000 SPACE 00172000 TM ERPF1,ERF1TX IS TEXT ADDRESS IN PLIST? 00173000 BNO RPTX GO IF NOT 00174000 MVC ERPTXA+1(3),0(R1) COPY TEXT ADDRESS INTO WORK AREA 00175000 LA R1,3(,R1) AND SKIP OVER IN PASSED PLIST 00176000 RPTX EQU * 00177000 SPACE 00178000 TM ERPF1,ERF1HD IS HEADER IN PLIST? 00179000 BNO RPHD GO IF NOT 00180000 MVC ERPHDR,0(R1) COPY HEADER INTO WORK AREA 00181000 LA R1,6(,R1) SKIP OVER IT IN PASSED PLIST 00182000 RPHD EQU * 00183000 SPACE 00184000 TM ERPF1,ERF1BF 'BUFFA' BUFFER ADDR IN PLIST? 00185000 BNO RPBF GO IF NOT 00186000 MVC ERPBFA+1(3),0(R1) COPY BUFFER ADDRESS INTO WORK 00187000 LA R1,3(,R1) AND SKIP OVER IT IN PASSED PLIST 00188000 RPBF EQU * 00189000 SPACE 00190000 * AT THIS POINT, R1 POINTS TO THE FIRST (OR ONLY) SUBSTITUTION OPTION 00191000 * BYTE. 00192000 ST R1,ERPSBA POINTER TO FIRST SUB FLAG BYTE 00193000 SPACE 2 00194000 * IF THE TEXT WAS PART OF AN MF=I PLIST, THEN IT FOLLOWS THE END OF THE 00195000 * PLIST SO FAR. WE MUST LOOP THROUGH ALL THE SUBSTITUTION PARAMETERS 00196000 * UNTIL WE GET TO THE END OF THEM. THAT IS WHERE THE TEXT IS. 00197000 * AT THIS POINT, R1 POINTS TO THE FIRST SUBSTITUTION OPTION BYTE, IF 00198000 * ANY. 00199000 TM ERPF1,ERF1TX WAS TEXT ADDR IN PLIST? 00200000 BO RPTE NOTHING TO DO -- ALREADY SET 00201000 SPACE 00202000 * IF THERE ARE NO SUBSTITUTIONS AT ALL, THEN R1 ALREADY POINTS TO THE 00203000 * TEXT. 00204000 TM ERPF1,ERF1SB1+ERF1SBN ANY SUBS? 00205000 BZ RPTFF GO IF SO -- TEXT ADDR IS IN R1 00206000 SPACE 00207000 * IF THERE IS ONLY ONE SUBSTITUTION, THEN WE MUST ONLY SKIP ONE BYTE. 00208000 TM ERPF1,ERF1SBN MULTIPLE SUBSTITUTIONS? 00209000 BO RPTF GO IF YES 00210000 LA R1,1(,R1) SKIP OVER LONE OPTION BYTE 00211000 B RPTFF R1 -> TEXT 00212000 SPACE 00213000 * MULTIPLE SUBSTITUTIONS -- WE MUST SKIP OVER THEM. 00214000 RPTF EQU * 00215000 LR R15,R1 SAVE ADDRESS OF SUB OPTION BYTE 00216000 LA R1,5(,R1) AND MAKE MOST PROBABLE SKIP 00217000 SPACE 00218000 * CUTE TRICK -- THE GROUP IS FOUR BYTES LONG IF THE FOLLOWING TEST 00219000 * GIVES 'MIXED' -- ELSE IT'S FIVE BYTES. 00220000 TM 0(R15),ERSFA+ERSFL TEST 'ADDR' AND 'LEN' FLAGS 00221000 BNM *+6 SKIP IF 5 BYTES 00222000 BCTR R1,0 DECREMENT TO SKIP ONLY 4 00223000 TM 0(R15),ERSFLST WAS THIS THE LAST SUB? 00224000 BNO RPTF LOOP BACK IF NOT 00225000 SPACE 00226000 * R1 PROBABLY NOW POINTS TO THE TEXT -- BUT IF MF=I AND RENT=NO WERE 00227000 * SPECIFIED ALONG WITH MULTIPLE SUBSTITUTIONS, THEN THE PLIST MAY 00228000 * BE PADDED WITH SOME ZEROES. WE SKIP OVER THESE. 00229000 RPTFF EQU * 00230000 CLI 0(R1),0 ARE WE POINTING TO A ZERO? 00231000 LA R1,1(,R1) INCREMENT TO NEXT BYTE 00232000 BE *-8 LOOP BACK 2 IF WE ARE 00233000 BCTR R1,0 DECREMENT TO FIRST REAL BYTE 00234000 SPACE 00235000 * AT THIS POINT, R1 POINTS TO THE TEXT. 00236000 ST R1,ERPTXA 00237000 RPTE EQU * 00238000 * THE MESSAGE HEADER HAS THE FORMAT: 'DMSXXXNNNL', WHERE XXX IS THE 00239000 * CSECT NAME, NNN IS THE MESSAGE NUMBER, AND L IS THE MESSAGE LEVEL 00240000 * LETTER. IF THE DMSERR (RATHER THAN THE LINEDIT) MACRO WAS USED, THEN 00241000 * THE PASSED PLIST CONTAINS THE NECESSARY HEADER INFORMATION. 00242000 TM ERPF1,ERF1HD WAS A MESSAGE HEADER PASSED? 00243000 BNO HDX NOTHING TO DO IF NOT 00244000 SPACE 00245000 * CREATE ERROR MESSAGE HEADER 00246000 SPACE 00247000 * FIRST, CONVERT ERROR MESSAGE NUMBER TO BCD. 00248000 MVC ERNUM-1(4),=X'F0202120' STORE EDIT PATTERN 00249000 LH R1,ERPNUM GET ERROR MESSAGE NUMBER 00250000 CVD R1,ERT1 CONVERT TO DECIMAL 00251000 ED ERNUM-1(4),ERT1+6 CONVERT TO BCD 00252000 SPACE 00253000 MVC ERMESS,=C'DMS' FIRST 3 LETTERS ARE DMS 00254000 MVC ERSECT,ERPCS COPY CSECT NAME 00255000 MVC ERLET,ERPLET COPY MESSAGE LEVEL LETTER 00256000 MVI ERBL,C' ' SET BLANK FIELD 00257000 HDX EQU * 00258000 * WE COPY THE UNSCANNED MESSAGE TEXT INTO OUR MESSAGE AREA. 00259000 L R1,ERPTXA GET ADDRESS OF MESSAGE TEXT 00260000 SR ER,ER 00261000 IC ER,0(R1) ER <- LENGTH OF MESSAGE TEXT 00262000 CH ER,=AL2(ERTSIZE) COMPARE WITH SIZE OF OUR TEXT *00263000 BUFFER 00264000 BL *+8 SKIP IF LOWER 00265000 LA ER,ERTSIZE TRUNCATE IF TOO LARGE 00266000 BCTR ER,0 ER <- (TEXT LENGTH)-1 00267000 LTR ER,ER ANYTHING LEFT? 00268000 BNM *+6 SKIP IF YES 00269000 SR ER,ER OTHERWISE USE 1 CHAR 00270000 SPACE 00271000 B *+10 SKIP OVER MVC 00272000 MVC ERTEXT(0),1(R1) LENGTH FILLED IN BY EX 00273000 EX ER,*-6 COPY TEXT 00274000 SPACE 00275000 * INITIALIZE SCAN POINTERS 00276000 LA ER,ERTEXT(ER) ER -> LAST BYTE OF TEXT 00277000 LA OR,ERTEXT-1 'TO' POINTER 00278000 LR IR,OR 'FROM' POINTER 00279000 SPACE 00280000 * THE REGISTER DR CONTAINS THE LENGTH OF THE FIELD BEING SUBBED 00281000 * INTO. WE MAKE IT NEGATIVE NOW. 00282000 SR DR,DR 00283000 BCTR DR,0 DR <- -1 00284000 * WHEN CONTROL REACHES THIS POINT, THE REGISTERS ARE SET AS FOLLOWS: 00285000 SPACE 00286000 * OR POINTS TO THE PLACE WHERE THE LAST MESSAGE CHARACTER WAS 00287000 * COPIED TO. 00288000 * IR POINTS TO THE PLACE WHERE THE LAST MESSAGE CHARACTER WAS 00289000 * COPIED FROM. 00290000 SPACE 00291000 * INITIALLY, BOTH IR AND OR (INPUT REGISTER AND OUTPUT REGISTER) 00292000 * POINT TO THE SAME PLACE. THE BASIC LOOP MOVES 1 CHARACTER AT A TIME 00293000 * FROM THE INPUT TO THE OUTPUT. BUT INITIALLY, THESE ARE IN THE SAME 00294000 * PLACE, SO THAT THE MOVE HAS NO EFFECT. IN FACT, IF THE MESSAGE 00295000 * CONTAINS NO MULTIPLE BLANKS, AND NO SUBSTITUTIONS, THEN THIS SCAN 00296000 * WILL HAVE NO EFFECT WHATSOEVER. 00297000 * HOWEVER, IF MULTIPLE BLANKS ARE DISCOVERED, THEN THOSE AFTER THE 00298000 * FIRST WILL NOT BE COPIED, SO THAT IR WILL START TO MOVE AHEAD OF 00299000 * OR, AND GENUINE DATA MOVEMENT WILL TAKE PLACE. 00300000 SPACE 00301000 * WHEN CONSECUTIVE DOTS ARE DISCOVERED IN THE MESSAGE TEXT, AND A 00302000 * SUBSTITUTION CAN BE MADE, IT PROCEEDS AS FOLLOWS: 00303000 * THE SUBSTITUTION IS MADE, OVERLAYING THE DOTS IN THE INPUT AREA. 00304000 * THEN, AFTER THE SUBSTITUTION HAS BEEN MADE, THE BASIC LOOP (AT ERLUP) 00305000 * IS RE-ENTERED, WITH IR AND OR UNCHANGED. THIS WILL CAUSE THE 00306000 * NEWLY SUBSTITUTED FIELD TO BE COPIED FROM THE INPUT AREA TO THE 00307000 * OUTPUT AREA, WITH BLANKS ELIMINATED. 00308000 SPACE 00309000 * THE REGISTER DR IS USED TO PREVENT A RECURSION LOOP. THAT IS, 00310000 * IF THE 'CHAR' OPTION IS USED IN A SUBSTITUTION, THERE IS NOTHING 00311000 * TO PREVENT THE SUBSTITUTED STRING FROM CONTAINING DOTS. THIS 00312000 * WOULD MEAN THAT ANOTHER SUBSTITUTION WOULD BE MADE INTO THE 00313000 * SUBSTITUTED FIELD. WE PREVENT THIS AS FOLLOWS: 00314000 * WHEN A SUBSTITUTION IS MADE, REGISTER DR IS SET TO THE LENGTH OF 00315000 * THE DOT FIELD, LESS 1. THAT NUMBER IS LEFT IN THERE WHEN CONTROL 00316000 * IS RETURNED TO ERLUP. THUS, AS EACH CHARACTER IN THE INPUT FIELD 00317000 * IS SCANNED, WE REDUCE REGISTER DR BY 1. IF CONSECUTIVE DOTS 00318000 * ARE FOUND, THEY WILL BE IGNORED IF REGISTER DR IS NONNEGATIVE. 00319000 * (FOR THIS REASON, DR IS INITIALIZED TO -1, ABOVE.) 00320000 SPACE 00321000 * FINALLY, WE NOTE HERE THAT REGISTER ER HAS BEEN SET TO THE LAST 00322000 * CHARACTER OF THE INPUT AREA, SO THAT IT WILL BE POSSIBLE TO KNOW 00323000 * WHEN TO STOP. 00324000 TM ERPF2,ERF2CM IS BLANK COMPRESSION WANTED? @VA02528 00325000 BZ ERLUP YES @VA02528 00326000 TM ERPF2,ERF2PR PRINT OPTION ON? @VA02528 00327000 BZ ERLUP NO @VA02528 00328000 TM ERPF2,X'01' ARE YOU SURE? @VA02528 00329000 BO ERLUP NOPE, NOT ON @VA02528 00330000 LA IR,1(,IR) SKIP TO CARRIAGE CONTROL @VA02528 00331000 CLI 0(IR),C'.' IS IT A DOT? @VA02528 00332000 BE DECRE YES, CONTINUE NORMALLY @VA02528 00333000 LA OR,1(,OR) SKIP TO CARRIAGE CONTROL @VA02528 00334000 ERLUPX LA IR,1(,IR) INCREMENT FOR CHECK @VA02528 00335000 CLI 0(IR),X'40' IS IT BLANK? @VA02528 00336000 BE ERLUPX YES, CHECK NEXT POSITION @VA02528 00337000 DECRE BCTR IR,0 GET PREVIOUS POSITION @VA02528 00338000 SPACE 2 00339000 ERLUP EQU * 00340000 CR IR,ER END OF STRING? 00341000 BNL ND END OF SCAN -- GO TYPE 00342000 LA IR,1(,IR) INCREMENT INPUT POINTER 00343000 BCTR DR,0 DECREMENT SCANNED FIELD LENGTH 00344000 CLI 0(IR),C' ' IS THE INPUT CHAR A BLANK? 00345000 BNE ERLUP1 SKIP CHECK IF NOT 00346000 TM ERPF2,ERF2CM IS BLANK COMPRESSION WANTED? 00347000 BZ ERLUP2 SIMPLY COPY THE BLANK IF NOT 00348000 * WE MUST BE CAREFUL TO OMIT THE TERMINATING BLANKS OF A 00349000 * SUBSTITUTION FIELD. DR CONTAINS THE NUMBER OF CHARACTERS AFTER 00350000 * THIS ONE, REMAINING IN THE LAST SUBSTITUTION FIELD. 00351000 LTR DR,DR ARE WE IN SUBSTITUTION FIELD? 00352000 BZ ERLUP SKIP BLK IF AT END OF SUB FIELD 00353000 BM BL1 GO IF NOT INSIDE SUB FIELD 00354000 CLI 1(IR),C' ' IS NEXT CHAR IN SUB FIELD ALSO *00355000 A BLANK? 00356000 BNE ERLUP2 COPY BLANK IF NOT 00357000 B ERLUP SKIP THIS BLANK IF SO 00358000 SPACE 00359000 * COME HERE IF WE ARE NOT INSIDE A SUBSTITUTION FIELD. 00360000 BL1 EQU * 00361000 CLI 0(OR),C' ' WAS LAST OUTPUT CHARACTER BLANK? 00362000 BE ERLUP SKIP THIS BLANK IF SO 00363000 B ERLUP2 COPY BLANK IF NOT 00364000 SPACE 00365000 ERLUP1 EQU * 00366000 CLI 0(IR),C'.' IS INPUT CHAR A DOT? 00367000 BNE ERLUP2 GO COPY IF NOT 00368000 CR IR,ER IS IT LAST CHAR OF LINE? 00369000 BE ERLUP2 COPY DOT IF SO 00370000 LTR DR,DR ARE WE RE-SCANNING INPUT FIELD? 00371000 BNM ERLUP2 COPY DOT IF WE ARE 00372000 TM ERPF1,ERF1SB1+ERF1SBN ANY SUB PARMS (LEFT)? 00373000 BZ ERLUP2 COPY DOT IF NOT 00374000 CLI 1(IR),C'.' IS NEXT CHAR ALSO A DOT? 00375000 BNE ERLUP2 COPY DOT IF NOT 00376000 BCTR IR,0 POINT TO CHAR PRECEDING DOTS 00377000 B ERDOTS GO PERFORM SUBSTITUTION 00378000 SPACE 00379000 * WHEN CONTROL REACHES THIS POINT, WE HAVE NOTHING TO DO BUT COPY OVER 00380000 * THE CHARACTER AND RETURN TO THE MAIN LOOP. 00381000 ERLUP2 EQU * 00382000 LA OR,1(,OR) INCREMENT OUTPUT POINTER 00383000 MVC 0(1,OR),0(IR) COPY OVER THE CHARACTER 00384000 B ERLUP RETURN TO MAIN LOOP 00385000 * AT THIS POINT, REGISTER IR, THE 'INPUT' REGISTER, POINTS TO THE 00386000 * CHARACTER PRECEDING THE FIELD OF DOTS. 00387000 ERDOTS EQU * 00388000 SR DR,DR NUMBER OF DOTS SO FAR 00389000 LR R1,IR R1 -> CHAR PRECEDING DOTS 00390000 SPACE 00391000 * IN THE FOLLOWING LOOP, WE COUNT THE NUMBER OF DOTS IN THE FIELD, 00392000 * AND, AT THE SAME TIME, WE CHANGE EACH DOT TO A BLANK. 00393000 ERDT1 EQU * 00394000 LA R1,1(,R1) INCREASE TEXT POINTER 00395000 CLI 0(R1),C'.' IS IT A DOT? 00396000 BNE ERDT2 NO -- WE'RE THROUGH COUNTING 00397000 CR R1,ER HAVE WE REACHED END OF TEXT? 00398000 BH ERDT2 YES -- WE'RE THROUGH COUNTING 00399000 SPACE 00400000 MVI 0(R1),C' ' OTHERWISE, CHANGE DOT TO BLANK 00401000 LA DR,1(,DR) INCREASE DOT COUNT 00402000 B ERDT1 AND LOOP BACK TO CONTINUE COUNT 00403000 SPACE 00404000 * COME HERE AT END OF DOTS 00405000 ERDT2 EQU * 00406000 BCTR DR,0 00407000 SPACE 00408000 * REGISTERS AT THIS POINT ARE: 00409000 * IR POINTS TO THE CHARACTER PRECEDING THE SUBSTITUTION FIELD. 00410000 * DR CONTAINS (THE LENGTH OF THE FIELD)-1. 00411000 SPACE 00412000 ST DR,ERSSZ SAVE SUBSTITUTION FIELD SIZE 00413000 SPACE 00414000 TM ERPF1,ERF1SBN ONE SUBSTITUTION? 00415000 BO SM GO HANDLE MULTIPLE SUB SITUATION 00416000 SPACE 00417000 * OTHERWISE, THERE IS ONLY ONE SUBSTITUTION, AND THE DATA IS IN REG 0. 00418000 MVC ERSBD,ERSAVE+4*R0 COPY R0 FROM SAVE AREA 00419000 L R1,ERPSBA POINT TO OPTION BYTE IN PLIST 00420000 MVC ERSBF,0(R1) COPY OPTION BYTE INTO WORK AREA 00421000 MVC ERSBL,ERSBD COPY LENGTH BYTE PASSED, IF ANY 00422000 B SSC GO HANDLE SUBSTITUTION 00423000 SPACE 00424000 * COME HERE IF THIS IS ONE OF MULTIPLE SUBSTITUTIONS. THE SUBSTITUTION 00425000 * INFORMATION IS PACKED TOGETHER AT THE END OF THE PLIST, AND ERPSBA IN 00426000 * OUR WORK AREA POINTS TO THE INFORMATION FOR THE CURRENT ONE. 00427000 * THIS INFORMATION AREA CAN HAVE THREE FORMATS, INDICATED BY THE OPTION 00428000 * BYTE, WHICH IS ALWAYS THE FIRST BYTE OF THE GROUP (FOR THE FLAG 00429000 * DEFINITIONS FOR THIS OPTION BYTE, SEE FLAGS DEFINITIONS UNDER ERSBF 00430000 * IN WORK AREA). 00431000 SPACE 00432000 * THE FORMATS ARE AS FOLLOWS: 00433000 SPACE 00434000 * IF NEITHER ERSFA NOR ERSFL IS ON, THEN WE ARE BEING PASSED FOUR BYTES 00435000 * OF DATA IN THE FORM, 00436000 * (1 BYTE OPTION BYTE) (4 BYTES OF DATA) 00437000 SPACE 00438000 * IF JUST ERSFA IS ON, THEN WE ARE BEING PASSED THE ADDRESS OF 00439000 * THE DATA, WITH NO LENGTH SPECIFIED, IN THE FOLLOWING FORMAT: 00440000 * (1 BYTE OPTION BYTE) (3 BYTE ADDRESS) 00441000 SPACE 00442000 * IF BOTH ERSFA AND ERSFL ARE ON, THEN WE ARE BEING PASSED AN ADDRESS 00443000 * AND LENGTH, IN THE FOLLOWING FORMAT: 00444000 * (1 BYTE OPTION BYTE) (1 BYTE LENGTH FIELD) (3 BYTE ADDRESS) 00445000 SPACE 00446000 * IT IS IMPOSSIBLE FOR ERSFL TO BE ON WITH ERSFA OFF. 00447000 SPACE 00448000 * IN ORDER TO SIMPLIFY THINGS, WE COPY THE INFORMATION INTO FIELDS OF 00449000 * OUR WORK AREA, SO THAT THE INDIVIDUAL SUBSTITUTION ROUTINES WILL 00450000 * NOT HAVE ANY TROUBLE FINDING THINGS. 00451000 SM EQU * 00452000 L R1,ERPSBA POINT TO SUBSTITUTION PARMS 00453000 MVC ERSBF,0(R1) COPY OPTION BYTE TO WORK AREA 00454000 MVC ERSBD,1(R1) COPY DATA VALUE OR ADDRESS 00455000 MVC ERSBL,1(R1) COPY LENGTH FIELD, IF ANY 00456000 TM ERSBF,ERSFA+ERSFL TEST BOTH FLAGS SIMULTANEOUSLY 00457000 SPACE 00458000 * IF 'MIXED', THEN WE HAVE THE ONLY POSSIBLE CASE OF A FOUR-BYTE FIELD 00459000 * (OTHER CASES HAVE 5-BYTE FIELDS). 00460000 BNM *+12 SKIP 2 INSTRUCTIONS IF NOT MIXED 00461000 MVC ERSBD,0(R1) COPY DATA ADDRESS CORRECTLY 00462000 BCTR R1,0 DECREMENT SO SKIP ONLY FOUR 00463000 LA R1,5(,R1) SKIP FIVE BYTES 00464000 ST R1,ERPSBA POINTER TO NEXT SUBSTITUTION FLD 00465000 SPACE 00466000 * WHEN CONTROL REACHES THIS POINT, THE SUBSTITUTION INFORMATION HAS 00467000 * BEEN COPIED INTO THE VARIOUS FIELDS OF THE WORK AREA, AND WE CAN GO 00468000 * TO WORK. 00469000 SSC EQU * 00470000 TM ERSBF,ERSFLST IS THIS THE LAST SUBSTITUTION *00471000 PARAMETER FIELD? 00472000 BNO *+8 SKIP IF NOT 00473000 NI ERPF1,X'FF'-(ERF1SB1+ERF1SBN) TURN OFF SUBSTITUTIONS *00474000 FLAGS, TO PREVENT FURTHER ONES 00475000 SPACE 00476000 * SO ALL POINTERS ARE NOW SET UP, AND THE REGISTERS ARE AS FOLLOWS: 00477000 * IR -> CHARACTER PRECEDING THE SUBSTITUTION FIELD 00478000 * DR CONTAINS THE (LENGTH OF THE SUBSTITUTION FIELD) - 1, WHICH EQUALS 00479000 * THE (NUMBER OF DOTS IN THE FIELD) - 1. 00480000 IC R1,ERSBF GET OPTION BYTE FROM WORK AREA 00481000 N R1,=AL1(0,0,0,7) GET LAST THREE BITS 00482000 AR R1,R1 MULTIPLY BY FOUR 00483000 AR R1,R1 00484000 B *+4(R1) BRANCH BASED ON OPTION 00485000 B SH HEX OR HEXA 00486000 B SD DEC OR DECA 00487000 B SC CHARA 00488000 B SH4 HEX4A 00489000 B SC8 CHAR8A 00490000 B SSTAR ILLEGAL 00491000 B SSTAR ILLEGAL 00492000 B SSTAR ILLEGAL 00493000 SPACE 3 00494000 * ILLEGAL ARGUMENT -- JUST PUT TWO DOTS INTO FIELD. 00495000 SSTAR EQU * 00496000 MVC 0(2,IR),=C'**' 00497000 B SEND GO FINISH UP SUBSTITUTION 00498000 EJECT 00499000 * CHAR OPTION -- MAKE A CHARACTER SUBSTITUTION. 00500000 SC EQU * 00501000 SR R1,R1 00502000 IC R1,ERSBL GET SPECIFIED LENGTH, IF ANY 00503000 BCTR R1,0 DECREMENT BY 1 00504000 TM ERSBF,ERSFL WAS A LENGTH SPECIFIED? 00505000 BO *+6 SKIP IF SO 00506000 LR R1,DR OTHERWISE, USE NUMBER OF DOTS 00507000 SPACE 00508000 * AT THIS POINT, R1 CONTAINS EITHER THE LENGTH SPECIFIED BY THE USER 00509000 * (MINUS 1) OR, IF NONE WAS SPECIFIED, THE CONTENTS OF DR, WHICH 00510000 * CONTAINS ONE LESS THAN THE NUMBER OF DOTS IN THE FIELD. 00511000 * WE NOW TAKE THE MINIMUM OF DR AND R1, AND THAT IS THE LENGTH OF THE 00512000 * SUBSTITUTION TO BE MADE. 00513000 LTR R1,R1 WAS SPECIFIED LENGTH = 0? 00514000 BM SEND NOTHING TO DO IF IT WAS 00515000 CLR R1,DR TAKE MINIMUM 00516000 BNL *+6 SKIP IF SPECIFIED LEN HIGHER 00517000 LR DR,R1 IF LESS, USE SPECIFIED LENGTH 00518000 SPACE 00519000 * DR NOW CONTAINS ONE LESS THAN THE NUMBER OF CHARACTERS TO BE COPIED 00520000 * OVER. 00521000 L R1,ERSBD GET DATA POINTER 00522000 B *+10 SKIP OVER MVC 00523000 MVC 1(,IR),0(R1) LENGTH FILLED IN BY EX 00524000 EX DR,*-6 MOVE DATA INTO MESSAGE AREA 00525000 B SEND GO FINISH UP SUBSTITUTION 00526000 EJECT 00527000 * CHAR8 OPTION -- MAKE A CHARACTER SUBSTITUTION, BUT STORE A BLANK 00528000 * AFTER EVERY EIGHTH CHARACTER. 00529000 SC8 EQU * 00530000 TM ERSBF,ERSFL WAS A LENGTH SPECIFIED? 00531000 BNO SC8A SKIP COMPUTATION IF NOT 00532000 SPACE 00533000 * OTHERWISE, THE MACRO SPECIFIED A LENGTH, IN BYTES, OF THE INPUT FIELD 00534000 * TO BE COPIED. WE MUST DETERMINE HOW MANY BYTES THE SPECIFIED LENGTH 00535000 * WILL REQUIRE IN THE MESSAGE TEXT. IT WILL BE APPROXIMATELY 9/8 AS 00536000 * BIG TO ACCOMODATE THE BLANK AT THE END OF EACH EIGHTH CHARACTER. 00537000 * THE EXACT FORMULA IS: 00538000 * REQUIRED LENGTH = (L-1)/8*9 + MOD(L-1,8) + 1, 00539000 * WHERE L IS THE LENGTH SPECIFIED BY THE USER. 00540000 * WE PERFORM THIS COMPUTATION BELOW, EXCEPT THAT WE DO NOT BOTHER TO 00541000 * ADD IN THE '+1' OF THE FORMULA, SINCE WE WANT THE (LENGTH - 1), 00542000 * ANYWAY. 00543000 SLR R0,R0 00544000 SLR R1,R1 00545000 IC R1,ERSBL GET LENGTH SPECIFIED BY MACRO 00546000 BCTR R1,0 TAKE (L-1) 00547000 LTR R1,R1 IS IT NEGATIVE? 00548000 BM SEND HE SPECIFIED 0 LENGTH -- THAT *00549000 MEANS NOTHING TO DO 00550000 SPACE 00551000 * THE R0-R1 REGISTER PAIR CONTAINS (L-1). WE DIVIDE BY 8, TO PUT 00552000 * (L-1)/8 INTO REGISTER 1, AND MOD (L-1,8) INTO R0. 00553000 D R0,=F'8' DIVIDE BY 8 00554000 MH R1,=H'9' COMPUTE (L-1)/8*9 00555000 AR R1,R0 (L-1)/8*9 + MOD(L-1,8) 00556000 SPACE 00557000 * REGISTER 1 NOW CONTAINS ONE LESS THAN THE NUMBER OF BYTES NECESSARY 00558000 * TO COMPLY WITH THE USER'S LENGTH REQUEST. DR CONTAINS ONE LESS THAN 00559000 * THE AVAILABLE FIELD SIZE (NUMBER OF DOTS). WE COMPARE THE TWO, AND 00560000 * TAKE THE MINIMUM. 00561000 CLR R1,DR COMPARE THE TWO 00562000 BNL *+6 00563000 LR DR,R1 TAKE THE MINIMUM 00564000 SPACE 00565000 * WE NOW PERFORM A LOOP WHICH COPIES 8 CHARACTERS AT A TIME, PUTTING 00566000 * A SPACE AFTER EACH ONE, UNTIL THE FIELD IS EXHAUSTED. 00567000 SC8A EQU * 00568000 LA XR,1(,DR) XR <- EXACT FIELD LENGTH 00569000 LR R14,IR R14 -> TARGET AREA 00570000 L R15,ERSBD R15 -> SOURCE DATA AREA 00571000 SPACE 00572000 * LOOP BACK TO THIS POINT TO COPY THE NEXT EIGHT CHARACTERS. 00573000 SC8B EQU * 00574000 LR R1,XR COPY LENGTH REMAINING 00575000 CH R1,=H'8' AT LEAST 8 CHARS LEFT? 00576000 BL *+8 SKIP IF NOT 00577000 LA R1,8 IF SO, COPY ONLY 8 CHARACTERS 00578000 BCTR R1,0 DECREMENT FOR EX 00579000 B *+10 SKIP OVER MVC 00580000 MVC 1(,R14),0(R15) LENGTH FILLED IN BY EX 00581000 EX R1,*-6 MOVE UP TO EIGHT BYTES OF DATA 00582000 LA R14,9(,R14) INCREMENT TARGET POINTER, *00583000 SKIPPING OVER AN EXTRA BLANK 00584000 LA R15,8(,R15) SKIP OVER SOURCE 00585000 SH XR,=H'9' COMPUTE REMAINING TARGET AREA 00586000 BP SC8B LOOP BACK IF ANYTHING LEFT 00587000 B SEND GO FINISH UP SUBSTITUTION 00588000 EJECT 00589000 * HEX AND HEXA OPTIONS -- PERFORM A HEXADECIMAL SUBSTITUTION. 00590000 SPACE 00591000 * SEE DISCUSSION BELOW UNDER 'HEX4A' OPTION FOR EXPLANATION OF WHY 00592000 * A LENGTH IS NOT ALLOWED WITH THE 'HEXA' OPTION. 00593000 SH EQU * 00594000 TM ERSBF,ERSFA WAS AN ADDRESS SPECIFIED? 00595000 L R1,ERSBD LOAD THIS ADDRESS, IF SO 00596000 BZ *+10 SKIP IF DATA VALUE WAS SPECIFIED 00597000 MVC ERSBD,0(R1) COPY DATA INTO ERSBD 00598000 SPACE 00599000 * IN EITHER CASE, ERSBD NOW CONTAINS THE FOUR BYTES OF DATA. 00600000 CH DR,=H'7' MAXIMUM LENGTH IS 8 00601000 BL *+8 LONGER THAN 8? 00602000 LA DR,7 ALLOW ONLY 8 CHARS 00603000 SPACE 00604000 * CONVERT NUMBER TO BCD HEX 00605000 UNPK ERT2(9),ERSBD(5) UNPACK IT 00606000 TR ERT2(8),TRTBL TRANSLATE IT 00607000 SPACE 00608000 * COPY ONLY THE LAST K CHARACTERS, WHERE K IS THE LENGTH OF THE FIELD. 00609000 LA R1,ERT2+7 POINT TO END OF STRING 00610000 SR R1,DR SUBTRACT NUMBER OF CHARS 00611000 B *+10 SKIP OVER MVC 00612000 MVC 1(0,IR),0(R1) LENGTH FILLED IN BY MVC 00613000 EX DR,*-6 COPY STRING 00614000 B SEND GO FINISH UP SUBSTITUTION 00615000 SPACE 00616000 TRTBL EQU *-C'0' DISPLACE TRANSLATE TABLE BACK 00617000 DC C'0123456789ABCDEF' TRANSLATE TABLE 00618000 EJECT 00619000 * HEX4A OPTION. COVERT THE SOURCE DATA FIELD INTO GRAPHIC 00620000 * HEXADECIMAL, INSERTING A BLANK ON THE LINE AFTER EACH FOUR BYTES 00621000 * OF INPUT ( FOUR BYTES OF OUTPUT). 00622000 * NOTICE THAT THIS OPTION (HEX4A) IS DIFFERENT FROM THE HEX OPTION, 00623000 * EVEN FOR VERY SHORT SUBSTITUTIONS -- UNDER FOUR CHARACTERS. 00624000 * THE DIFFERENCE IS THAT YOU ALWAYS SPECIFIED FOUR BYTES OF DATA WITH 00625000 * THE HEX OPTION, AND IF THE FIELD CONTAINS LESS THAN EIGHT BYTES, 00626000 * YOU TRUNCATE FROM THE LEFT, KEEPING LOW-ORDER DIGITS IN THE FINAL 00627000 * TEXT. IN THE CASE OF THE HEX4A OPTION, YOU TRUNCATE FROM THE RIGHT. 00628000 * IN FACT, IT WAS THIS CONFUSION THAT CASUED ME NOT EVEN TO ALLOW A 00629000 * LENGTH OT BE SPECIFIED WITH THE 'HEXA' OPTION. 00630000 SH4 EQU * 00631000 TM ERSBF,ERSFL DID THE USER SPECIFY A LENGTH? 00632000 BNO SH4A GO IF HE DID NOT 00633000 SPACE 00634000 * IF THE USER SPECIFIED A LENGTH, IT IS THE LENGTH OF THE SOURCE FIELD, 00635000 * WHICH IS TO BE CONVERTED. WE MUST COMPUTE THE FIELD SIZE WHICH HE 00636000 * WILL REQUIRE FOR HIS INPUT LENGTH. THIS WILL BE APPROXIMATELY 00637000 * 9/4'THS OF THE INPUT LENGTH. THE EXACT FORMULA IS: 00638000 * REQUIRED LENGTH = (L-1)/4*9 + 2*MOD(L-1,4) + 2 00639000 * WE COMPUTE THIS FORMULA BELOW, EXCEPT THAT WE ADD IN '+1' RATHER THAN 00640000 * '+2', SINCE WE ARE INTERESTED IN THE LENGTH-1, TO COMPARE WITH 00641000 * REGISTER DR. 00642000 SLR R0,R0 00643000 SLR R1,R1 00644000 IC R1,ERSBL GET SPECIFIED LENGTH 00645000 BCTR R1,0 R1 <- (L-1) 00646000 LTR R1,R1 WAS LENGTH = 0? 00647000 BM SEND NOTHING TO DO IF SO 00648000 SPACE 00649000 * WE DIVIDE (L-1) BY 4. THE QUOTIENT IS IN REG 1, AND THE 00650000 * REMAINDER (MOD(L-1,4)) IS IN REG 0. 00651000 D R0,=F'4' DIVIDE BY 4 00652000 MH R1,=H'9' R1 <- (L-1)/4*9 00653000 AR R0,R0 R0 <- 2*MOD(L-1,4) 00654000 AR R1,R0 R1 <- (L-1)/4*9 + 2*MOD(L-1,4) 00655000 LA R1,1(,R1) ADD AN EXTRA 1 00656000 SPACE 00657000 * R1 CONTAINS THE (NEEDED FIELD LENGTH) - 1 00658000 CLR R1,DR TAKE MINIMUM OF THE TWO 00659000 BNL *+6 00660000 LR DR,R1 00661000 SPACE 00662000 * WE NOW CONVERT 4 BYTES AT A TIME OF THE SOURCE INTO EIGHT CHARACTERS, 00663000 * AND INSERT THEM INTO THE MESSAGE AREA, PUTTING A BLANK AT THE END 00664000 * OF EACH GROUP. 00665000 SH4A EQU * 00666000 LA XR,1(,DR) XR CONTAINS REAL FIELD SIZE 00667000 LR R14,IR R14 -> TARGET AREA 00668000 L R15,ERSBD R15 -> SOURCE AREA 00669000 SPACE 00670000 * LOOP BACK TO THIS POINT EACH TIME TO CONVERT FOUR MORE BYTES. 00671000 SH4B EQU * 00672000 LR R1,XR GET NUMBER OF BYTES REMAINING 00673000 L R2,0(R15) GET DATA TO BE CONVERTED @VA02693 00674000 ST R2,ERT1 PUT DATA INTO WORK AREA @VA02693 00675000 UNPK ERT2(9),ERT1(5) CONVERT FOUR MORE BYTES @VA02693 00676000 TR ERT2(8),TRTBL 00677000 CH R1,=H'8' AT LEAST EIGHT BYTES LEFT? 00678000 BL *+8 SKIP IF NOT 00679000 LA R1,8 USE ONLY 8 CHARS IF MORE 00680000 BCTR R1,0 DECREMENT FOR EX 00681000 B *+10 SKIP OVER MVC 00682000 MVC 1(,R14),ERT2 LENGTH FILLED IN BY EX 00683000 EX R1,*-6 COPY DATA INTO MESSAGE AREA 00684000 LA R14,9(,R14) SKIP OVER COPIED DATA AND BLANK 00685000 LA R15,4(,R15) SKIP OVER SOURCE JUST CONVERTED 00686000 SH XR,=H'9' COMPUTE NUMBER BYTES REMAINING 00687000 BP SH4B GO IF SOMETHING LEFT 00688000 B SEND OTHERWISE, FINISH UP SUB 00689000 EJECT 00690000 * DEC OR DECA OPTION. PERFORM A DECIMAL CONVERSION. 00691000 SD EQU * 00692000 L R1,ERSBD GET DATA ADDRESS, IF DECA 00693000 TM ERSBF,ERSFA WAS IT DECA? 00694000 BZ *+10 SKIP MVC IF NOT 00695000 MVC ERSBD,0(R1) COPY DATA INTO ERSBD 00696000 L R0,ERSBD R0 NOW CONTAINS THE VALUE TO *00697000 BE CONVERTED. 00698000 LTR XR,R0 GET NUMBER 00699000 BNM ERDD1 GO IF NO MINUS SIGN 00700000 SPACE 00701000 * IF THE NUMBER IS NEGATIVE, WE INCREASE IR AND DECREASE DR, SO 00702000 * THAT WE WILL HAVE ROOM FOR A MINUS SIGN. 00703000 LA IR,1(,IR) INCREASE OUTPUT POINTER 00704000 LPR R0,R0 MAKE NUMBER POSITIVE 00705000 BCTR DR,0 DECREASE FIELD LENGTH BY 1 00706000 SPACE 00707000 * THE NUMBER IN R0 IS NOW POSITIVE. THE REAL NUMBER IS IN XR. 00708000 ERDD1 EQU * 00709000 CH DR,=H'14' BUFFER LENGTH EXCEED 15? 00710000 BL *+8 SKIP IF NOT 00711000 LA DR,14 15 IS THE MAXIMUM 00712000 SPACE 00713000 CVD R0,ERT1 CONVERT NUMBER TO DECIMAL 00714000 MVC ERT2(16),ERDDED MOVE IN EDIT PATTERN 00715000 ED ERT2(16),ERT1 CONVERT NUMBER TO BCD 00716000 SPACE 00717000 * COPY ONLY THE LAST K CHARACTERS, WHERE K IS THE LENGTH OF THE FIELD. 00718000 LA R1,ERT2+15 POINT TO END OF STRING 00719000 SR R1,DR SUBTRACT NUMBER OF CHARS 00720000 B *+10 SKIP OVER MVC 00721000 MVC 1(0,IR),0(R1) LENGTH FILLED IN BY EX 00722000 EX DR,*-6 COPY BCD DECIMAL STRING 00723000 SPACE 00724000 * WE MUST RESET SOME POINTERS, IF THE ORIGINAL NUMBER WAS NEGATIVE. 00725000 LTR XR,XR WAS NUMBER NEGATIVE? 00726000 BNM SEND FINISH UP IF NOT 00727000 BCTR IR,0 RESET FIELD POINTER 00728000 LA DR,1(,DR) RESET FIELD LENGTH 00729000 SPACE 00730000 * WE SEARCH FOR THE FIRST NON-BLANK IN THE DECIMAL NUMBER, AND 00731000 * INSERT A MINUS SIGN IN FRONT OF IT. 00732000 LR R1,IR R1 -> BLANK BEFORE FIELD 00733000 LA R1,1(,R1) INCREMENT CHAR POINTER 00734000 CLI 0(R1),C' ' IS IT A BLANK 00735000 BE *-8 LOOP BACK IF IT IS 00736000 BCTR R1,0 POINT TO BLANK PRECEDING DIGIT 00737000 MVI 0(R1),C'-' MOVE IN MINUS SIGN 00738000 B SEND GO FINISH UP SUBSTITUTION 00739000 SPACE 00740000 ERDDED DC C' ',13X'20',X'2120' EDIT PATTERN 00741000 EJECT 00742000 * FINISH UP THE SUBSTITUTION. WE MUST SKIP ALL LEADING BLANKS IN 00743000 * THE SUBSTITUTION FIELD (THE COPY LOOP WILL SKIP TERMINATING BLANKS). 00744000 * OF COURSE WE DON'T DO THAT IF BLANK COMPRESSION IS NOT WANTED. 00745000 SEND EQU * 00746000 L DR,ERSSZ RESTORE SIZE OF SUB FIELD 00747000 LA DR,1(,DR) DR <- # CHARS IN SUB FIELD 00748000 TM ERPF2,ERF2CM BLANK COMPRESSION WANTED? 00749000 BZ ERLUP GO IMMEDIATELY IF NOT 00750000 SPACE 00751000 * THE FOLLOWING LOOP SKIPS LEADING BLANKS. 00752000 SEND1 EQU * 00753000 CLI 1(IR),C' ' NEXT CHAR A BLANK? 00754000 BNE ERLUP RE-ENTER SCAN LOOP IF NOT 00755000 LA IR,1(,IR) SKIP OVER TO IT 00756000 BCT DR,SEND1 LOOP BACK IF NOT END OF FIELD 00757000 B ERLUP RE-ENTER SCAN LOOP 00758000 * COME HERE ON END OF SCAN. 00759000 ND EQU * 00760000 TM ERPF2,ERF2DT DOES HE WANT A DOT? 00761000 BZ NDD GO IF NOT 00762000 TM ERPF2,ERF2CM DOES HE WANT BLANK COMPRESSION? 00763000 BZ NB SKIP IF NOT 00764000 CLI 0(OR),C' ' IS THERE A TERMINATING BLANK? 00765000 BNE NB SKIP IF NOT 00766000 BCTR OR,0 JUMP BACK IF SO 00767000 SPACE 00768000 NB EQU * 00769000 CLI 0(OR),C'.' IS LAST CHAR ALREADY A DOT? 00770000 BNE *+6 SKIP IF NOT 00771000 BCTR OR,0 DON'T HAVE TWO, IF SO 00772000 MVI 1(OR),C'.' INSERT A DOT 00773000 LA OR,1(,OR) POINT TO LAST CHAR OF MESSAGE 00774000 SPACE 00775000 * AT THIS POINT, OR -> THE LAST CHAR OF THE MESSAGE. WE COMPUTE 00776000 * MESSAGE LENGTH AND MESSAGE STARTING ADDRESS, AND STORE THEM INTO 00777000 * THE 'TYPLIN' PLIST, FOR LACK OF A BETTER PLACE. 00778000 NDD EQU * 00779000 LA R1,ERMESS POINT TO START OF MESSAGE 00780000 TM ERPF1,ERF1HD IS THERE A MESSAGE HEADER? 00781000 BO *+8 SKIP IF SO 00782000 LA R1,ERTEXT OTHERWISE, POINT TO TEXT AREA 00783000 ST R1,ERTPLA STORE ADDRESS IN TYPLIN PLIST 00784000 SR OR,R1 COMPUTE MESSAGE LENGTH 00785000 LA OR,1(,OR) OR CONTAINS MESSAGE LENGTH 00786000 ST OR,ERTPLL STORE LENGTH IN TYPLIN PLIST 00787000 TM ERPF1,ERF1BF WAS 'BUFFA' SPECIFIED? 00788000 BZ NU GO IF NOT 00789000 SPACE 00790000 * OTHERWISE, WE COPY THE MESSAGE TEXT INTO THE USER'S BUFFER AREA. 00791000 L R1,ERTPLL GET MESSAGE LENGTH 00792000 L R14,ERTPLA ADDRESS OF MESSAGE TEXT 00793000 BCTR R14,0 POINT TO PRECEDING BYTE 00794000 STC R1,0(R14) STORE LENGTH INTO PRECEDING BYTE 00795000 L R15,ERPBFA POINT TO SPECIFIED BUFFER AREA 00796000 B *+10 SKIP OVER MVC 00797000 MVC 0(0,R15),0(R14) LENGTH FILLED IN BY EX 00798000 EX R1,*-6 COPY OVER LENGTH AND MESSAGE 00799000 SPACE 00800000 NU EQU * 00801000 SPACE 00802000 * WE NOW BRANCH TO A SPECIAL ROUTINE DEPENDING ON WHAT THE MACRO 00803000 * SPECIFIED IN THE 'DISP' FIELD. 00804000 IC R1,ERPF2 GET DISP BYTE 00805000 N R1,=AL1(0,0,0,7) GET LAST THREE BITS 00806000 AR R1,R1 MULTIPLY BY 4 00807000 AR R1,R1 00808000 B *+4(R1) BRANCH TO SPECIALIZED ROUTINE 00809000 B DER DISP=ERRMSG 00810000 B DTY DISP=TYPE 00811000 B DSI DISP=SIO 00812000 B DNO DISP=NONE 00813000 B DPR DISP=PRINT 00814000 B DCP DISP=CPCOMM 00815000 B DTY ILLEGAL 00816000 B DTY ILLEGAL 00817000 B DTY ILLEGAL 00818000 EJECT 00819000 * 'ERRMSG' OPTION. IN MOST CASES, WE WILL SET A SPECIAL BIT IN THE 00820000 * TYPLIN PLIST SO THAT CONWRIT WILL DO THE SIO TO CP WITH A SPECIAL 00821000 * OPCODE OF X'05', WHICH WILL INDICATE TO CP THAT THIS IS TO BE 00822000 * PROCESSED AS AN ERROR MESSAGE. 00823000 DER EQU * 00824000 SPACE 00825000 * TYPLIN PLIST BITS 00826000 ERMBIT EQU X'40' ERROR MESSAGE BIT 00827000 NOHTBIT EQU X'01' 'HT' CAN'T CANCEL THIS LINE 00828000 SPACE 00829000 * THE BITS THAT GET SET IN THE PLIST DEPEND ON THE 'LET' FIELD OF THE 00830000 * ERROR MESSAGE. THE BITS ARE SET AS FOLLOWS: 00831000 * E + I + W -> ERMBIT 00832000 * S + T -> NOHTBIT 00833000 * R + OTHERS -> NO BITS 00834000 SPACE 00835000 * WE CHECK THE LETTER NINE BYTES FROM THE START OF THE MESSAGE TEXT, 00836000 * WHETHER DMSERR CREATED THE HEADER OR NOT. THIS WILL ALLOW 00837000 * 'LINEDIT DISP=ERRMSG' TO WORK PROPERLY, WITH THE USER SPECIFYING HIS 00838000 * OWN HEADER. 00839000 L R1,ERTPLA GET ADDRESS OF MESSAGE TEXT 00840000 CLI 9(R1),C'E' IS LETTER = E 00841000 BE DERE GO IF YES 00842000 CLI 9(R1),C'I' LETTER = I 00843000 BE DERE GO IF SO 00844000 CLI 9(R1),C'W' LETTER = W 00845000 BE DERE GO IF SO 00846000 CLI 9(R1),C'S' LETTER = S 00847000 BE DERH GO IF SO 00848000 CLI 9(R1),C'T' LETTER = T 00849000 BE DERH GO IF SO 00850000 SPACE 00851000 * OTHERWISE, WE SET NO BITS WHATSOEVER, AND GO TYPE IT OUT. 00852000 MVI ERTPLL+1,0 ZERO OUT FLAG BYTE 00853000 B DTY 00854000 SPACE 00855000 * FOR E, I AND W, SET THE ERMBIT, SO THAT SIO X'05' WILL BE USED. 00856000 DERE EQU * 00857000 MVI ERTPLL+1,ERMBIT SET ERROR MESSAGE BIT 00858000 B DTY GO TYPE MESSAGE 00859000 SPACE 00860000 * FOR S AND T MESSAGES, SET NOHTBIT, SO THAT THE MESSAGE CAN NEVER 00861000 * BE CANCELED. 00862000 DERH EQU * 00863000 MVI ERTPLL+1,NOHTBIT SET NO HT BIT 00864000 B DTY 00865000 EJECT 00866000 * 'TYPE' OPTION. WE BALR TO TYPLIN, SO THAT WE WON'T DO AN SVC, SO 00867000 * THAT WE CAN BE CALLED FROM THE SAVC HANDLER, DMSITS. 00868000 DTY EQU * 'TYPE' OPTION 00869000 L R15,=V(DMSCWR) POINT TO TYPLIN ROUTINE 00870000 LA R1,ERTPL POINT TO TYPLIN PLIST 00871000 MVI ERTPLA,1 FILL IN REST OF IT 00872000 MVI ERTPLL,C'R' 00873000 MVC ERTPL(8),=CL8'TYPLIN' 00874000 BAL RR,NUCCALL CALL TYPEOUT ROUTINE 00875000 B DNO 00876000 EJECT 00877000 * PRINT OPTION. 00878000 DPR EQU * 00879000 MVC ERTPL(8),=CL8'PRINTR' SET UP PRINTR PLIST 00880000 LA R1,ERTPL AND POINT TO IT 00881000 L R15,=V(PRINTR) VCON FOR PRINTR ROUTINE 00882000 BAL RR,NUCCALL GO CALL IT 00883000 B DNO WE'RE FINISHED 00884000 EJECT 00885000 * DISP=SIO IS USED ONLY FOR EMERGENCIES, SUCH AS WHEN TYPLIN IS 00886000 * CALLING DMSERR. IT DOES ITS OWN SIO'S TO THE TERMINAL, AND DOESN'T 00887000 * USE SYSTEM FACILITIES. 00888000 DSI EQU * 00889000 SSM =X'00' DISABLE ALL INTERRUPTS V0005 00890000 SR R1,R1 V0005 00891000 BCTR R1,0 R1 <- -1 V0005 00892000 DIAG R1,R14,X'24' FIND ADDRESS OF CONSOLE V0005 00893000 BC B'0001',DSNC CC = 3 -> NO VIRTUAL CONSOLV0005 00894000 SPACE 1 V0005 00895000 * OTHERWISE, R1 CONTAINS THE VIRTUAL CONSOLE ADDRESS V0005 00896000 SPACE 1 V0005 00897000 * WE NOW 'REMEMBER' WHETHER THERE IS ACTIVITY PENDING ON THE V0005 00898000 * VIRTUAL CONSOLE, SO WE CAN RESTORE THE STATUS AFTER WE HAVE V0005 00899000 * TYPED OUT THE MESSAGE. V0005 00900000 SR XR,XR ZERO FLAG = NO TERMINAL ACTIVITY 00901000 TIO 0(R1) ANY CONSOLE ACTIVITY? V0005 00902000 BZ DSIS GO IF NOT 00903000 LA XR,1 SET FLAG FOR CONSOLE ACTIVITY 00904000 TIO 0(R1) WAIT FOR CONSOLE ACTIVITY V0005*00905000 TO FINISH V0005 00906000 BC 7,*-4 JUMP BACK IF NOT FINISHED 00907000 SPACE 00908000 * SET UP CCW 00909000 DSIS EQU * 00910000 MVC ERT2(16),CCWS COPY DUMMY CCWS INTO WORK AREA 00911000 MVC ERT2+1(3),ERTPLA+1 COPY DATA ADDRESS INTO CCW 00912000 MVC ERT2+5(3),ERTPLL+1 COPY DATA LENGTH INTO CCW 00913000 LA R0,ERT2 00914000 ST R0,CAW STORE IN CAW V0005 00915000 SIO 0(R1) DO OUTPUT TO CONSOLE V0005 00916000 BC 7,*-4 LOOP UNTIL IT 'TAKES' 00917000 TIO 0(R1) WAIT FOR COMPLETION V0005 00918000 BC 7,*-4 WAIT UNTIL IT COMPLETES 00919000 LTR XR,XR WAS THERE ANY CONSOLE ACTIVITY? 00920000 BZ DNO NOTHING TO DO IF NOT 00921000 SPACE 1 V0005 00922000 * WE NOW WISH TO RESTORE THE 'ACTIVITY PENDING' STATUS OF THE V0005 00923000 * CONSOLE, TO KEEP THE CONSOLE HANDLING ROUTINES HAPPY. THE V0005 00924000 * WAY TO DO THIS IS TO DO A SIO ON THE SECOND OF THE TWO CCW'S V0005 00925000 * IN CCWCONS, WHICH IS THE AREA IN NUCON USED BY THE CONSOLE V0005 00926000 * ROUTINES. V0005 00927000 MVI CONCCWS+8,4 CHANGE NOP TO SENSE V0005 00928000 LA R0,CONCCWS+8 POINT TO CCW V0005 00929000 ST R0,CAW STORE IN CAW V0005 00930000 SIO 0(R1) START I/O ON THIS CCW V0005 00931000 BC 7,*-4 LOOP UNTIL IT 'TAKES' V0005 00932000 MVI CONCCWS+8,3 CHANGE SENSE BACK TO NOP V0005 00933000 B DNO GO FINISH UP 00934000 SPACE 2 V0005 00935000 * IF THE GUY HAS NO CONSOLE ATTACHED, THEN WE PRODUCE THE MESSAGE V0005 00936000 * BY MEANS OF 'CP MSG *' COMMAND. V0005 00937000 DSNC EQU * V0005 00938000 LA R1,DSMS POINT TO MSG * V0005 00939000 LA R0,DSMSL GET LENGTH OF MESSAGE V0005 00940000 DIAG R1,R0,8 DIAGNOSE TO CP V0005 00941000 B DIE DIE IMMEDIATELY V0005 00942000 SPACE 1 V0005 00943000 DSMS DC C'MSG * DMSERR215T NO VIRTUAL CONSOLE ATTACHED. ' V0005 00944000 DC C'RE-IPL CMS.' V0005 00945000 DSMSL EQU *-DSMS V0005 00946000 SPACE 2 00947000 CCWS CCW 9,0,X'60',0 WRITE WITH CC/SILI 00948000 CCW 3,0,X'20',1 NOP 00949000 EJECT 00950000 * CPCOMM OPTION. PASS THE TEXT TO CP TO EXECUTE AS A COMMAND. 00951000 DCP EQU * 00952000 LA R1,=CL16'CONWAIT CON1' POINT TO A PLIST @VA09080 00952300 L R15,=V(DMSCWT) GET ADDRESS OF CONWAIT ROUTINE @VA09080 00952600 BAL RR,NUCCALL AND CALL CONWAIT TO DRAIN I/O @VA09080 00952900 L R1,ERTPLA GET ADDRESS OF MESSAGE TEXT 00953000 L R0,ERTPLL GET LENGTH OF MESSAGE TEXT 00954000 DC X'83100008' DIAGNOSE IT TO CP 00955000 ST R0,ERSAVE+4*R15 SAVE ERROR CODE FOR OUR RETURN 00956000 B DNO GO FINISH UP 00957000 EJECT 00958000 * COME HERE ON 'NONE' DISPOSITION, AND ALSO TO FINISH UP. 00959000 * WE MUST RETURN TO CALLER, EITHER BY A NORMAL RETURN, OR BY 00960000 * LOADING A DISABLED WAIT STATE PSW. 00961000 DNO EQU * 00962000 TM ERPF2,ERF2DI WAS DIE=YES SPECIFIED? 00963000 BO DIE GO DIE IF SO 00964000 LM R0,R15,ERSAVE RESTORE REGISTERS 00965000 BR R14 AND RETURN TO CALLER 00966000 EJECT 00967000 * SUBROUTINE TO CALL A NUCLEUS ROUTINE, IF THE VCON TO IT WAS 00968000 * RESOLVED. IF IT WAS NOT RESOLVED, THEN SVC 202 IS CALLED. 00969000 * WE ASSUME R1 POINTS TO THE PLIST. 00970000 NUCCALL EQU * 00971000 ST RR,ERT1 SAVE RETURN REGISTER 00972000 LTR R15,R15 WAS VCON RESOLVED? 00973000 BZ NUCCALLS NO -- MAKE AN SVC CALL 00974000 LA R13,ERPAS13 POINT TO A SAVE AREA 00975000 BALR R14,R15 CALL ROUTINE 00976000 SPACE 00977000 * THE ROUTINE MAY HAVE CLOBBERED ALL OUR REGISTERS, WE ASSUME 00978000 * NOTHING. 00979000 BALR R15,0 RE-ESTABLISH ADDRESSABILITY 00980000 USING *,R15 00981000 L BR,=A(DMSERR) 00982000 DROP R15 00983000 L TR,=V(DMSERT) POINT TO WORK AREA 00984000 L RR,ERT1 RESTORE RETURN REG 00985000 BR RR AND RETURN TO CALLER 00986000 SPACE 00987000 NUCCALLS EQU * 00988000 SVC 202 MAKE AN SVC CALL 00989000 DC AL4(*+4) 00990000 BR RR 00991000 * COME HERE TO DIE 00992000 DIE EQU * 00993000 * IF BATCH IS RUNNING, DON'T ALLOW DISABLED WAIT STATE V0742 00994000 TM BATFLAGS,BATRUN BATCH MONITOR RUNNING? V0742 00995000 BZ NOTBAT IF NOT, FORGET THIS... V0742 00996000 TM BATFLAG2,BATSYSAB RECURSIVE SYS ABEND CHEK @VA05162 00997000 BZ BATABEND FIRST TIME, GOTO BATCH @VA05162 00998000 BAL R1,DIEDIAG POINT TO MSG LINE @VA05162 00999000 DIEMSG DC C'MSG OPERATOR CMSBATCH SYSTEM ABEND' @VA05162 01000000 DIEMSGLN EQU *-DIEMSG @VA05162 01001000 DIEDIAG LA R2,DIEMSGLN PROVIDE LENGTH OF DIE MSG @VA05162 01002000 DC X'83120008' DIAG MSG TO CP AND... @VA05162 01003000 B NOTBAT NOW DIE IN PEACE. @VA05162 01004000 BATABEND OI BATFLAG2,BATSYSAB SET RECURSION FLAG ... @VA05162 01005000 L R15,ABATABND GO TO BATCH ABEND PROC. V0742 01006000 BALR R14,R15 AND DON'T COME BACK... V0742 01007000 NOTBAT EQU * V0742 01008000 SPACE 01009000 L R15,AUSERRST ANY MACHINE THAT WANTS TO BE @V60C5BE 01010000 * RESTARTED SHOULD PUT A VCON HERE.@V60C5BE 01011000 XC AUSERRST,AUSERRST ZERO THE LOCATION TO PREVENT @V60C5BE 01012000 * RECURSIVE ABEND LOOPS @V60C5BE 01013000 LTR R15,R15 DID VM SUPPLY A RESTART ENTRY PT?@V60C5BE 01014000 BCR 7,R15 IF THERE IS ONE, GO TO IT. @V60C5BE 01015000 SPACE 01016000 * IF THE GUY DID NOT REQUEST AN SIO, THEN WE DO A CONWAIT BEFORE DYING. 01017000 IC R1,ERPF2 GET HIS 'DISP' VALUE 01018000 N R1,=AL1(0,0,0,7) GET LAST THREE BITS 01019000 CH R1,=AL2(ERF2SI) DID HE REQUEST 'SIO'? 01020000 BE DIEW YES -- GO DIE DIRECTLY 01021000 LA R1,=CL16'CONWAIT CON1' POINT TO A PLIST 01022000 L R15,=V(DMSCWT) LOAD VCON FOR CONWAIT ROUTINE 01023000 BAL RR,NUCCALL CALL CONWAIT 01024000 SPACE 01025000 * NOW, FINALLY, WE CAN DIE 01026000 DIEW EQU * 01027000 SPACE 01028000 * WE MUST DECIDE WHETHER WE WERE CALLED BY SVC OR BALR CALL. 01029000 L XR,CURRSAVE GET ADDRESS OF SYSTEM SAVE AREA 01030000 LTR XR,XR IS THERE ANY? 01031000 BZ DIEBALR NO -> WE WERE CALLED BY BALR 01032000 USING SSAVE,XR 01033000 SPACE 01034000 * WE ARE NOW POINTING TO THE CURRENT SYSTEM SAVE AREA. WE CHECK TO 01035000 * SEE IF THE CALLEE NAME IS DMSERR OR LINEDIT. 01036000 CLC CALLEE,=CL8'DMSERR' IS THE CALLEE DMSERR? 01037000 BE DIESVC SVC CALL IF SO 01038000 CLC CALLEE,=CL8'LINEDIT' IS THE CALLED LINEDIT? 01039000 BNE DIEBALR BALR CALL IF NOT 01040000 SPACE 01041000 * FOR SVC CALLS, WE SIMPLE DISABLE THE SVC OLD PSW, AND SET THE 01042000 * WAIT STATE BIT ON. 01043000 DIESVC EQU * 01044000 MVI OLDPSW,0 TURN OFF THE SYSTEM MASK 01045000 OI OLDPSW+1,X'02' TURN ON WAIT STATE BIT 01046000 LM R0,R15,ERSAVE RESTORE REGS 01047000 BR R14 RETURN TO SVC HANDLER 01048000 SPACE 01049000 * FOR BALR CALLS, WE CREATE OUR OWN DISABLED WAIT STATE PSW AND LOAD 01050000 * IT. 01051000 DIEBALR EQU * 01052000 SPACE 01053000 ERMPSW EQU X'30' CONSTRUCTION AREA FOR PSW 01054000 MVC ERMPSW(4),=X'00020000' SET DISABLED WAIT STATE 01055000 LM R0,R15,ERSAVE RESTORE REGISTERS 01056000 ST R14,ERMPSW+4 SET ADDR IN PSW 01057000 LPSW ERMPSW DIE 01058000 LTORG 01059000 EJECT 01060000 DMSERT 01061000 NUCON 01062000 SVCSAVE 01063000 END 01064000