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