PRGM SSDEBUG; # TITLE SSDEBUG - INITIALIZES *SSDEBUG* UTILITY. # BEGIN # SSDEBUG # # *** SSDEBUG - INITIALIZES *SSDEBUG* UTILITY. * * THIS PRGM INITIALIZES *SSDEBUG* UTILITY BY * CRACKING THE CONTROL CARD AND CHECKING THE * SYNTAX OF THE PARAMETERS. * * SSDEBUG,I,L=REPORT. * * PRGM SSDEBUG. * * ENTRY. INPUTS TO SSDEBUG ARE - * * CM CARTRIDGE MANUFACTURER CODE IS *A *, * INDICATING *IBM *. * * CM = A CARTRIDGE MANUFACTURE CODE IS *A *, * INDICATING *IBM *. * * CM OMITTED CARTRIDGE MANUFACTURER CODE IS *A *, * INDICATING *IBM *. * * CM = ANYTHING ELSE IS CURRENTLY ILLEGAL. * * CN NOT PERMITTED. * * CN = CSN DIGIT PORTION OF CARTRIDGE SERIAL NUMBER * IS *CSN*. * * CN OMITTED FOR OP=RS, ONE AND ONE OF THE FOLLOWING * MUST BE SPECIFIED: *YI* OR *CN*. * FOR OP=CF, ONE AND ONLY ONE OF THE FOLLOWING * MUST BE SPECIFIED: *FO*, *YI*, OR *CN*. * * I SOURCE OF DIRECTIVES IS ON FILE * *INPUT*. * I = LFN SOURCE OF DIRECTIVES IS ON FILE * *LFN*. * I OMITTED SOURCE OF DIRECTIVES IS ON FILE * *INPUT*. * * Z SOURCE OF DIRECTIVES IS ON THE * CONTROL CARD. * * L LISTABLE OUTPUT ON FILE *OUTPUT*. * L = LFN LISTABLE OUTPUT ON FILE *LFN*. * L = 0 NO OUTPUT FILE GENERATED. * L OMITTED SAME AS *L*. * * *SSDEBUG* DIRECTIVE OPTIONS ARE- * OP NOT PERMITTED. * OP = XX WHERE *XX* IS THE DIRECTIVE TO BE PROCESSED. * *XX* MAY BE ONE OF THE FOLLOWING. * *RS*--READ SELECTED RAW AU. * *RF*--READ SELECTED RAW FILES. * *RP*--RELEASE SPACE FOR PROBLEM CHAINS. * *RL*--REMOVE FCT ENTRY NOT LINKED PROPERLY * TO THE SMMAP. * *RC*--REMOVE SMMAP ENTRY WHERE THERE IS NO * CORRESPONDING FCT ENTRY. * *CF*--CHANGE FLAG IN SFMCAT OR SMMAP. * OP OMITTED NOT PERMITTED. * * PF USE PERMANENT FILE NAME *MMMMBUG* FOR * RAW MSF IMAGE. * PF = PFN USE PERMANENT FILE NAME *PFN* FOR RAW * MSF IMAGE. * PF OMITTED SAME AS *PF*. * *NOTE* - *PF* IS ONLY USED WITH OP=RS * OR OP=RF. THE PERMANENT FILE-S FAMILY * AND USER INDEX WILL BE TAKEN FROM THE * USER-S CURRENT PERMANENT FILE PARAMETERS. * * FO NOT PERMITTED. * FO = N *FCT* ORDINAL. * FO OMITTED MUST BE SPECIFIED FOR OP=RF, OP=RP, AND * OP=RL. * FOR OP=CF, ONE AND ONLY ONE OF THE FOLLOWING * MUST BE SPECIFIED: *FO* , *YI* , OR *CN*. * * ST NOT PERMITTED. * ST = N AU NUMBER. FOR OP=RF AND OP=RP, *N* IS * THE STARTING AU OF A FILE OR FRAGMENT. * FOR OP=CF, *N* IS THE AU NUMBER OF AN * *FCT* FLAG TO BE CHANGED, AND TAKES PRIORITY * OVER THE RANGE OF AU INDICATED BY THE * *SL* AND *SU* PARAMETERS. AU NUMBERS * ARE MEANINGFUL WITH OP=CF ONLY FOR AU * DETAIL FLAGS (FL=SF, FL=FC, OR FL=SC). * ST OMITTED MUST BE SPECIFIED FOR OP=RF AND OP=RP. * FOR OP=CF, VALUES OF *SL* AND *SU* ARE USED. * * FM USE DEFAULT FAMILY. * FM = FAM PROCESS THE FAMILY *FAM*. * FM OMITTED SAME AS *FM*. * * SB NOT PERMITTED. * SB = SUB SELECT A SUBFAMILY *SUB*. * SB OMITTED NOT PERMITTED. * * SM USE A * SM = N USE SM *N* WHERE *N* IS A LETTER FROM * A TO H. * SM OMITTED SAME AS *SM*. * * SL COPY, OR CHANGE FLAGS FOR, AU 1 * THROUGH *SU* (FROM THE *SU* PARAMETER). * SL = Z COPY, OR CHANGE FLAGS FOR, AU *Z* * THROUGH *SU* (FROM THE *SU* PARAMETER). * SL OMITTED SAME AS *SL*. * * SU COPY, OR CHANGE FLAGS FOR, AU *SL* * (FROM THE *SL* PARAMETER) THROUGH 1. * SU = J COPY, OR CHANGE FLAGS FOR, AU *SL* * (FROM THE *SL* PARAMETER) THROUGH *J*. * SU OMITTED SAME AS *SU*. * *NOTE* - *SL* AND *SU* MUST BE IN * THE RANGE 1 THROUGH 1931. *SL* MUST BE * LESS THAN OR EQUAL TO *SU*. * FOR OP=CF, IF *ST* IS SPECIFIED, THEN * *SL* AND *SU* ARE NOT USED. * * FL NOT PERMITTED. * FL = XX SET OR CLEAR FLAG *XX* IN SMMAP OR MSF * CATALOG (VALID ONLY FOR OP=CF). *XX* MUST * BE ONE OF THE FOLLOWING - * *ME* - LINKAGE ERROR FLAG (IN SMMAP). * *FE* - LINKAGE ERROR FLAG (IN MSF CATALOG * *FCT*). * *IB* - INHIBIT ALLOCATION FLAG. * *LC* - LOST CARTRIDGE FLAG. * *EW* - EXCESSIVE WRITE PARITY ERROR FLAG. * *SF* - START OF FRAGMENT FLAG. * *FC* - FROZEN CHAIN FLAG. * *AC* - AU CONFLICT FLAG. * FL OMITTED *FL* MUST BE SPECIFIED FOR OP=CF. * * ON FLAG SPECIFIED BY *FL* IS TO BE SET * (VALID ONLY FOR OP=CF). * OF FLAG SPECIFIED BY *FL* IS TO BE CLEARED * (VALID ONLY FOR OP=CF). * * YI NOT PERMITTED. * YI = N USE *N* AS THE Y COORDINATE WHERE * *N* IS FROM 0 TO 21. * *NOTE* - THERE ARE NO CUBES ON THE * COLUMN Z=6. * *ZI* MUST BE SPECIFIED WHEN *YI*=N * IS USED. * YI OMITTED FOR OP=RS, ONE AND ONLY ONE OF THE FOLLOWING * MUST BE SPECIFIED: *YI* OR *CN*. * FOR OP=CF, ONE AND ONLY ONE OF THE FOLLOWING * MUST BE SPECIFIED: *FO*, *YI*, OR *CN*. * *YI* AND *ZI* ARE REQUIRED FOR OP=RC. * * ZI NOT PERMITTED. * ZI = N USE *N* AS THE ZI COORDINATE WHERE * *N* IS FROM 0 TO 15. * *YI* MUST BE SPECIFIED WHEN *ZI*=N * IS USED. * ZI OMITTED *ZI* MUST BE SPECIFIED IF *YI* IS USED. * *YI* AND *ZI* ARE REQUIRED FOR OP=RC. * * EXIT. *SSDEBUG* DIRECTIVES WERE PROCESSED OR AN * ERROR CONDITION WAS ENCOUNTERED. * * MESSAGES. SSDEBUG COMPLETE. * SSDEBUG - MUST BE SYSTEM ORIGIN. * UNABLE TO CONNECT WITH EXEC. * * NOTES. PRGM *SSDEBUG* INITIALIZES THE *SSDEBUG* * UTILITY. *SSDEBUG* IS A DIRECTIVE * ORIENTED UTILITY. THE DIRECTIVES CAN * BE SPECIFIED ON THE CONTROL CARD OR VIA * A FILE. THE CONTROL CARD IS CRACKED AND * THE DIRECTIVES ARE READ INTO A BUFFER. * PROC *DBLOOP* IS CALLED TO CRACK AND * SYNTAX CHECK EACH DIRECTIVE. THE CRACKED * DIRECTIVES ARE WRITTEN TO A SCRATCH FILE. * ANY ERROR IN THE DIRECTIVES CAUSES *SSDEBUG* * TO ABORT. IF THERE ARE NO ERRORS IN THE * DIRECTIVES, A CONNECT IS SET UP WITH EXEC. * PROC *DBMAIN* IS CALLED TO PROCESS EACH * DIRECTIVE. A DISCONNECT IS DONE WITH EXEC * AFTER ALL THE DIRECTIVES HAVE BEEN PROCESSED * SUCCESSFULLY. # # **** PRGM SSDEBUG - XREF LIST BEGIN. # XREF BEGIN PROC ABORT; # CALLS *ABORT* MACRO # PROC BZFILL; # BLANK/ZERO FILLS A BUFFER # PROC DBCALL1; # ISSUES TYPE 1 REQUESTS TO EXEC # PROC DBERR; # ERROR PROCESSOR # PROC DBHEAD; # WRITES HEADER LINE # PROC DBLOOP; # CRACKS AND SYNTAX CHECKS DIRECTIVES # PROC DBMAIN; # PROCESSES EACH DIRECTIVE # PROC DBTAB; # SETS UP ARGUMENT LIST # PROC GETFAM; # GETS DEFAULT FAMILY AND SUB SYSTEM ID # PROC GETPFP; # GET USER-S FAMILY AND UI # PROC GETSPS; # GET SYSTEM ORIGIN STATUS # PROC MESSAGE; # DISPLAYS MESSAGES # PROC READ; # READS A FILE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC RPCLOSE; # CLOSES REPORT FILE # PROC RPLINE; # WRITES A REPORT LINE # PROC RPOPEN; # OPENS REPORT FILE # PROC RPSPACE; # WRITES A BLANK LINE # PROC XARG; # CRACK PARAMETER LIST # PROC XZAP; # *Z* ARGUMENT PROCESSOR # PROC ZSETFET; # INITIALIZES A FET # END # **** PRGM SSDEBUG - XREF LIST END. # DEF RSLEN #1#; # RETURN STATUS WORD LENGTH # DEF LISTCON #0#; # DO NOT LIST COMDECKS # CONTROL PRESET; *CALL COMBFAS *CALL COMBBZF *CALL COMBCMD *CALL COMBCPR *CALL COMBPFP *CALL COMBUCR *CALL COMSPFM *CALL COMTDBG *CALL COMTDBP *CALL COMTDER *CALL COMTFMT *CALL COMTOUT ITEM ARGLIST U; # FWA OF ARGUMENT TABLE # ITEM BUFP U; # FWA OF *CIO* BUFFER # ITEM DEFORD I; # DEFAULT FAMILY ORDINAL # ITEM ERRFLAG B; # ERROR FLAG # ITEM FETP U; # FWA OF FET # ITEM FLAG I; # ERROR FLAG # ITEM LFN C(7); # FILE NAME # ITEM LNKORD I; # LINKED FAMILY ORDINAL # ITEM NUM I; # NUMBER OF FAMILIES # ITEM RESPCODE U; # RESPONSE CODE FROM EXEC # ARRAY CALL$SS [0:0] P(CPRLEN);; # CALLSS REQUEST BLOCK # ARRAY OUTFET [0:0] S(SFETL);; # FET FOR OUTPUT FILE # BASED ARRAY RA [0:0];; # TO ACCESS CONTROL CARD AREA # ARRAY SPSSTAT [0:0] S(RSLEN); BEGIN ITEM SPS$STATUS U(00,48,12); # RETURN STATUS # END CONTROL EJECT; GETSPS(SPSSTAT); # GET SYSTEM ORIGIN STATUS # IF SPS$STATUS NQ 0 THEN BEGIN DBMSG$LN[0] = " SSDEBUG - MUST BE SYSTEM ORIGIN."; MESSAGE(DBMSG[0],SYSUDF1); ABORT; END DBREQID = REQNAME"RQIDBUG"; # SET REQUESTOR ID # # * SAVE THE USER-S PERMANENT FILE PARAMETERS. # GETPFP(PFP[0]); USER$FAM[0] = PFP$FAM[0]; USER$UI[0] = PFP$UI[0]; USER$PACK[0] = PFP$PACK[0]; # * CRACK THE CONTROL CARD. # DBTAB(ARGLIST); # SET UP ARGUMENT TABLE # XARG(ARGLIST,0,FLAG); IF FLAG NQ OK THEN # PROCESS SYNTAX ERROR # BEGIN DBERRCODE = S"DSYNT$CRD"; OUT$FETP = 0; DBERR(DBERRCODE); END # * READ THE DIRECTIVES. # FETP = LOC(DB$FET[0]); BUFP = LOC(DB$CBUF[0]); LFN = DBARG$I[0]; ZSETFET(FETP,LFN,BUFP,DBUFL,SFETL); IF DBARG$Z[0] NQ 0 THEN # *Z* OPTION SPECIFIED # BEGIN XZAP(DB$FET[0]); END ELSE BEGIN READ(DB$FET[0],RCL); # READ DIRECTIVE FILE # END # * SET UP THE OUTPUT FILE. # IF DBARG$WL[0] EQ 0 THEN # NO OUTPUT FILE SPECIFIED # BEGIN OUT$FETP = 0; END ELSE # OUTPUT FILE IS SPECIFIED # BEGIN OUT$FETP = LOC(OUTFET[0]); END RPOPEN(DBARG$L[0],OUT$FETP,DBHEAD); # OPEN OUTPUT FILE # # * WRITE THE CONTROL CARD IMAGE TO THE OUTPUT FILE. # P= 0; BZFILL(RA[O"70"],TYPFILL"BFILL",80); RPLINE(OUT$FETP,RA[O"70"],2,80,0); RPSPACE(OUT$FETP,SP"SPACE",1); # * CRACK AND SYNTAX CHECK THE DIRECTIVES. # DBLOOP(ARGLIST,ERRFLAG); IF ERRFLAG THEN # SYNTAX ERROR IN DIRECTIVES # BEGIN DBERRCODE = S"DSYNT$CRD"; DBERR(DBERRCODE); END # * GET THE DEFAULT FAMILY AND SUBSYSTEM ID. # DBSSID = ATAS; GETFAM(FAMT,NUM,LNKORD,DEFORD,DBSSID); DEF$FAM = FAM$NAME[DEFORD]; # * CONNECT TO EXEC. # P = LOC(CALL$SS[0]); DBCALL1(REQTYP1"CONNECT",RESPCODE); IF RESPCODE NQ OK THEN BEGIN DBMSG$LN[0] = " UNABLE TO CONNECT WITH EXEC."; MESSAGE(DBMSG[0],SYSUDF1); RPCLOSE(OUT$FETP); # CLOSE OUTPUT FILE # RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END # * PROCESS EACH DIRECTIVE. # DBMAIN; # * DISCONNECT FROM EXEC. # DBCALL1(REQTYP1"DISCONNECT",RESPCODE); RPCLOSE(OUT$FETP); DBMSG$LN[0] = " SSDEBUG COMPLETE."; # END WITH DAYFILE MESSAGE # MESSAGE(DBMSG[0],UDFL1); RESTPFP(PFP$END); # RESTORE USER-S *PFP* # END # SSDEBUG # TERM PROC DBCALL1((REQCODE),RESPCODE); # TITLE DBCALL1 - ISSUES A TYPE 1 UCP CALL TO EXEC. # BEGIN # DBCALL1 # # ** DBCALL1 - ISSUES A TYPE 1 UCP CALL TO EXEC. * * PROC DBCALL1((REQCODE),RESPCODE) * * ENTRY (REQCODE) = REQUEST CODE. * (DBREQID) = REQUESTOR ID. * (DBSSID) = SUBSYSTEM ID. * P = FWA OF CALLSS PARAMETER BLOCK. * * EXIT (RESPCODE) = RESPONSE FROM EXEC. * * NOTES THE CALLSS PARAMETER BLOCK IS SET UP FOR * A TYPE 1 REQUEST AND THE REQUEST IS ISSUED * TO EXEC. TYPE 1 REQUESTS ARE THE UCP * LINKAGE REQUESTS, CONNECT AND DISCONNECT. # ITEM REQCODE I; # REQUEST CODE # ITEM RESPCODE I; # RESPONSE FROM EXEC # # **** PROC DBCALL1 - XREF LIST BEGIN. # XREF BEGIN PROC CALLSS; # ISSUES A UCP/SCP REQUEST # END # **** PRDC DBCALL1 - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMTDBG ITEM I I; # LOOP INDUCTION VARIABLE # CONTROL EJECT; # * SET UP THE PARAMETER BLOCK. # FASTFOR I = 0 STEP 1 UNTIL CPRLEN-1 DO BEGIN CPR1[I] = 0; # ZERO FILL PARAMETER BLOCK # END CPR$RQT[0] = TYP"TYP1"; CPR$RQC[0] = REQCODE; CPR$RQI[0] = DBREQID; CPR$SSPFLG[0] = TRUE; CPR$WC[0] = TYP1$WC; # * ISSUE THE CALL. # CALLSS(DBSSID,CPR[0],RCL); RESPCODE = CPR$ES[0]; RETURN; END # DBCALL1 # TERM PROC DBCALL3((REQCODE),MAPENT,(FCTORD),(CATFLD),(CATVALUE),RESPCODE); # TITLE DBCALL3 - ISSUES TYPE 3 UCP CALL TO EXEC. # BEGIN # DBCALL3 # # ** DBCALL3 - ISSUES TYPE 3 UCP CALL TO EXEC. * * PROC DBCALL3((REQCODE),MAPENT,(FCTORD),(CATFLD),(CATVALUE), * RESPCODE) * * ENTRY (REQCODE) = REQUEST CODE. * (MAPENT) = UPDATED SMMAP ENTRY. * (FCTORD) = *FCT* ORDINAL. * (CATFLD) = CATALOG FIELD TO BE UPDATED. * (CATVALUE) = NEW VALUE FOR UPDATED CATALOG FIELD. * (DBREQID) = REQUESTOR ID. * (DBSSID) = SUBSYSTEM ID. * (DBARG$FM) = FAMILY NAME. * (DBARG$SB) = SUBFAMILY IDENTIFIER. * (DBARG$SMID) = SM IDENTIFIER. * (DBARG$Y) = Y COORDINATE. * (DBARG$Z) = Z COORDINATE. * (DBARG$ST) = STARTING AU NUMBER. * P = FWA OF CALLSS PARAMETER BLOCK. * * EXIT (RESPCODE) = RESPONSE FROM EXEC. * * MESSAGES SSDEBUG ABNORMAL, DBCALL3. * NOTES THE PARAMETER BLOCK IS SET UP FOR A TYPE 3 * REQUEST AND THE REQUEST IS ISSUED TO EXEC. * TYPE 3 REQUESTS ARE THE REQUESTS TO MODIFY * MSF CATALOGS AND MAPS. THE SPECIFIC REQUEST * ISSUED DEPENDS ON THE REQUEST CODE. PARAMETERS * NOT NEEDED FOR THE REQUEST ARE IGNORED. THE * RESPONSE CODE FROM EXEC IS RETURNED TO THE * CALLING PROC. # ITEM REQCODE I; # REQUEST CODE # ARRAY MAPENT [0:0] P(3); # SMMAP ENTRY # BEGIN ITEM MAPENTRY C(00,00,30); # 3 WORD SMMAP ENTRY # END ITEM FCTORD I; # *FCT* ORDINAL # ITEM CATFLD I; # CATALOG FIELD TO BE UPDATED # ITEM CATVALUE I; # CATALOG VALUE FOR UPDATE # ITEM RESPCODE I; # RESPONSE FROM EXEC # # **** PROC DBCALL3 - XREF LIST BEGIN. # XREF BEGIN PROC CALLSS; # ISSUES A UCP/SCP REQUEST # PROC MESSAGE; # DISPLAYS MESSAGES # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # END # **** PROC DBCALL3 - XREF LIST END. # DEF PROCNAME #"DBCALL3."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMTDBG *CALL COMTDBP ITEM COMPLETE B; # COMPLETION STATUS # ITEM I I; # LOOP INDUCTION VARIABLE # SWITCH CALL3ACT: REQTYP3 # TYPE 3 REQUESTS # UPDCAT: UPD$CAT, # UPDATE CATALOG FIELD # UPDMAP: UPD$MAP, # UPDATE SMMAP ENTRY # PURGFRAG: PURG$FRAG, # PURGE FRAGMENT # PURGFCT: PURG$FCT; # PURGE *FCT* ENTRY # CONTROL EJECT; # * CHECK FOR A VALID REQUEST CODE. # IF REQCODE LS REQTYP3"UPD$CAT" OR REQCODE GR REQTYP3"PURG$FCT" ## OR REQCODE EQ REQTYP3"REL$SETUP" THEN # ILLEGAL REQUEST CODE # BEGIN DBMSG$PROC[0] = PROCNAME; MESSAGE(DBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END # * SET UP THE FIELDS COMMON TO ALL THE REQUESTS. # FASTFOR I = 0 STEP 1 UNTIL CPRLEN-1 DO BEGIN CPR1[I] = 0; # ZERO FILL PARAMETER BLOCK # END CPR$RQT[0] = TYP"TYP3"; CPR$RQC[0] = REQCODE; CPR$RQI[0] = DBREQID; CPR$FAM[0] = DBARG$FM[0]; CPR$SUB[0] = DBARG$SB[0]; CPR$CSU[0] = DBARG$SMID[0]; CPR$WC[0] = TYP3$WC; # * SET UP THE FIELDS NEEDED FOR SPECIFIC REQUESTS. # GOTO CALL3ACT[REQCODE]; UPDCAT: # UPDATE CATALOG ENTRY # CPR$FCT[0] = FCTORD; CPR$AU[0] = DBARG$ST[0]; CPR$FLD[0] = CATFLD; CPR$VAL[0] = CATVALUE; GOTO ISSUECALL; UPDMAP: # UPDATE SMMAP ENTRY # CPR$Y[0] = DBARG$YI[0]; CPR$Z[0] = DBARG$ZI[0]; CPR$MAPENT[0] = MAPENTRY[0]; GOTO ISSUECALL; PURGFRAG: # PURGE FRAGMENT # CPR$FCT[0] = FCTORD; CPR$AU[0] = DBARG$ST[0]; GOTO ISSUECALL; PURGFCT: # PURGE *FCT* ENTRY # CPR$FCT[0] = FCTORD; GOTO ISSUECALL; ISSUECALL: # ISSUE REQUEST TO EXEC # COMPLETE = FALSE; REPEAT WHILE NOT COMPLETE DO BEGIN CALLSS(DBSSID,CPR[0],RCL); IF CPR$RQR[0] NQ RESPTYP3"RESUB$REQ" THEN # REQUEST COMPLETE # BEGIN COMPLETE = TRUE; TEST DUMMY; END CPR$RQR[0] = 0; # RESUBMIT THE REQUEST # CPR$C[0] = FALSE; END RESPCODE = CPR$RQR[0]; RETURN; END # DBCALL3 # TERM PROC DBCALL4((REQCODE),(Y),(Z),(SL),(SH),(FAMLY),(UI),RESPCODE); # TITLE DBCALL4 - ISSUES A TYPE 4 UCP REQUEST TO EXEC. # BEGIN # DBCALL4 # # ** DBCALL4 - ISSUES A TYPE 4 UCP REQUEST TO EXEC. * * PROC DBCALL4((REQCODE),(Y),(Z),(STRM),(FAMLY),(UI),RESPCODE) * * ENTRY (REQCODE) = REQUEST CODE. * (Y) = Y COORDINATE. * (Z) = Z COORDINATE. * (SL) = STRIPE LOW. * (SH) = STRIPE HIGH. * (FAMLY) = USER-S FAMILY NAME. * (UI) = USER INDEX. * (DBREQID) = REQUESTOR ID. * (TRNSPORT) = TRANSPORT ID. * (ADDRSENSE) = FWA OF BUFFER TO HOLD SENSE BYTES. * (DBARG$SMID) = SM ID. * (DBARG$PF) = FILE NAME TO WHICH DATA IS WRITTEN. * P = FWA OF PARAMETER BLOCK. * * EXIT (RESPCODE) = RESPONSE FROM EXEC. * (CPR$DRD) = TRANSPORT ID (ONLY FOR LOAD CARTRIDGE * REQUEST). * (ADDRSENSE) = FWA OF BUFFER CONTAINING SENSE BYTES * (ONLY FOR GET DRAWER STATUS REQUEST). * * MESSAGES SSDEBUG ABNORMAL, DBCALL4. * * NOTES THE PARAMETER BLOCK IS SET UP FOR A TYPE 4 * UCP REQUEST AND THE REQUEST IS ISSUED TO EXEC. * TYPE 4 REQUESTS ARE THE REQUESTS THAT REQUIRE * SM OR MST ACTIONS PERFORMED. PARAMETERS NOT * NEEDED FOR THE REQUEST ARE IGNORED. THE RESPONSE * CODE FROM EXEC IS RETURNED TO THE CALLING PROC. # ITEM REQCODE I; # REQUEST CODE # ITEM Y I; # Y COORDINATE # ITEM Z I; # Z COORDINATE # ITEM SL I; # STRIPE LOW # ITEM SH I; # STRIPE HIGH # ITEM FAMLY C(7); # USER-S FAMILY NAME # ITEM UI U; # USER INDEX # ITEM RESPCODE I; # RESPONSE CODE FROM EXEC # # **** PROC DBCALL4 - XREF LIST BEGIN. # XREF BEGIN PROC CALLSS; # ISSUES A UCP/SCP REQUEST # PROC MESSAGE; # DISPLAYS MESSAGES # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # END # **** PROC DBCALL4 - XREF LIST END. # DEF PROCNAME #"DBCALL4."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL,COMBLBL *CALL COMTDBG *CALL COMTDBP *CALL,COMTLAB ITEM I I; # LOOP INDUCTION VARIABLE # # * ARRAY TO HOLD CARTRIDGE LABEL. # ARRAY CARTLABEL[0:0]S(LABLEN);; SWITCH CALL4ACT: REQTYP4 # TYPE 4 REQUESTS # LOADCART: LOAD$CART, # LOAD CARTRIDGE # UNLDCART: UNLD$CART, # UNLOAD CARTRIDGE # WRITELAB: WRT$LAB, # WRITE CARTRIDGE LABEL # CPRAWSTR: CP$RAW$AU; # COPY RAW AU # CONTROL EJECT; # * CHECK FOR A VALID REQUEST CODE. # IF REQCODE NQ REQTYP4"LOAD$CART" ## AND REQCODE NQ REQTYP4"UNLD$CART" ## AND REQCODE NQ REQTYP4"CP$RAW$AU" ## AND REQCODE NQ REQTYP4"WRT$LAB" THEN # ILLEGAL REQUEST CODE # BEGIN DBMSG$PROC[0] = PROCNAME; MESSAGE(DBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END # * SET UP THE FIELDS COMMON TO ALL REQUESTS. # FASTFOR I = 0 STEP 1 UNTIL CPRLEN-1 DO BEGIN CPR1[I] = 0; # ZERO FILL PARAMETER BLOCK # END CPR$RQT[0] = TYP"TYP4"; CPR$RQC[0] = REQCODE; CPR$RQI[0] = DBREQID; CPR$CSU[0] = DBARG$SMID[0]; CPR$WC[0] = TYP4$WC; # * SET UP THE FIELDS FOR SPECIFIC REQUESTS. # GOTO CALL4ACT[REQCODE]; LOADCART: # LOAD CARTRIDGE FROM Y,Z # CPR$Y[0] = Y; CPR$Z[0] = Z; CPR$ADDR2[0] = LOC(CARTLABEL[0]); GOTO ISSUECALL; UNLDCART: # UNLOAD CARTRIDGE TO Y,Z # CPR$Y[0] = Y; CPR$Z[0] = Z; CPR$DRD[0] = TRNSPORT; GOTO ISSUECALL; CPRAWSTR: # COPY RAW AU # CPR$Y[0] = Y; CPR$Z[0] = Z; CPR$DRD[0] = TRNSPORT; CPR$ST$LW = SL; CPR$ST$HI = SH; CPR$FAM[0] = FAMLY; CPR$PFN[0] = DBARG$PF[0]; CPR$UI[0] = UI; GOTO ISSUECALL; WRITELAB: CPR$Y[0] = Y; CPR$Z[0] = Z; CPR$ADDR2[0] = LOC(CARTLABEL[0]); P = LOC(CARTLABEL[0]); LAB$CARTTP[0] = LABTYPE"SCR$LAB"; LAB$SMID[0] = " "; LAB$FMLY[0] = " "; GOTO ISSUECALL; ISSUECALL: # ISSUE REQUEST TO EXEC # CALLSS(DBSSID,CPR[0],RCL); RESPCODE = CPR$RQR[0]; RETURN; END # DBCALL4 # TERM PROC DBCMAP; # TITLE DBCMAP - REMOVE SMMAP ENTRY. # BEGIN # DBCMAP # # ** DBCMAP - REMOVE SMMAP ENTRY. * * PROC DBCMAP. * * ENTRY THE CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS * ARE SET UP IN THE COMMON AREA DEFINED IN *COMTDBP*. * THE SMMAP IS OPEN FOR THE SPECIFIED SM. * P = FWA OF CALLSS PARAMETER BLOCK. * * EXIT THE DIRECTIVE WAS PROCESSED AND MAP WAS * CLOSED OR AN ERROR CONDITION WAS DETECTED. * * MESSAGES SSDEBUG ABNORMAL, DBCMAP. * * NOTES THE SELECTED SMMAP ENTRY IS CHECKED FOR THE * ERROR FLAG. IF SET, THE CARTRIDGE FROM THAT * LOCATION IS MOVED TO THE OUTPUT DRAWER AND THE * SMMAP ENTRY IS UPDATED TO BE EMPTY AND UNASSIGNED. # # **** PROC DBCMAP - XREF LIST BEGIN. # XREF BEGIN PROC DBCALL3; # ISSUES A TYPE 3 UCP REQUEST # PROC DBCALL4; # ISSUES A TYPE 4 UCP REQUEST # PROC DBERR; # ERROR PROCESSOR # PROC DBRESP; # PROCESS RESPONSE FROM EXEC # PROC MCLOSE; # CLOSES SMMAP # PROC MESSAGE; # DISPLAYS MESSAGES # PROC MGETENT; # GET SMMAP ENTRY # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # END # **** PROC DBCMAP - XREF LIST END. # DEF PROCNAME #"DBCMAP."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMBCMS *CALL COMBMAP *CALL COMTDBG *CALL COMTDBP *CALL COMTDER *CALL COMTLAB ITEM CMAPADR I; # FWA OF MAP ENTRY # ITEM FLAG I; # ERROR STATUS # ITEM ORD I; # SMMAP ENTRY ORDINAL # ITEM RESPCODE I; # RESPONSE FROM EXEC # ITEM UNLOAD B; # UNLOAD REQUIRED FLAG # ITEM Y I; # Y COORDINATE # ITEM Z I; # Z COORDINATE # ARRAY CMAPENT [0:0] P(MAPENTL);; # SMMAP ENTRY # CONTROL EJECT; # * CHECK THE SMMAP ENTRY FOR THE ERROR FLAG. # CMAPADR = LOC(CMAPENT[0]); ORD = MAXORD - DBARG$ZI[0] - ( DBARG$YI[0]*16 ); MGETENT(DBARG$SMID[0],ORD,CMAPADR,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # ABNORMAL TERMINATION # BEGIN DBMSG$PROC[0] = PROCNAME; MESSAGE(DBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END P = CMAPADR; IF NOT CM$FLAG1[0] THEN # SMMAP ERROR FLAG NOT SET # BEGIN DBERRCODE = S"DMAP$NSET"; DBERR(DBERRCODE); RETURN; END # * UPDATE THE SMMAP ENTRY TO BE EMPTY AND UNASSIGNED. # UNLOAD = CM$CSND[0] NQ ""; # SET FLAG IF UNLOAD REQUIRED # CM$CODE[0] = CUBSTAT"UNASGN"; CM$TCSN[0] = " "; CM$FMLYNM[0] = " "; CM$SUB[0] = 0; CM$FCTORD[0] = 0; CM$FLAG1[0] = FALSE; DBCALL3(REQTYP3"UPD$MAP",CMAPENT[0],0,0,0,RESPCODE); IF RESPCODE NQ RESPTYP3"OK3" THEN # UNABLE TO UPDATE ENTRY # BEGIN DBRESP(RESPCODE,TYP"TYP3"); RETURN; END MCLOSE(DBARG$SMID[0],FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # UNABLE TO CLOSE MAP # BEGIN DBRESP(FLAG,0); END # * MOVE THE CARTRIDGE TO THE OUTPUT DRAWER. # IF UNLOAD THEN BEGIN # MOVE CARTRIDGE TO OUTPUT DRAWER # DBCALL4(REQTYP4"LOAD$CART",DBARG$YI[0],DBARG$ZI[0],0,0,0,0, RESPCODE); IF RESPCODE EQ RESPTYP4"CELL$EMP" THEN # EMPTY CUBE # BEGIN DBERRCODE = S"DEMPTYCUBE"; DBERR(DBERRCODE); # ISSUE INFORMATIVE MESSAGE # RETURN; END IF RESPCODE NQ RESPTYP4"OK4" THEN # OTHER ERROR ON LOAD # BEGIN DBRESP(RESPCODE,TYP"TYP4"); RETURN; END TRNSPORT = CPR$DRD[0]; # SET UP TRANSPORT ID # Z = 0; Y = SM$EXIT$TY; # SET EXIT TRAY # DBCALL4(REQTYP4"WRT$LAB",Y,Z,0,0,0,0,RESPCODE); IF RESPCODE NQ RESPTYP4"OK4" THEN # *CHANGE* FAILS # BEGIN DBRESP(RESPCODE,TYP"TYP4"); RETURN; END END # MOVE CARTRIDGE TO OUTPUT DRAWER # RETURN; END # DBCMAP # TERM PROC DBCONV(FLAG); # TITLE DBCONV - CONVERTS CRACKED PARAMETERS TO INTEGERS. # BEGIN # DBCONV # # ** DBCONV - CONVERTS CRACKED PARAMETERS TO INTEGERS. * * PROC DBCONV(FLAG) * * ENTRY THE CRACKED PARAMETERS ARE SET UP IN THE COMMON AREA * DEFINED IN *COMTDBP*. * * EXIT THE CRACKED PARAMETERS ARE CONVERTED OR REPLACED * BY DEFAULT VALUES AND PLACED BACK IN THE SAME * COMMON AREA. * (FLAG) = 0, NO ERROR. * 1, CONVERSION ERROR. * * NOTES THE PARAMETERS ARE CONVERTED FROM DISPLAY * CODE TO INTEGER VALUES OR ARE REPLACED BY * DEFAULT VALUES. THE CONVERTED PARAMETERS * ARE PLACED BACK IN THEIR ORIGINAL LOCATIONS. # ITEM FLAG I; # ERROR FLAG # # **** PROC DBCONV - XREF LIST BEGIN. # XREF BEGIN FUNC XDXB I; # DISPLAY TO INTEGER CONVERSION # END # **** PROC DBCONV - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMTDBG *CALL COMTDBP ITEM TEMP I; # TEMPORARY ITEM # CONTROL EJECT; FLAG = 0; # INITIALIZE # # * CHECK THE VALUE OF *SB*. # IF DBARG$SB[0] EQ 0 THEN # *SB* OMITTED # BEGIN DBARG$SB[0] = -2; END ELSE BEGIN IF DBARG$SB[0] NQ -1 THEN BEGIN # CONVERT *SB* # FLAG = XDXB(DBARG$SB[0],1,TEMP); IF FLAG NQ OK THEN # CONVERSION ERROR # BEGIN RETURN; END DBARG$SB[0] = TEMP; END # CONVERT *SB* # END # * CHECK THE VALUE OF *SM*. # IF DBARG$SM[0] EQ 0 THEN BEGIN DBARG$SM[0] = "A"; # USE DEFAULT VALUE # END # * CHECK THE VALUE OF *SL*. # IF DBARG$SL[0] NQ 0 THEN BEGIN # CONVERT *SL* # FLAG = XDXB(DBARG$SL[0],1,TEMP); IF FLAG NQ OK THEN # CONVERSION ERROR # BEGIN RETURN; END DBARG$SL[0] = TEMP; END # CONVERT *SL* # ELSE # USE DEFAULT VALUE # BEGIN DBARG$SL[0] = 1; END # * CHECK THE VALUE OF *SU*. # IF DBARG$SU[0] NQ 0 THEN BEGIN # CONVERT *SU* # FLAG = XDXB(DBARG$SU[0],1,TEMP); IF FLAG NQ OK THEN # CONVERSION ERROR # BEGIN RETURN; END DBARG$SU[0] = TEMP; END # CONVERT *SU* # ELSE # USE DEFAULT VALUE # BEGIN DBARG$SU[0] = 1; END # * CHECK THE VALUE OF *D*. # IF DBARG$D[0] EQ 0 THEN # *D* OMITTED # BEGIN DBARG$D[0] = -2; END ELSE BEGIN IF DBARG$D[0] NQ -1 THEN BEGIN # CONVERT *D* # FLAG = XDXB(DBARG$D[0],1,TEMP); IF FLAG NQ OK THEN # CONVERSION ERROR # BEGIN RETURN; END DBARG$D[0] = TEMP; END # CONVERT *D* # END # * CHECK THE VALUE OF *YI*. # IF DBARG$YI[0] EQ 0 THEN # *YI* OMITTED # BEGIN DBARG$YI[0] = -1; END ELSE # *YI* SPECIFIED # BEGIN IF DBARG$YI[0] NQ O"7777" THEN BEGIN # CONVERT *YI* # FLAG = XDXB(DBARG$YI[0],1,TEMP); IF FLAG NQ OK THEN # CONVERSION ERROR # BEGIN RETURN; END DBARG$YI[0] = TEMP; END # CONVERT *YI* # END # * CHECK THE VALUE OF *ZI*. # IF DBARG$ZI[0] EQ 0 THEN # *ZI* OMITTED # BEGIN DBARG$ZI[0] = -1; END ELSE # *ZI* SPECIFIED # BEGIN IF DBARG$ZI[0] NQ O"7777" THEN BEGIN # CONVERT *ZI* # FLAG = XDXB(DBARG$ZI[0],1,TEMP); IF FLAG NQ OK THEN BEGIN RETURN; END DBARG$ZI[0] = TEMP; END # CONVERT *ZI* # END # * CHECK THE VALUE OF *PF*. # IF DBARG$WPF[0] EQ 0 THEN BEGIN DBARG$PF[0] = "MMMMBUG"; # USE DEFAULT VALUE # END # * CHECK THE VALUE OF *FO*. # IF DBARG$FO[0] EQ 0 THEN # *FO* OMITTED # BEGIN DBARG$FO[0] = -2; END ELSE # *FO* SPECIFIED # BEGIN IF DBARG$FO[0] NQ -1 THEN BEGIN # CONVERT *FO* # FLAG = XDXB(DBARG$FO[0],1,TEMP); IF FLAG NQ OK THEN # CONVERSION ERROR # BEGIN RETURN; END DBARG$FO[0] = TEMP; END # CONVERT *FO* # END # * CHECK THE VALUE OF *ST*. # IF DBARG$ST[0] EQ 0 THEN # *ST* OMITTED # BEGIN DBARG$ST[0] = -2; END ELSE # *ST* SPECIFIED # BEGIN IF DBARG$ST[0] NQ -1 THEN BEGIN # CONVERT *ST* # FLAG = XDXB(DBARG$ST[0],1,TEMP); IF FLAG NQ OK THEN # CONVERSION ERROR # BEGIN RETURN; END DBARG$ST[0] = TEMP; END # CONVERT *ST* # END RETURN; END # DBCONV # TERM PROC DBERR(ERRCODE); # TITLE DBERR - ERROR PROCESSOR. # BEGIN # DBERR # # ** DBERR - ERROR PROCESSOR. * * PROC DBERR(ERRCODE) * * ENTRY (ERRCODE) = ERROR CODE. * (OUT$FETP) = FWA OF FET FOR OUTPUT FILE. * (DBARG$PF) = PERMANENT FILE NAME. * (DBARG$DIRN) = DIRECTIVE NUMBER IN DISPLAY CODE. * * EXIT ERROR PROCESSING DONE. DEPENDING ON THE * ERROR CODE EITHER *SSDEBUG* IS TERMINATED * OR CONTROL IS RETURNED BACK TO THE CALLING * PROC. * * MESSAGES SSDEBUG ABNORMAL, DBERR. * SEE ARRAY *ERRMSG* FOR THE DAYFILE MESSAGES * PRINTED OUT. * * NOTES *DBERR* IS A TABLE DRIVEN ERROR PROCESSOR. A * TABLE HAS BEEN PRESET WITH THE ERROR MESSAGES * WHICH CORRESPOND TO THE ERROR STATUS LIST SET * UP IN *COMTDER*. THE ERROR CODE CORRESPONDS * TO THE ORDINAL OF THE CORRESPONDING ENTRY IN * THE TABLE. THE ACTION TO BE TAKEN FOR THE * ERROR CODE HAS BEEN PRESET AS STATUS VALUES * IN THE CORRESPONDING ENTRY IN THE TABLE. THE * ERROR MESSAGE IS PRINTED OUT IN THE DAYFILE * AND THE REPORT FILE. # ITEM ERRCODE I; # ERROR CODE # # **** PROC DBERR - XREF LIST BEGIN. # XREF BEGIN PROC BZFILL; # BLANK/ZERO FILL A BUFFER # PROC MESSAGE; # DISPLAYS MESSAGE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC RPCLOSE; # CLOSE OUTPUT FILE # PROC RPLINE; # PRINTS A REPORT LINE # PROC RPSPACE; # PRINTS A BLANK LINE # FUNC XCDD C(10); # CONVERTS TO DISPLAY CODE # END # **** PROC DBERR - XREF LIST END. # DEF PROCNAME #"DBERR."#; # PROC NAME # STATUS ACTION # ACTION TO BE TAKEN # MSG, # DISPLAY DAYFILE/REPORT MESSAGE # MSGDTL, # DISPLAY DETAILED MESSAGE # RETRN, # RETURN TO CALLING PROC # ABRT, # ABORT PROCESSING # LSTACT; # END OF STATUS LIST # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBBZF *CALL COMBCPR *CALL COMTDBG *CALL COMTDBP *CALL COMTDER *CALL COMTOUT ITEM DIS$ERR C(20); # ERROR CODE IN DISPLAY # ITEM FNAME C(7); # FILE NAME # ITEM I I; # LOOP INDUCTION VARIABLE # ITEM STAT I; # STATUS VALUE # # * ARRAYS FOR DISPLAZING DAYFILE MESSAGES. # ARRAY DAYMSG [0:0] P(5); # ERROR MESSAGE # BEGIN ITEM DAY$MSGTXT C(00,00,40); # MESSAGE TEXT # ITEM DAY$MSGFIL C(01,48,07); # FILE NAME # ITEM DAY$MSGTRM U(04,00,60) = [0]; # ZERO BYTE TERMINATOR # END ARRAY DIRNUM [0:0] P(2); # DIRECTIVE NUMBER # BEGIN ITEM DIR$MSG C(00,00,11) = [" DIRECTIVE "]; ITEM DIR$NO C(01,06,03); # DIRECTIVE NUMBER # ITEM DIR$PRD C(01,24,01) = ["."]; # ENDING PERIOD # ITEM DIR$TRM U(01,30,30) = [0]; # ZERO BYTE TERMINATOR # END ARRAY ERRNUM [0:0] P(3); # ERROR NUMBER # BEGIN ITEM ERR$TXT C(00,00,15) = [" SSDEBUG ERROR "]; ITEM ERR$NUM C(01,30,03); # ERROR NUMBER # ITEM ERR$PRD C(01,48,02) = [". "]; # ENDING PERIOD # ITEM ERR$TRM U(02,00,60) = [0]; # ZERO BYTE TERMINATOR # END # * ARRAY PRESET WITH THE ERROR MESSAGES AND THE STATUS * VALUES REPRESENTING THE ACTION TO BE TAKEN ON AN ERROR * CODE. # ARRAY ERRMSG [0:DBCODEMAX] S(5); BEGIN ITEM ERR$MSG C(00,00,38) = [ " SYNTAX ERROR, SSDEBUG ABORT.", " SYNTAX ERROR IN DIRECTIVE.", " ILLEGAL DIRECTIVE.", " FO NOT SPECIFIED CORRECTLY.", " ST NOT SPECIFIED CORRECTLY.", " ILLEGAL SUBFAMILY.", " ILLEGAL SM.", " ILLEGAL SL.", " ILLEGAL SU.", # CSN OPTION VIOLATED.#, # CN OR YI OPTION VIOLATED.#, # CN, FO, OR YI OPTION VIOLATED.#, " FL OPTION VIOLATED.", " ON,OF OPTION VIOLATED.", " ILLEGAL D.", " YI,ZI OPTION VIOLATED.", " CUBE EMPTY - SMMAP ENTRY REMOVED.", " UNABLE TO DEFINE .", " ATTACH ERROR ON .", # CSN NOT FOUND.#, # CSN OR Y-Z NOT IN SUBFAMILY.#, " NON FROZEN FRAGMENT.", " FROZEN CHAIN.", " SMMAP ERROR FLAG NOT SET IN FCT.", " ERROR FLAG NOT SET IN SMMAP.", " CATALOG/MAP INTERLOCKED.", " PERMANENT FILE PROBLEM.", " NO SUCH SUBCATALOG.", " FCT ORDINAL OUT OF RANGE.", " CATALOG/MAP NOT OPEN.", " CARTRIDGE NOT FOUND.", " MSF SYSTEM ERROR.", " MSF HARDWARE PROBLEM.", " DISK FILE ERROR.", " ONLY PART OF CARTRIDGE LABEL MATCHED.", " CARTRIDGE IN USE.", " SPECIFIED CELL EMPTY.", " NO CARTRIDGE LABEL MATCH.", " UNRECOVERABLE READ ERROR.", " VOLUME HEADER ERROR.", " DISK FULL.", " STORAGE MODULE OFF."] ; ITEM ERR$MTRM U(03,48,12) = [0,DBCODEMAX(0)]; # ZERO BYTE TERMINATOR # ITEM ERR$STATW U(04,00,60); # ACTION TO BE TAKEN # # * STATUS VALUES REPRESENTING TYPE OF MESSAGE TO * BE PRINTED. # ITEM ERR$STAT1 S: ACTION (04,00,06) = [ 17(S"MSG"), 2(S"MSGDTL"), 23(S"MSG")]; # * STATUS VALUES REPRESENTING TYPE OF ACTION TO BE * TAKEN AFTER PRINTING THE MESSAGE. # ITEM ERR$STAT2 S: ACTION (04,06,06) = [ S"ABRT", 16(S"RETRN"), 25(S"ABRT")]; END CONTROL EJECT; # * CHECK FOR A LEGAL ERRCODE. # IF ERRCODE LS 0 OR ERRCODE GR DBCODEMAX THEN # ILLEGAL ERROR CODE # BEGIN DBMSG$PROC[0] = PROCNAME; MESSAGE(DBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END # * SET UP THE DIRECTIVE NUMBER AND ERROR CODE * FOR DISPLAY. # DIR$NO[0] = DBARG$DIRN[0]; DIS$ERR = XCDD(ERRCODE); ERR$NUM = C<7,3>DIS$ERR; # * DO THE CORRESPONDING PROCESSING FOR THE * ERROR CODE. # IF ERRCODE NQ DERRLIST"DSYNT$CRD" THEN BEGIN # DISPLAY MESSAGE HEADER # IF ERR$STAT2[ERRCODE] EQ S"ABRT" THEN # SEND MESSAGE TO SYSTEM DAYFILE # BEGIN MESSAGE(ERRNUM[0],SYSUDF1); MESSAGE(DIRNUM[0],SYSUDF1); END ELSE # SEND MESSAGE TO USER DAYFILE # BEGIN MESSAGE(ERRNUM[0],UDFL1); MESSAGE(DIRNUM[0],UDFL1); END RPLINE(OUT$FETP,"*** ERROR",4,9,1); RPLINE(OUT$FETP,ERR$NUM[0],14,3,0); RPLINE(OUT$FETP,"DIRECTIVE",8,9,1); RPLINE(OUT$FETP,DIR$NO[0],18,3,0); END # DISPLAY MESSAGE HEADER # # * DISPLAY ERROR MESSAGE. # IF ERR$STAT1[ERRCODE] EQ S"MSG" THEN BEGIN # DISPLAY ERROR MESSAGE # IF ERR$STAT2[ERRCODE] EQ S"ABRT" THEN # SEND MESSAGE TO SYSTEM DAYFILE # BEGIN MESSAGE(ERRMSG[ERRCODE],SYSUDF1); END ELSE # SEND MESSAGE TO USER DAYFILE # BEGIN MESSAGE(ERRMSG[ERRCODE],UDFL1); END RPLINE(OUT$FETP,ERR$MSG[ERRCODE],7,38,0); END ELSE BEGIN # DISPLAY DETAILED MESSAGE # DAY$MSGTXT[0] = ERR$MSG[ERRCODE]; FNAME = DBARG$PF[0]; BZFILL(FNAME,TYPFILL"BFILL",7); DAY$MSGFIL[0] = FNAME; IF ERR$STAT2[ERRCODE] EQ S"ABRT" THEN # SEND MESSAGE TO SYSTEM DAYFILE # BEGIN MESSAGE(DAYMSG[0],SYSUDF1); END ELSE # SEND MESSAGE TO USER DAYFILE # BEGIN MESSAGE(DAYMSG[0],UDFL1); END RPLINE(OUT$FETP,DAY$MSGTXT[0],7,40,0); END # DISPLAY DETAILED MESSAGE # RPSPACE(OUT$FETP,SP"SPACE",1); # * ABORT OR RETURN. # IF ERR$STAT2[ERRCODE] EQ S"ABRT" THEN BEGIN RPCLOSE(OUT$FETP); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END RETURN; END # DBERR # TERM PROC DBFLAG; # TITLE DBFLAG - SET OR CLEAR SPECIFIED FLAGS. # BEGIN # DBFLAG # # ** DBFLAG - SET OR CLEAR SPECIFIED FLAGS. * * *DBFLAG* CHANGES SPECIFIED FLAGS IN SMMAPS OR CATALOGS. * * PROC DBFLAG * * ENTRY THE CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS * ARE SET UP IN THE COMMON AREA DEFINED IN *COMTDBP*. * THE APPROPRIATE SMMAP AND CATALOG, IF ANY, HAVE * BEEN OPENED. * P = FWA OF *CALLSS* PARAMETER BLOCK. * * EXIT THE DIRECTIVE WAS PROCESSED AND THE MAP AND * CATALOG WERE CLOSED, OR AN ERROR CONDITION * WAS DETECTED. * * MESSAGES * SSDEBUG ABNORMAL, DBFLAG.* # # **** PROC DBFLAG - XREF LIST BEGIN. # XREF BEGIN PROC CCLOSE; # CLOSE MSF CATALOG # PROC CGETFCT; # GET *FCT* ENTRY # PROC DBCALL3; # ISSUE TYPE 3 *CALLSS* # PROC DBERR; # *SSDEBUG* ERROR PROCESSOR # PROC DBRESP; # RESPOND TO ERROR CONDITION # PROC DBVSN; # SEARCH SMMAP FOR A VSN # PROC MCLOSE; # CLOSE SMMAP # PROC MGETENT; # GET A SMMAP ENTRY # PROC MESSAGE; # ISSUE MESSAGE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # END # **** PROC DBFLAG - XREF LIST END. # DEF PROCNAME #"DBFLAG"#; # PROCEDURE NAME # DEF LISTCON #0#; # DO NOT LIST COMMON DECKS # *CALL COMBFAS *CALL COMBCMS *CALL COMBCPR *CALL COMBMAP *CALL COMBMCT *CALL COMTDBG *CALL COMTDBP *CALL COMTDER ITEM CONTINUE B; # LOOP CONTROL FLAG # ITEM I I; # INDUCTION VARIABLE # ITEM ORD I; # SMMAP ORDINAL # ITEM RESPCODE I; # RESPONSE CODE # ITEM Y I; # SM *Y* COORDINATE # ITEM Z I; # SM *Z* COORDINATE # ARRAY FCTENT [0:0] P(FCTENTL); ; # *FCT* ENTRY # ARRAY MAPENT [0:0] P(MAPENTL); ; # SMMAP ENTRY # CONTROL EJECT; # * IF THE *ST* PARAMETER WAS SPECIFIED, USE THIS VALUE IN PLACE * OF THE *SL* AND *SU* AU NUMBERS. # IF DBARG$ST[0] NQ -2 THEN # *ST* SPECIFIED # BEGIN DBARG$SL[0] = DBARG$ST[0]; DBARG$SU[0] = DBARG$ST[0]; END # * GET THE APPROPRIATE SMMAP OR CATALOG ENTRY. # IF DBARG$FL[0] EQ "ME" AND DBARG$FO[0] GR 0 THEN # *FCT* ENTRY REQUIRED # BEGIN # GET *FCT* # CGETFCT(DBARG$FM[0],DBARG$SB[0],DBARG$SMID[0],DBARG$FO[0], LOC(FCTENT[0]),0,RESPCODE); IF RESPCODE NQ CMASTAT"NOERR" THEN # UNABLE TO GET *FCT* # BEGIN DBRESP(RESPCODE,0); END P = LOC(FCTENT[0]); IF FCT$Y[0] EQ 0 AND FCT$Z[0] EQ 0 THEN # NO CARTRIDGE FOR THIS *FO* # BEGIN RESPCODE = CMASTAT"ORDERR"; DBRESP(RESPCODE,0); END DBARG$YI[0] = FCT$Y[0]; DBARG$ZI[0] = FCT$Z[0]; CCLOSE(DBARG$FM[0],DBARG$SB[0],0,RESPCODE); IF RESPCODE NQ CMASTAT"NOERR" THEN # UNABLE TO CLOSE CATALOG # BEGIN DBRESP(RESPCODE,0); END END # GET *FCT* # IF DBARG$WCN[0] NQ 0 THEN # CSN SPECIFIED # BEGIN # *CN* SPECIFIED # DBVSN(Y,Z,MAPENT[0],RESPCODE); IF RESPCODE NQ OK THEN # CSN NOT FOUND # BEGIN DBERRCODE = S"DVSN$NFND"; DBERR(DBERRCODE); RETURN; END DBARG$YI[0] = Y; DBARG$ZI[0] = Z; END # *CN* SPECIFIED # IF DBARG$YI[0] GQ 0 AND DBARG$WCN[0] EQ 0 THEN BEGIN # *YI* SPECIFIED # ORD = MAXORD -DBARG$ZI[0] - ( DBARG$YI[0]*16 ); MGETENT(DBARG$SMID[0],ORD,LOC(MAPENT[0]),RESPCODE); IF RESPCODE NQ CMASTAT"NOERR" THEN # UNABLE TO GET MAP ENTRY # BEGIN DBMSG$PROC[0] = PROCNAME; MESSAGE(DBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); END END # *YI* SPECIFIED # # * UPDATE THE CATALOG OR SMMAP AS REQUESTED. # P = LOC(MAPENT[0]); IF DBARG$FL[0] EQ "ME" THEN # UPDATE SMMAP # BEGIN # *FL* .EQ. *ME* # CM$FLAG1[0] = DBARG$ON[0] NQ 0; DBCALL3(REQTYP3"UPD$MAP",MAPENT[0],0,0,0,RESPCODE); IF RESPCODE NQ RESPTYP3"OK3" THEN # UNABLE TO UPDATE MAP # BEGIN DBRESP(RESPCODE,TYP"TYP3"); RETURN; END END # *FL* .EQ. *ME* # ELSE # UPDATE CATALOG # BEGIN # *FL* .NE. *ME* # IF DBARG$FO[0] EQ 0 OR DBARG$FO[0] EQ -2 THEN BEGIN # *FO* NOT SPECIFIED # IF CM$CODE[0] NQ CUBSTAT"SUBFAM" THEN # VSN OR Y-Z NOT IN SUBFAMILY # BEGIN DBERRCODE = S"DNOTIN$SB"; DBERR(DBERRCODE); RETURN; END DBARG$FO[0] = CM$FCTORD[0]; DBARG$FM[0] = CM$FMLYNM[0]; DBARG$SB[0] = CM$SUB[0]; END # *FO* NOT SPECIFIED # CONTINUE = TRUE; SLOWFOR I = DBARG$SL[0] STEP 1 WHILE CONTINUE AND I LQ DBARG$SU[0] DO BEGIN CONTINUE = DBARG$FLSD[0]; # TRUE FOR AU DETAIL FLAGS # DBARG$ST[0] = I; DBCALL3(REQTYP3"UPD$CAT",0,DBARG$FO[0],DBARG$FLCD[0], DBARG$ON[0],RESPCODE); IF RESPCODE NQ RESPTYP3"OK3" THEN # UNABLE TO UPDATE CATALOG # BEGIN DBRESP(RESPCODE,TYP"TYP3"); RETURN; END END END # *FL* .NE. *ME* # IF DBARG$FL[0] EQ "ME" OR DBARG$FO[0] EQ 0 THEN # MAP OPENED # BEGIN MCLOSE(DBARG$SMID[0],RESPCODE); IF RESPCODE NQ CMASTAT"NOERR" THEN # UNABLE TO CLOSE MAP # BEGIN DBRESP(RESPCODE,0); END END END # DBFLAG # TERM PROC DBFMAP; # TITLE DBFMAP - REMOVE *FCT* ENTRY. # BEGIN # DBFMAP # # ** DBFMAP - REMOVE *FCT* ENTRY. * * PROC DBFMAP. * * ENTRY THE CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS * ARE SET UP IN THE COMMON AREA DEFINED IN *COMTDBP*. * THE CATALOG IS OPEN FOR THE SPECIFIED FAMILY AND * SUBFAMILY. * P = FWA OF CALLSS PARAMETER BLOCK. * * EXIT THE DIRECTIVE HAS BEEN PROCESSED AND CATALOG * HAS BEEN CLOSED OR AN ERROR CONDITION HAS * BEEN DETECTED. * * NOTES THE SELECTED *FCT* ENTRY IS CHECKED FOR THE * SMMAP ERROR FLAG AND IF SET, A REQUEST IS * SENT TO EXEC TO PURGE THE *FCT* ENTRY. # # **** PROC DBFMAP - XREF LIST BEGIN. # XREF BEGIN PROC CCLOSE; # CLOSES THE CATALOG # PROC CGETFCT; # GET *FCT* ENTRY # PROC DBCALL3; # ISSUES A TYPE 3 UCP REQUEST # PROC DBERR; # ERROR PROCESSOR # PROC DBRESP; # PROCESS RESPONSE FROM EXEC # END # **** PROC DBFMAP - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMS *CALL COMBCPR *CALL COMBMCT *CALL COMTDBG *CALL COMTDBP *CALL COMTDER ITEM FCTBADR I; # FWA OF BUFFER FOR *FCT* # ITEM FLAG I; # ERROR STATUS # ITEM RESPCODE I; # RESPONSE FROM EXEC # ARRAY FCTENT [0:0] P(FCTENTL);; # *FCT* ENTRY # CONTROL EJECT; # * CHECK THE SMMAP ERROR FLAG IN THE *FCT* ENTRY. # FCTBADR = LOC(FCTENT[0]); CGETFCT(DBARG$FM[0],DBARG$SB[0],DBARG$SMID[0],DBARG$FO[0], FCTBADR,0,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # UNABLE TO GET *FCT* ENTRY # BEGIN DBRESP(FLAG,0); RETURN; END P = FCTBADR; IF NOT FCT$SEF[0] THEN # SMMAP ERROR FLAG NOT SET # BEGIN DBERRCODE = S"DCME$NSET"; DBERR(DBERRCODE); RETURN; END # * PURGE THE *FCT* ENTRY. # DBCALL3(REQTYP3"PURG$FCT",0,DBARG$FO[0],0,0,RESPCODE); IF RESPCODE NQ RESPTYP3"OK3" THEN # UNABLE TO PURGE *FCT* ENTRY # BEGIN DBRESP(RESPCODE,TYP"TYP3"); RETURN; END CCLOSE(DBARG$FM[0],DBARG$SB[0],0,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # UNABLE TO CLOSE CATALOG # BEGIN DBRESP(FLAG,0); END RETURN; END # DBFMAP # TERM PROC DBHEAD((FETP)); # TITLE DBHEAD - PRINT HEADER LINE ON THE REPORT. # BEGIN # DBHEAD # # ** DBHEAD - PRINT HEADER LINE ON THE REPORT. * * PROC DBHEAD((FETP)) * * ENTRY (FETP) = FWA OF FET FOR REPORT FILE. * * EXIT HEADER LINE HAS BEEN WRITTEN. * * NOTES THE REPORT FORMATTER IS USED TO PRINT * THE HEADER LINE. # ITEM FETP I; # FWA OF FET # # **** PROC DBHEAD - XREF LIST BEGIN. # XREF BEGIN PROC RPLINEX; # PRINT A REPORT LINE # END # **** PROC DBHEAD - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS CONTROL EJECT; # * PRINT HEADER LINE. # RPLINEX(FETP,"SSDEBUG REPORT FILE",2,19,0); RPLINEX(FETP," ",2,1,0); RPLINEX(FETP," ",2,1,0); RETURN; END # DBHEAD # TERM PROC DBLOOP((ARGLIST),ERRFLAG); # TITLE DBLOOP - CRACK AND SYNTAX CHECK *SSDEBUG* DIRECTIVES. # BEGIN # DBLOOP # # ** DBLOOP - CRACK AND SYNTAX CHECK *SSDEBUG* DIRECTIVES. * * PROC DBLOOP((ARGLIST),ERRFLAG) * * ENTRY (ARGLIST) = FWA OF ARGUMENT LIST. * (DB$CBUF) = *SSDEBUG* DIRECTIVES. * (DB$FET) = FET FOR READING DIRECTIVES. * * EXIT ALL THE DIRECTIVES HAVE BEEN CRACKED, SYNTAX CHECKED * AND WRITTEN TO A SCRATCH FILE. * (DSCR$FET) = FET FOR READING THE SCRATCH FILE. * (ERRFLAG) = FALSE, NO ERROR. * TRUE, ERROR IN ONE OR MORE DIRECTIVES. * * MESSAGES SSDEBUG, NO DIRECTIVES. * * NOTES A LOOP IS SET UP TO READ EACH DIRECTIVE. * THE DIRECTIVE IS CRACKED AND THE CRACKED * PARAMETERS ARE CONVERTED FROM DISPLAY * CODE TO INTEGER VALUES. THE CONVERTED PARAMETERS * ARE PLACED BACK INTO THE SAME LOCATIONS (DEFINED * IN *COMTDBP*). THE DIRECTIVE IS THEN CHECKED FOR * ALL THE VALID OPTIONS. ANY ERROR IN THE DIRECTIVE * CAUSES A DIRECTIVE ERROR FLAG TO BE SET UP. THE * CRACKED DIRECTIVE ALONG WITH THE DIRECTIVE * FLAG, NUMBER AND IMAGE IS WRITTEN TO A SCRATCH * FILE. THE SCRATCH FILE HAS ONE RECORD WITH * AN EOR. AN ERROR IN ANY DIRECTIVE CAUSES AN * ERROR FLAG TO BE RETURNED TO THE CALLING PROC. # ITEM ARGLIST I; # FWA OF ARGUMENT LIST # ITEM ERRFLAG B; # ERROR FLAG # # **** PROC DBLOOP - XREF LIST BEGIN. # XREF BEGIN PROC BZFILL; # BLANK/ZERO FILLS A BUFFER # PROC DBCONV; # CONVERT PARAMETERS TO INTEGERS # PROC DBERR; # ERROR PROCESSOR # PROC DBOPT; # CHECKS FOR VALID OPTIONS # PROC LOFPROC; # LIST OF FILES PROCESSOR # PROC MESSAGE; # DISPLAYS MESSAGES # PROC READC; # READS A CODED LINE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC RETERN; # RETURNS A FILE # PROC REWIND; # REWINDS A FILE # PROC RPLINE; # WRITES A REPORT LINE # PROC RPSPACE; # WRITES A BLANK LINE # PROC WRITER; # WRITES EOR ON A FILE # PROC WRITEW; # DATA TRANSFER ROUTINE # PROC XARG; # CRACK PARAMETER LIST # FUNC XCDD C(10); # CONVERTS TO DISPLAY CODE # PROC ZFILL; # ZERO FILLS A BUFFER # PROC ZSETFET; # INITIALIZES A FET # END # **** PROC DBLOOP - XREF LIST END. # DEF WBUFL #8#; # LENGTH OF WORKING BUFFER # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBBZF *CALL COMBCPR *CALL COMTDBG *CALL COMTDBP *CALL COMTDER *CALL COMTOUT ITEM BUFP I; # FWA OF *CIO* BUFFER # ITEM COMMENT B; # COMMENT INDICATOR # ITEM DIRNUM I; # DIRECTIVE NUMBER # ITEM EOR B; # EOR STATUS ON A FILE # ITEM FETP I; # FWA OF FET # ITEM I I; # LOOP INDUCTION VARIABLE # ITEM FLAG I; # ERROR STATUS # ITEM TEMP C(10); # TEMPORARY ITEM # ARRAY DB$WBUF [0:0] S(WBUFL); # WORKING BUFFER # BEGIN ITEM DB$DIRIMG C(00,00,80); # DIRECTIVE IMAGE # END CONTROL EJECT; COMMENT = FALSE; # INITIALIZE # EOR = FALSE; DIRNUM = 0; ERRFLAG = FALSE; # * SET UP FET FOR SCRATCH FILE. # FETP = LOC(DSCR$FET[0]); BUFP = LOC(DSCR$BUF[0]); ZSETFET(FETP,DBSCR,BUFP,DBUFL,SFETL); RETERN(DSCR$FET[0],RCL); # RETURN THE SCRATCH FILE # LOFPROC(DBSCR); # ADD LFN TO LIST OF FILES # # * SET UP A LOOP TO * 1. READ A DIRECTIVE. * 2. CRACK THE DIRECTIVE. * 3. CONVERT THE PARAMETERS. * 4. CHECK FOR VALID OPTIONS. * 5. WRITE THE DIRECTIVE TO THE SCRATCH FILE. # FASTFOR I = 0 STEP 1 WHILE NOT EOR DO BEGIN # CRACK AND SYNTAX CHECK DIRECTIVES # # * READ THE DIRECTIVE. # ZFILL(DB$WBUF[0],WBUFL); READC(DB$FET[0],DB$WBUF[0],WBUFL,FLAG); IF FLAG NQ OK THEN # NO MORE DIRECTIVES # BEGIN EOR = TRUE; TEST I; END # * CHECK FOR A COMMENT. # IF C<0,1>DB$DIRIMG[0] EQ "*" THEN # A COMMENT # BEGIN COMMENT = TRUE; TEMP = " "; END ELSE # A DIRECTIVE # BEGIN COMMENT = FALSE; DIRNUM = DIRNUM + 1; TEMP = XCDD(DIRNUM); # SET UP DIRECTIVE NUMBER # TEMP = C<7,3>TEMP; END # * WRITE THE DIRECTIVE IMAGE ALONG WITH THE DIRECTIVE * NUMBER TO THE OUTPUT FILE. # BZFILL(DB$WBUF[0],TYPFILL"BFILL",80); RPLINE(OUT$FETP,TEMP,2,5,1); RPLINE(OUT$FETP,DB$DIRIMG[0],8,80,0); RPSPACE(OUT$FETP,SP"SPACE",1); IF COMMENT THEN BEGIN TEST I; # READ NEXT DIRECTIVE # END # * SET UP THE AREA TO BE WRITTEN TO THE * SCRATCH FILE. # ZFILL(DBARG[0],DBDIRPRML); DBARG$DIRN[0] = TEMP; DBARG$DIRI[0] = DB$DIRIMG[0]; # * CRACK THE DIRECTIVE. # XARG(ARGLIST,DB$WBUF[0],FLAG); IF FLAG NQ OK THEN # SYNTAX ERROR IN DIRECTIVE # BEGIN DBARG$DIRF[0] = TRUE; ERRFLAG = TRUE; END # * ADJUST FOR MANUFACTURERS CODE. # IF C<1,1>DBARG$CM[0] NQ "-" THEN # INSERT HYPHEN # BEGIN C<1,1>DBARG$CM[0] = "-"; END # * CONVERT THE PARAMETERS FROM DISPLAY CODE TO * INTEGER VALUES. # IF NOT DBARG$DIRF[0] THEN BEGIN # CONVERT PARAMETERS # DBCONV(FLAG); IF FLAG NQ OK THEN # CONVERSION ERROR # BEGIN DBARG$DIRF[0] = TRUE; ERRFLAG = TRUE; END END # CONVERT PARAMETERS # IF DBARG$DIRF[0] THEN BEGIN DBERRCODE = S"DSYNT$DIR"; DBERR(DBERRCODE); END # * CHECK THE DIRECTIVE FOR VALID OPTIONS. # IF NOT DBARG$DIRF[0] THEN BEGIN # CHECK VALID OPTIONS # DBOPT(FLAG); IF FLAG NQ OK THEN # VALID OPTIONS VIOLATED # BEGIN DBARG$DIRF[0] = TRUE; ERRFLAG = TRUE; END END # CHECK VALID OPTIONS # # * WRITE THE DIRECTIVE NUMBER, ERROR FLAG, * IMAGE AND THE CRACKED PARAMETERS TO THE * SCRATCH FILE. # WRITEW(DSCR$FET[0],DBARG[0],DBDIRPRML,FLAG); END # CRACK AND SYNTAX CHECK DIRECTIVES # IF DIRNUM EQ 0 THEN # NO DIRECTIVES # BEGIN DBMSG$LN[0] = " SSDEBUG, NO DIRECTIVES."; MESSAGE(DBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END WRITER(DSCR$FET[0],RCL); REWIND(DSCR$FET[0],RCL); RETURN; END # DBLOOP # TERM PROC DBMAIN; # TITLE DBMAIN - PROCESS *SSDEBUG* DIRECTIVES. # BEGIN # SSDEBUG # # ** DBMAIN - PROCESS *SSDEBUG* DIRECTIVES. * * PROC DBMAIN. * * ENTRY THE CRACKED AND SYNTAX CHECKED DIRECTIVES * HAVE BEEN WRITTEN TO A SCRATCH FILE WHICH HAS * BEEN REWOUND. * (DSCR$FET) = FET FOR READING THE SCRATCH FILE. * * EXIT ALL DIRECTIVES HAVE BEEN PROCESSED OR AN ERROR FLAG * HAS BEEN SET UP. * * MESSAGES FAMILY NOT FOUND. * * NOTES A LOOP IS SET UP TO READ EACH DIRECTIVE * FROM THE SCRATCH FILE INTO THE COMMON AREA * DEFINED IN *COMTDBP*. THE CATALOG OR MAP IS * OPENED AND THE CORRESPONDING ROUTINE IS * CALLED TO PROCESS THE DIRECTIVE. ANY ERROR * IN DIRECTIVE PROCESSING CAUSES *SSDEBUG* * TO ABORT. # # **** PROC DBMAIN - XREF LIST BEGIN. # XREF BEGIN PROC COPEN; # OPEN CATALOG # PROC DBCMAP; # PROCESS REMOVE SMMAP ENTRY DIRECTIVE # PROC DBFLAG; # PROCESS CHANGE FLAG DIRECTIVE # PROC DBFMAP; # PROCESS REMOVE FCT ENTRY DIRECTIVE # PROC DBRDFIL; # PROCESS READ FILE DIRECTIVE # PROC DBRDSTM; # PROCESS READ AU DIRECTIVE # PROC DBREL; # PROCESS RELEASE MSF PROBLEM CHAIN DIRECTIVE # PROC DBRESP; # PROCESSES RESPONSE FROM EXEC # PROC LOFPROC; # LIST OF FILES PROCESSOR # PROC MESSAGE; # DISPLAY MESSAGES # PROC MOPEN; # OPEN SMMAP # PROC READ; # READS A FILE # PROC READW; # DATA TRANSFER ROUTINE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC RETERN; # RETURNS A FILE # PROC RPLINE; # WRITES A REPORT LINE # PROC RPSPACE; # WRITES A BLANK LINE # PROC SETPFP; # SET FAMILY AND USER INDEX # PROC SSINIT; # SETS UP TABLES AND POINETRS # FUNC XCOD C(10); # INTEGER TO DISPLAY CONVERSION # END # **** PROC DBMAIN - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMD *CALL COMBCMS *CALL COMBCPR *CALL COMBPFP *CALL COMBSNS *CALL COMSPFM *CALL COMTDBG *CALL COMTDBP *CALL COMTOUT ITEM DIS$SB C(10); # SUBFAMILY IN DISPLAY CODE # ITEM EOR B; # INDICATES END OF RECORD # ITEM I I; # LOOP INDUCTION VARIABLE # ITEM J I; # LOOP INDUCTION VARIABLE # ITEM RESPCODE I; # RESPONSE CODE # ARRAY CATNAME [0:0] P(1); # CATALOG FILE NAME # BEGIN ITEM CAT$NAM C(00,00,06); # FIRST 6 CHARACTERS # ITEM CAT$SB C(00,36,01); # SUBFAMILY IDENTIFIER # END ARRAY DRWSTAT [0:0] S(SNSLEN);; # DRAWER STATUS TABLE # ARRAY MAPNAME [0:0] P(1); # MAP FILE NAME # BEGIN ITEM MAP$NAM C(00,00,07) = ["SMMAP "]; ITEM MAP$SM C(00,30,01); # SM IDENTIFIER # ITEM MAP$ZFILL U(00,36,06) = [0]; END # * SWITCH TO PROCESS *SSDEBUG* DIRECTIVES. THE * ORDER OF THE SWITCH LABELS IS THE SAME AS THE * DIRECTIVE NAMES SET UP IN ARRAY *DB$DIR* * DEFINED IN *COMTDBG*. # SWITCH DIR$ACT # SWITCH TO PROCESS DIRECTIVES # CMAP, # REMOVE SMMAP ENTRY # FMAP, # REMOVE *FCT* ENTRY # REL, # RELEASE PROBLEM CHAIN # RDFIL, # READ FILE # RDSTM, # READ AU # FLAG; # CHANGE FLAG # CONTROL EJECT; ADDRSENSE = LOC(DRWSTAT[0]); # FWA OF DRAWER STATUS TABLE # P = ADDRSENSE; # * INITIALIZE THE FETS, BUFFERS, TABLES AND * POINTERS NEEDED TO ACCESS CATALOGS AND MAPS. # SSINIT; # * READ THE DIRECTIVES. # READ(DSCR$FET[0],RCL); EOR = FALSE; FASTFOR I = 0 STEP 1 WHILE NOT EOR DO BEGIN # PROCESS EACH DIRECTIVE # READW(DSCR$FET[0],DBARG[0],DBDIRPRML,RESPCODE); IF RESPCODE NQ OK THEN # NO MORE DIRECTIVES # BEGIN EOR = TRUE; TEST I; END # * WRITE THE DIRECTIVE TO THE OUTPUT FILE. # RPLINE(OUT$FETP,DBARG$DIRN[0],2,5,1); RPLINE(OUT$FETP,DBARG$DIRI[0],8,80,0); RPSPACE(OUT$FETP,SP"SPACE",1); IF DBARG$DIRF[0] THEN # SYNTAX ERROR IN DIRECTIVE # BEGIN RPLINE(OUT$FETP,"*** SYNTAX ERROR",2,16,0); TEST I; # GET NEXT DIRECTIVE # END IF DBARG$FM[0] EQ 0 THEN # FAMILY NOT SPECIFIED # BEGIN DBARG$FM[0] = DEF$FAM; # USE DEFAULT FAMILY # END PFP$WRD0[0] = 0; # SET FLAGS # PFP$WRD1[0] = 0; # CLEAR PACK NAME # PFP$FG1[0] = TRUE; PFP$FG2[0] = TRUE; PFP$FG4[0] = TRUE; # * OPEN THE SMMAP FOR *RS*, *RC* AND *CF* DIRECTIVES. # IF DBARG$OP[0] EQ "RC" OR ( DBARG$OP[0] EQ "RS" AND DBARG$WCN[0] NQ 0 ) OR (DBARG$OP[0] EQ "CF" AND (DBARG$FL[0] EQ "ME" OR DBARG$FO[0] LS 0)) THEN BEGIN # OPEN SMMAP # PFP$FAM[0] = DEF$FAM; # SET FAMILY AND USER INDEX # PFP$UI[0] = DEF$UI; SETPFP(PFP); IF PFP$STAT[0] NQ 0 THEN # DEFAULT FAMILY NOT FOUND # BEGIN DBMSG$LN[0] = " FAMILY NOT FOUND."; MESSAGE(DBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END MAP$SM[0] = DBARG$SM[0]; MOPEN(DBARG$SMID[0],MAP$NAM[0],"RM",RESPCODE); IF RESPCODE NQ CMASTAT"NOERR" THEN # UNABLE TO OPEN MAP # BEGIN DBRESP(RESPCODE,0); TEST I; END ELSE # MAP OPENED # BEGIN LOFPROC(MAP$NAM[0]); # ADD LFN TO LIST OF FILES # END END # OPEN SMMAP # # * OPEN THE CATALOG FOR *RF*, *RP*, *RL*, AND *CF* DIRECTIVES. # IF DBARG$OP[0] EQ "RF" OR DBARG$OP[0] EQ "RP" OR DBARG$OP[0] EQ "RL" OR (DBARG$OP[0] EQ "CF" AND DBARG$FL[0] EQ "ME" AND DBARG$FO[0] GR 0) THEN BEGIN # OPEN CATALOG # PFP$FAM[0] = DBARG$FM[0]; # SET FAMILY AND USER INDEX # PFP$UI[0] = DEF$UI + DBARG$SB[0]; SETPFP(PFP); IF PFP$STAT[0] NQ 0 THEN # FAMILY NOT FOUND # BEGIN DBMSG$LN[0] = " FAMILY NOT FOUND."; MESSAGE(DBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END CAT$NAM[0] = SFMCAT; DIS$SB = XCOD(DBARG$SB[0]); CAT$SB[0] = C<9,1>DIS$SB; COPEN(DBARG$FM[0],DBARG$SB[0],CATNAME[0],"RM",TRUE,RESPCODE); IF RESPCODE NQ CMASTAT"NOERR" THEN # UNABLE TO OPEN CATALOG # BEGIN DBRESP(RESPCODE,0); TEST I; END ELSE # CATALOG OPENED # BEGIN LOFPROC(OCT$LFN[1]); # ADD LFN TO LIST OF FILES # END END # OPEN CATALOG # # * PROCESS THE DIRECTIVE. # SLOWFOR J = 0 STEP 1 UNTIL DBDIRNM DO BEGIN # FIND MATCHING DIRECTIVE # IF DB$DIRNM[J] EQ DBARG$OP[0] THEN BEGIN GOTO DIR$ACT[J]; CMAP: # REMOVE SMMAP ENTRY # DBCMAP; TEST I; FMAP: # REMOVE *FCT* ENTRY # DBFMAP; TEST I; REL: # RELEASE PROBLEM CHAINS # DBREL; TEST I; RDFIL: # READ FILE # DBRDFIL; TEST I; RDSTM: DBRDSTM; # READ AU # TEST I; FLAG: DBFLAG; # CHANGE FLAG # TEST I; END END # FIND MATCHING DIRECTIVE # END # PROCESS EACH DIRECTIVE # RETURN; END # DBMAIN # TERM PROC DBOPT(FLAG); # TITLE DBOPT - CHECKS CRACKED PARAMETERS FOR VALID OPTIONS. # BEGIN # DBOPT # # ** DBOPT - CHECKS CRACKED PARAMETERS FOR VALID OPTIONS. * * PROC DBOPT(FLAG) * * ENTRY THE CRACKED AND CONVERTED PARAMETERS ARE SET UP * IN THE COMMON AREA DEFINED IN *COMTDBP*. * * EXIT ALL OPTIONS HAVE BEEN CHECKED FOR VALIDITY. * (FLAG) = 0, NO ERROR. * 1, VALID OPTION VIOLATED. * * NOTES ALL THE DIRECTIVES ARE CHECKED FOR VALID * OPTIONS. THE VALID OPTIONS ARE * 1. *OP* MUST BE A VALID DIRECTIVE NAME. * 2. *FO* MUST BE SPECIFIED FOR OP=RF, RP AND RL, * AND *ST* MUST BE SPECIFIED FOR OP=RF AND RP. * 3. *SB* MUST BE FROM 0 TO 7. * 4. *CS* MUST BE FROM A THROUGH H. * 5. *SL* AND *SU* MUST BE FROM 1 TO 1931. * 5. *SL* AND *SU* MUST BE FROM 1 TO 1931. * 6. *SL* MUST BE LESS THAN OR EQUAL TO *SU*. * 7. FOR OP=RS, ONE AND ONLY ONE OF THE FOLLOWING * PARAMETERS MUST BE SPECIFIED: *V*, *YI*, OR *D*. * 8. FOR OP=CF, ONE AND ONLY ONE OF THE FOLLOWING * PARAMETERS MUST BE SPECIFIED: *V*, *YI*, OR *FO*. * 9. *FL*, *ON*, AND *OF* ARE VALID ONLY FOR OP=CF. * 10. FOR OP=CF, *FL* MUST BE A VALID FLAG NAME AND * EITHER *ON* OR *OF* MUST BE SPECIFIED. * 11. *YI* AND *ZI* MUST BE SPECIFIED TOGETHER. * 12. *YI* MUST BE FROM 0 TO 21. * 13. *ZI* MUST BE FROM 0 TO 15. * 14. *YI*, *ZI* MUST BE SPECIFIED FOR OP=RC. * * ANY VIOLATION OF THE VALID OPTIONS CAUSES A * MESSAGE TO BE PRINTED IN THE DAYFILE AND THE * REPORT FILE, AND AN ERROR FLAG TO BE RETURNED * TO THE CALLING ROUTINE. # ITEM FLAG I; # ERROR STATUS # # **** PROC DBOPT - XREF LIST BEGIN. # XREF BEGIN PROC DBERR; # ERROR PROCESSOR # END # **** PROC DBOPT - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMTDBP *CALL COMTDBG *CALL COMTDER *CALL COMTLAB ITEM FOUND B; # SEARCH FLAG # ITEM I I; # LOOP INDUCTION VARIABLE # ITEM OPTCOUNT I; # OPTION COUNT # CONTROL EJECT; FLAG = 1; # INITIALIZE # # * CHECK FOR A LEGAL DIRECTIVE NAME. # FOUND = FALSE; FASTFOR I = 0 STEP 1 UNTIL DBDIRNM DO BEGIN # SEARCH FOR MATCHING DIRECTIVE NAME # IF DBARG$OP[0] EQ DB$DIRNM[I] THEN BEGIN FOUND = TRUE; END END # SEARCH FOR MATCHING DIRECTIVE NAME # IF NOT FOUND THEN # ILLEGAL DIRECTIVE # BEGIN DBERRCODE = S"DILLEG$DIR"; DBERR(DBERRCODE); RETURN; END # * CHECK IF *FO* SPECIFIED CORRECTLY. # IF DBARG$FO[0] EQ -1 ## OR (DBARG$FO[0] EQ -2 ## AND (DBARG$OP[0] EQ "RF" ## OR DBARG$OP[0] EQ "RP" ## OR DBARG$OP[0] EQ "RL")) OR ( DBARG$FO[0] GQ 0 AND DBARG$FO[0] LS MINFO ) OR ( DBARG$FO[0] GR MAXFO ) THEN # *FO* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$FO"; DBERR(DBERRCODE); RETURN; END # * CHECK IF *ST* IS SPECIFIED CORRECTLY. # IF DBARG$ST[0] EQ -1 ## OR ( ( DBARG$ST[0] EQ -2 ## OR DBARG$ST[0] EQ 0 ) ## AND (DBARG$OP[0] EQ "RF" ## OR DBARG$OP[0] EQ "RP")) THEN # *ST* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$ST"; DBERR(DBERRCODE); RETURN; END # * CHECK THE VALUE OF *SB*. # IF DBARG$SB[0] LS 0 ## OR DBARG$SB[0] GR 7 THEN # *SB* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$SB"; DBERR(DBERRCODE); RETURN; END # * CHECK THE VALUE OF *SM*. # IF DBARG$SM[0] LS "A" ## OR DBARG$SM[0] GR "H" ## OR DBARG$WSM[0] NQ 0 ## THEN # *SM* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$SM"; DBERR(DBERRCODE); RETURN; END # * CHECK THE VALUE OF *SL*. # IF ( DBARG$SL[0] LS 0 ## OR DBARG$SL[0] GR INAVOT ) # MAXIMUM AU PER CARTRIDGE # OR ( DBARG$OP[0] EQ "RS" ## AND DBARG$SL[0] EQ 0 ) ## THEN # *SL* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$SL"; DBERR(DBERRCODE); RETURN; END # * CHECK THE VALUE OF *SU*. # IF ( DBARG$SU[0] LS 0 ## OR DBARG$SU[0] GR INAVOT ) # MAXIMUM AU PER CARTRIDGE # OR ( DBARG$OP[0] EQ "RS" ## AND DBARG$SU[0] EQ 0 ) ## OR DBARG$SU[0] LS DBARG$SL[0] THEN # *SU* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$SU"; DBERR(DBERRCODE); RETURN; END # * CHECK THE VALUE OF *CN* # IF DBARG$WCN[0] EQ -1 THEN # *CN* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$V"; DBERR(DBERRCODE); RETURN; END # * CHECK THE VALUE OF *YI* AND *ZI*. # IF DBARG$YI[0] LS -1 ## OR DBARG$ZI[0] LS -1 ## OR DBARG$YI[0] GR MAX$Y ## OR DBARG$ZI[0] GR MAX$Z ## OR DBARG$ZI[0] EQ Z$NO$CUBE THEN # *YI*, *ZI* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$YZ"; DBERR(DBERRCODE); RETURN; END # * CHECK IF *YI* AND *ZI* ARE SPECIFIED TOGETHER. # IF (DBARG$YI[0] EQ -1 ## AND DBARG$ZI[0] GQ 0) ## OR (DBARG$YI[0] GQ 0 ## AND DBARG$ZI[0] EQ -1) THEN # *YI*, *ZI* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$YZ"; DBERR(DBERRCODE); RETURN; END # * *YI*, *ZI* MUST BE SPECIFIED FOR OP=RC. # IF DBARG$OP[0] EQ "RC" ## AND DBARG$YI[0] EQ -1 THEN # *YI*, *ZI* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$YZ"; DBERR(DBERRCODE); RETURN; END # * FOR OP=RS, ONE AND ONLY ONE OF THE FOLLOWING MUST BE * SPECIFIED: *CN*, OR *YI*. FOR OP=CF, ONE AND ONLY * ONE OF THE FOLLOWING MUST BE SPECIFIED: *CN*, *YI*, OR *FO*. # IF DBARG$OP[0] EQ "RS" OR DBARG$OP[0] EQ "CF" THEN BEGIN # CHECK *CN*, *YI*, AND *FO* # OPTCOUNT = 0; IF DBARG$WCN[0] NQ 0 THEN # *CN* SPECIFIED # BEGIN OPTCOUNT = OPTCOUNT + 1; END IF DBARG$YI[0] GQ 0 THEN # *YI* SPECIFIED # BEGIN OPTCOUNT = OPTCOUNT + 1; END IF DBARG$OP[0] EQ "CF" ## AND DBARG$FO[0] GR 0 THEN # *FO* SPECIFIED AND OP=CF # BEGIN OPTCOUNT = OPTCOUNT + 1; DBERRCODE = S"DVIOL$VFOX"; END IF OPTCOUNT NQ 1 THEN # OPTION VIOLATED # BEGIN DBERR(DBERRCODE); RETURN; END END # CHECK *CN*, *YI*, AND *FO* # # * *FL* IS REQUIRED FOR OP=CF, AND NOT ALLOWED FOR ANY * OTHER DIRECTIVES. # IF (DBARG$OP[0] EQ "CF" AND DBARG$FL[0] LQ 0) OR (DBARG$OP[0] NQ "CF" AND DBARG$FL[0] GR 0) THEN # *FL* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$FL"; DBERR(DBERRCODE); RETURN; END # * EITHER *ON* OR *OF* (BUT NOT BOTH) MUST BE SPECIFIED FOR * OP=CF, BUT NEITHER MAY BE USED WITH OTHER DIRECTIVES. # IF (DBARG$OP[0] EQ "CF" AND DBARG$ON[0] EQ DBARG$OF[0]) OR (DBARG$OP[0] NQ "CF" AND ((DBARG$ON[0] NQ 0) OR (DBARG$OF[0] NQ 0))) THEN # *ON*, *OF* OPTION VIOLATED # BEGIN DBERRCODE = S"DVIOL$ONOF"; DBERR(DBERRCODE); RETURN; END # * CHECK FOR A VALID VALUE OF *FL*. # IF DBARG$OP[0] EQ "CF" THEN # CHANGE FLAG DIRECTIVE # BEGIN # CHECK *FL* # FOUND = FALSE; FASTFOR I = 0 STEP 1 WHILE NOT FOUND AND I LQ DBFLAGNM DO BEGIN IF DBARG$FL[0] EQ DB$FLAG[I] THEN BEGIN FOUND = TRUE; DBARG$FLCD[0] = DB$FLCODE[I]; # SAVE STATUS VALUE # DBARG$FLSD[0] = DB$FLSTR[I]; # AU DETAIL FLAG # END END IF NOT FOUND THEN BEGIN DBERRCODE = S"DVIOL$FL"; DBERR(DBERRCODE); RETURN; END END # CHECK *FL* # FLAG = 0; # NO ERRORS DETECTED # RETURN; END # DBOPT # TERM PROC DBRDFIL; # TITLE DBRDFIL - PROCESS READ FILE DIRECTIVE. # BEGIN # DBRDFIL # # ** DBRDFIL - PROCESS READ FILE DIRECTIVE. * * PROC DBRDFIL. * * ENTRY THE CRACKED AND SYNTAX CHECKED DIRECTIVE IS * IN THE COMMON AREA DEFINED IN *COMTDBP*. * THE CATALOG IS OPEN FOR THE SPECIFIED FAMILY * AND SUBFAMILY. * P = FWA OF CALLSS PARAMETER BLOCK. * (USER$FAM) = USER-S FAMILY NAME. * (USER$UI) = USER-S USER INDEX. * * EXIT THE DIRECTIVE HAS BEEN PROCESSED AND * THE CATALOG HAS BEEN CLOSED OR AN ERROR * CONDITION HAS BEEN DETECTED. * * MESSAGES SSDEBUG ABNORMAL, DBRDFIL. * * NOTES THE CARTRIDGE IS LOADED AND A REQUEST IS SENT * TO EXEC TO COPY EACH RAW AU IN THE CHAIN * TO THE SPECIFIED FILE. IF AN OFF CARTRIDGE * LINK EXISTS THE NEXT CARTRIDGE IS LOADED. THIS * SEQUENCE IS REPEATED UNTIL THE ENTIRE FILE IS * COPIED. IF FROZEN CHAIN FLAG IS SET * *SSDEBUG* ABORTS WITH A DAYFILE MESSAGE. # # **** PROC DBRDFIL - XREF LIST BEGIN. # XREF BEGIN PROC CCLOSE; # CLOSES THE CATALOG # PROC CGETFCT; # GET *FCT* ENTRY # PROC DBCALL4; # ISSUES A TYPE 4 UCP REQUEST # PROC DBERR; # ERROR PROCESSOR # PROC DBRESP; # PROCESSES RESPONSE FROM EXEC # PROC MESSAGE; # DISPLAYS MESSAGES # PROC PFD; # *PFM* REQUEST INTERFACE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC RETERN; # RETURNS A FILE # PROC SETPFP; # SET FAMILY AND USER INDEX # PROC ZSETFET; # INITIALIZES A FET # END # **** PROC DBRDFIL - XREF LIST END. # DEF PROCNAME #"DBRDFIL."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMS *CALL COMBCPR *CALL COMBMCT *CALL COMBPFP *CALL COMSPFM *CALL COMTDBG *CALL COMTDBP *CALL COMTDER ITEM ANOTHERVOL B; # MORE VOLUMES ON CARTRIDGE # ITEM CHNCNTRL I; # CHAIN CONTROL FIELD # ITEM FCTBADR I; # FWA OF BUFFER FOR *FCT* # ITEM FLAG I; # ERROR STATUS # ITEM GTNXTCART B; # GET NEXT CARTRIDGE FLAG # ITEM LAST B; # END OF CHAIN INDICATOR # ITEM LINK I; # OFF CARTRIDGE LINK # ITEM NXTFCT I; # NEXT *FCT* ENTRY ORDINAL # ITEM NXTSTRM I; # NEXT AU IN THE CHAIN # ITEM RESPCODE I; # RESPONSE FROM EXEC # ITEM SH I; # STRIPE HIGH # ITEM SL I; # STRIPE LOW # ITEM TEMP I; # INTEGER SCRATCH # ARRAY FCTENT [0:0] P(FCTENTL);; # *FCT* ENTRY # ARRAY SCRFET [0:0] S(SFETL);; # SCRATCH FET # CONTROL EJECT; # * DEFINE THE USER-S FILE TO RECEIVE THE RAW AU DATA. # RESTPFP(PFP$RESUME); # RESTORE USER-S *PFP* # FLAG = 0; PFD("DEFINE",DBARG$PF[0],0,"RC",FLAG,0); IF FLAG NQ OK THEN # UNABLE TO DEFINE USER-S FILE # BEGIN DBERRCODE = S"DDEF$PF"; DBERR(DBERRCODE); RETURN; END ZSETFET(LOC(SCRFET[0]),DBARG$PF[0],0,0,SFETL); RETERN(SCRFET[0],RCL); GTNXTCART = TRUE; # INITIALIZE THE FLAGS # LINK = 0; ANOTHERVOL = FALSE; NXTFCT = DBARG$FO[0]; SL = INSPAU*DBARG$ST[0] + (INFTST - INSPAU); NXTSTRM = DBARG$ST[0]; LAST = FALSE; FCTBADR = LOC(FCTENT[0]); # * COPY EACH AU OF THE FILE. # REPEAT WHILE NOT LAST DO BEGIN # COPY RAW AU # IF GTNXTCART ## AND NOT ANOTHERVOL THEN BEGIN # GET NEXT CARTRIDGE # CGETFCT(DBARG$FM[0],DBARG$SB[0],DBARG$SMID[0],NXTFCT, FCTBADR,0,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # UNABLE TO GET *FCT* ENTRY # BEGIN DBRESP(FLAG,0); RETURN; END # * CHECK FOR FROZEN CHAIN. # P = FCTBADR; IF FCT$Y[0] EQ 0 AND FCT$Z[0] EQ 0 THEN # NO CARTRIDGE FOR *FO* # BEGIN FLAG = CMASTAT"ORDERR"; DBRESP(FLAG,0); END FLAG = FCT$FRCF(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); IF FLAG EQ 1 THEN # FROZEN CHAIN # BEGIN DBERRCODE = S"DFROZ$CHN"; DBERR(DBERRCODE); RETURN; END SETFCTX(NXTSTRM); TEMP = FCT$LEN(FWD,FPS); SH = SL + INSPAU*TEMP + INSPAU - 1; # * CHECK FOR BEGINNING OF VOLUME. # FLAG = FCT$CC(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); IF FLAG NQ CHAINCON"FIRST" ## AND FLAG NQ CHAINCON"ONLY" ## AND LINK EQ 0 # NOT CONTINUATION CARTRIDGE # THEN # INVALID STARTING AU # BEGIN DBERRCODE = S"DVIOL$ST"; DBERR(DBERRCODE); RETURN; END # * CHECK FOR ALLOCATED AU. # FLAG = FCT$FBF(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); IF FLAG EQ 0 THEN # AU NOT ALLOCATED # BEGIN DBERRCODE = S"DVIOL$ST"; DBERR(DBERRCODE); RETURN; END # * CHECK FOR AU CONFLICT. # FLAG = FCT$AUCF(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); IF FLAG NQ 0 THEN # INTERSECTING CHAIN # BEGIN DBERRCODE = S"DVIOL$ST"; DBERR(DBERRCODE); RETURN; END # * CHECK FOR START OF FRAGMENT. # FLAG = FCT$SFF(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); IF FLAG NQ 0 THEN # START OF FRAGMENT # BEGIN DBERRCODE = S"DVIOL$ST"; DBERR(DBERRCODE); RETURN; END # * LOAD THE CARTRIDGE. # P = FCTBADR; DBCALL4(REQTYP4"LOAD$CART",FCT$Y[0],FCT$Z[0],0,0,0,0, RESPCODE); IF RESPCODE NQ RESPTYP4"OK4" THEN # UNABLE TO LOAD CARTRIDGE # BEGIN DBRESP(RESPCODE,TYP"TYP4"); RETURN; END TRNSPORT = CPR$DRD[0]; # SET UP TRANSPORT ID # GTNXTCART = FALSE; END # GET NEXT CARTRIDGE # # * COPY THE RAW AU. # ANOTHERVOL = FALSE; DBCALL4(REQTYP4"CP$RAW$AU",FCT$Y[0],FCT$Z[0],SL,SH, USER$FAM[0],USER$UI[0],RESPCODE); IF RESPCODE NQ RESPTYP4"OK4" THEN # UNABLE TO COPY RAW AU # BEGIN DBRESP(RESPCODE,TYP"TYP4"); RETURN; END # * GET THE NEXT AU IN THE CHAIN. # LINK = FCT$CLKOCL(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); IF LINK NQ 0 THEN # OFF CARTRIDGE LINK TEST # BEGIN # OFF CARTRIDGE LINK EXISTS # GTNXTCART = TRUE; IF LINK EQ 1 THEN # USE FIRST OFF CARTRIDGE LINK # BEGIN NXTFCT = FCT$OCL[0] + MINFO; END IF LINK EQ 2 THEN # USE SECOND OFF CARTRIDGE LINK # BEGIN NXTFCT = FCT$OCL1[0] + MINFO; END IF LINK EQ 3 THEN # USE THIRD OFF CARTRIDGE LINK # BEGIN NXTFCT = FCT$OCL2[0] + MINFO; END DBCALL4(REQTYP4"UNLD$CART",FCT$Y[0],FCT$Z[0],0,0,0,0, RESPCODE); IF RESPCODE NQ RESPTYP4"OK4" THEN # UNABLE TO UNLOAD CARTRIDGE # BEGIN DBRESP(RESPCODE,TYP"TYP4"); RETURN; END NXTSTRM = FCT$LINK(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); SL = INSPAU*NXTSTRM + (INFTST - INSPAU); END # OFF CARTRIDGE LINK EXISTS # IF LINK EQ 0 THEN # NO OFF CARTRIGE LINK # BEGIN # NO OFF CARTRIDGE LINK # CHNCNTRL = FCT$CC(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); IF CHNCNTRL EQ CHAINCON"LAST" ## OR CHNCNTRL EQ CHAINCON"ONLY" THEN # END OF CHAIN # BEGIN LAST = TRUE; TEST DUMMY; END NXTSTRM = FCT$LINK(FCT$WD(NXTSTRM),FCT$WP(NXTSTRM)); SL = INSPAU*NXTSTRM + (INFTST - INSPAU); SETFCTX(NXTSTRM); TEMP = FCT$LEN(FWD,FPS); SH = SL + INSPAU*TEMP + INSPAU - 1; ANOTHERVOL = TRUE; END # NO OFF CARTRIDGE LINK # END # COPY RAW AU # # * UNLOAD THE CARTRIDGE. # DBCALL4(REQTYP4"UNLD$CART",FCT$Y[0],FCT$Z[0],0,0,0,0, RESPCODE); IF RESPCODE NQ RESPTYP4"OK4" THEN # PROCESS ERROR RESPONSE # BEGIN DBRESP(RESPCODE,TYP"TYP4"); RETURN; END CCLOSE(DBARG$FM[0],DBARG$SB[0],0,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # UNABLE TO CLOSE CATALOG # BEGIN DBRESP(FLAG,0); END RETURN; END # DBRDFILE # TERM PROC DBRDSTM; # TITLE DBRDSTM - PROCESS READ AU DIRECTIVE. # BEGIN # DBRDSTM # # ** DBRDSTM - PROCESS READ AU DIRECTIVE. * * PROC DBRDSTM. * * ENTRY THE CRACKED AND SYNTAX CHECKED DIRECTIVE IS * IN THE COMMON AREA DEFINED IN *COMTDBG*. * THE MAP FOR THE SPECIFIED SM IS OPEN. * P = FWA OF CALLSS PARAMETER BLOCK. * (USER$FAM) = USER-S FAMILY NAME. * (USER$UI) = USER-S USER INDEX. * * EXIT THE DIRECTIVE HAS BEEN PROCESSED AND * THE MAP HAS BEEN CLOSED OR AN ERROR * CONDITION HAS BEEN DETECTED. * * MESSAGES SSDEBUG ABNORMAL, DBRDSTM. * * NOTES THE SPECIFIED CARTRIDGE IS LOADED AND A REQUEST * IS SENT TO EXEC TO COPY EACH SELECTED AU TO * THE SPECIFIED FILE. # # **** PROC DBRDSTM - XREF LIST BEGIN. # XREF BEGIN PROC DBCALL4; # ISSUES TYPE 4 UCP REQUEST # PROC DBERR; # ERROR PROCESSOR # PROC DBRESP; # PROCESSES RESPONSE FROM EXEC # PROC DBVSN; # SEARCH SM MAP FOR A VSN # PROC MCLOSE; # CLOSES SMMAP # PROC MESSAGE; # DISPLAYS MESSAGES # PROC PFD; # *PFM* REQUEST INTERFACE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC RETERN; # RETURNS A FILE # PROC SETPFP; # SET FAMILY AND USER INDEX # PROC ZSETFET; # INITIALIZES A FET # END # **** PROC DBRDSTM - XREF LIST END. # DEF PROCNAME #"DBRDSTM."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMS *CALL COMBCPR *CALL COMBMAP *CALL COMBPFP *CALL COMSPFM *CALL COMTDBG *CALL COMTDBP *CALL COMTDER ITEM FLAG I; # ERROR STATUS # ITEM I I; # LOOP INDUCTION VARIABLE # ITEM RESPCODE I; # RESPONSE CODE # ITEM STRIPELO I; # INITIAL STRIPE # ITEM STRIPEHI I; # LAST STRIPE # ITEM Y I; # Y COORDINATE # ITEM Z I; # Z COORDINATE # ARRAY CMAPENT [0:0] P(MAPENTL);; # SMMAP ENTRY # ARRAY SCRFET [0:0] S(SFETL);; # SCRATCH FET # CONTROL EJECT; # * DEFINE THE USER-S FILE TO RECEIVE THE RAW AU DATA. # RESTPFP(PFP$RESUME); # RESTORE USER-S *PFP* # FLAG = 0; PFD("DEFINE",DBARG$PF[0],0,"RC",FLAG,0); IF FLAG NQ OK THEN # UNABLE TO DEFINE USER-S FILE # BEGIN DBERRCODE = S"DDEF$PF"; DBERR(DBERRCODE); RETURN; END ZSETFET(LOC(SCRFET[0]),DBARG$PF[0],0,0,SFETL); RETERN(SCRFET[0],RCL); # * LOCATE THE CARTRIDGE. # Y = DBARG$YI[0]; # COORDINATES SPECIFIED, IF ANY # Z = DBARG$ZI[0]; IF DBARG$D[0] GQ -1 THEN # CARTRIDGE IN INPUT DRAWER # BEGIN Z = SM$ENT$TY; # SET ENTRY TRAY # Y = 0; END IF DBARG$WCN[0] NQ 0 THEN BEGIN # SEARCH SMMAP FOR THE VSN # DBVSN(Y,Z,CMAPENT[0],FLAG); IF FLAG NQ OK THEN # VSN NOT FOUND # BEGIN DBERRCODE = S"DVSN$NFND"; DBERR(DBERRCODE); RETURN; END END # SEARCH SMMAP FOR THE VSN # # * LOAD THE CARTRIDGE. # DBCALL4(REQTYP4"LOAD$CART",Y,Z,0,0,0,0,RESPCODE); IF RESPCODE NQ RESPTYP4"OK4" THEN # UNABLE TO LOAD CARTRIDGE # BEGIN DBRESP(RESPCODE,TYP"TYP4"); RETURN; END TRNSPORT = CPR$DRD[0]; # SET UP TRANSPORT ID # # * COPY EACH OF THE SELECTED RAW AU. # STRIPELO = INSPAU*DBARG$SL[0] + ( INFTST - INSPAU ); STRIPEHI = INSPAU*(DBARG$SU[0] - DBARG$SL[0] + 1) + STRIPELO - 1; DBCALL4(REQTYP4"CP$RAW$AU",Y,Z,STRIPELO,STRIPEHI,USER$FAM[0], USER$UI[0],RESPCODE); # * UNLOAD THE CARTRIDGE. # DBCALL4(REQTYP4"UNLD$CART",Y,Z,0,0,0,0,RESPCODE); IF RESPCODE NQ RESPTYP4"OK4" THEN # UNABLE TO UNLOAD CARTRIDGE # BEGIN DBRESP(RESPCODE,TYP"TYP4"); RETURN; END IF DBARG$WCN[0] NQ 0 THEN # MAP OPENED # BEGIN MCLOSE(DBARG$SMID[0],FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # UNABLE TO CLOSE SMMAP # BEGIN DBRESP(FLAG,0); END END RETURN; END # DBRDSTM # TERM PROC DBREL; # TITLE DBREL - RELEASE PROBLEM CHAIN AND CLEAR FLAGS. # BEGIN # DBREL # # ** DBREL - RELEASE PROBLEM CHAIN AND CLEAR FLAGS. * * PROC DBREL. * * ENTRY THE CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS * ARE IN THE COMMON AREA DEFINED IN *COMTDBP*. * THE CATALOG IS OPEN FOR THE SPECIFIED FAMILY AND * SUBFAMILY. * P = FWA OF CALLSS PARAMETER BLOCK. * * EXIT THE DIRECTIVE HAS BEEN PROCESSED AND THE * CATALOG HAS BEEN CLOSED OR AN ERROR CONDI- * TION HAS BEEN DETECTED. * * NOTES THE SELECTED *FCT* ENTRY IS CHECKED FOR THE * FROZEN CHAIN FLAG AND IF SET, A REQUEST IS * SENT TO EXEC TO RELEASE THE PROBLEM CHAIN. # # **** PROC DBREL - XREF LIST BEGIN. # XREF BEGIN PROC CCLOSE; # CLOSES THE CATALOG # PROC CGETFCT; # GET *FCT* ENTRY # PROC DBCALL3; # ISSUES A TYPE 3 UCP REQUEST # PROC DBERR; # ERROR PROCESSOR # PROC DBRESP; # PROCESS RESPONSE FROM EXEC # END # **** PROC DBREL - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMS *CALL COMBCPR *CALL COMBMCT *CALL COMTDBG *CALL COMTDBP *CALL COMTDER ITEM FCTBADR I; # FWA OF BUFFER FOR *FCT* # ITEM FLAG I; # ERROR STATUS # ITEM RESPCODE I; # RESPONSE FROM EXEC # ARRAY FCTENT [0:0] P(FCTENTL);; # *FCT* ENTRY # CONTROL EJECT; # * CHECK THE FROZEN CHAIN FLAG IN THE *FCT* ENTRY. # FCTBADR = LOC(FCTENT[0]); CGETFCT(DBARG$FM[0],DBARG$SB[0],DBARG$SMID[0],DBARG$FO[0], FCTBADR,0,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # UNABLE TO GET *FCT* ENTRY # BEGIN DBRESP(FLAG,0); RETURN; END P = FCTBADR; FLAG = FCT$FRCF(FCT$WD(DBARG$ST[0]),FCT$WP(DBARG$ST[0])); IF FLAG EQ 0 THEN # FROZEN CHAIN FLAG NOT SET # BEGIN DBERRCODE = S"DFROZ$NSET"; DBERR(DBERRCODE); RETURN; END # * RELEASE FROZEN CHAIN. # DBCALL3(REQTYP3"PURG$FRAG",0,DBARG$FO[0],0,0,RESPCODE); IF RESPCODE NQ RESPTYP3"OK3" THEN # UNABLE TO RELEASE FROZEN CHAIN # BEGIN DBRESP(RESPCODE,TYP"TYP3"); RETURN; END CCLOSE(DBARG$FM[0],DBARG$SB[0],0,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # UNABLE TO CLOSE CATALOG # BEGIN DBRESP(FLAG,0); END RETURN; END # DBREL # TERM PROC DBRESP((RESPCODE),(REQTYPE)); # TITLE DBRESP - PROCESS RESPONSE FROM EXEC. # BEGIN # DBRESP # # ** DBRESP - PROCESS RESPONSE FROM EXEC. * * PROC DBRESP((RESPCODE),(REQTYPE)) * * ENTRY (RESPCODE) = RESPONSE CODE FROM EXEC. * (REQTYPE) = TYPE OF REQUEST SENT TO EXEC. * 0, FOR MAP/CATALOG ACCESS ROUTINES. * * EXIT THE ERROR RESPONSE HAS BEEN PROCESSED. * * MESSAGES SSDEBUG ABNORMAL, DBRESP. * * NOTES *SSDEBUG* ERROR PROCESSOR IS CALLED WITH THE * CORRESPONDING ERROR CODE. # ITEM RESPCODE I; # RESPONSE CODE FROM EXEC # ITEM REQTYPE I; # TYPE OF REQUEST SENT TO EXEC # # **** PROC DBRESP - XREF LIST BEGIN. # XREF BEGIN PROC DBERR; # ERROR PROCESSOR # PROC MESSAGE; # DISPLAYS MESSAGE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # END # **** PROC DBRESP - XREF LIST END. # DEF PROCNAME #"DBRESP."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMS *CALL COMBCPR *CALL COMTDBG *CALL COMTDER # * STATUS SWITCH TO PROCESS THE RESPONSE CODES RETURNED * IN RESPONSE TO A TYPE 3 UCP REQUEST. # SWITCH RESPACT3: RESPTYP3 # TYPE 3 RESPONSE CODES # OK3$ACT: OK3, # NO ERROR # INTLCK$ACT: C$M$INTLCK, # CATALOG/MAP INTERLOCKED # NOPEN$ACT: C$M$NOPEN, # CATALOG/MAP NOT OPEN # RESUB$ACT: RESUB$REQ, # RESUBMIT REQUEST # SCATEX$ACT: SUB$CAT$EX, # SUBCATALOG ALREADY EYISTS # NOSUB$ACT: NO$SUB$CAT, # NO SUCH SUBCATALOG # PFPROB$ACT: PF$PROB, # PF PROBLEM # NEMPTY$ACT: MSC$NEMPTY, # MSC NOT EMPTY # ILLORD$ACT:ILLEG$ORD, # ORDINAL OUT OF RANGE # NFROZ$ACT: NFROZ$FRAG, # NON FROZEN FRAGMENT # GR$FL$ACT: GROUP$FUL; # GROUP FULL STATUS # # * STATUS SWITCH TO PROCESS THE RESPONSE CODES * RETURNED IN RESPONSE TO A TYPE 4 UCP REQUEST. # SWITCH RESPACT4: RESPTYP4 # TYPE 4 RESPONSE CODES # OK4$ACT: OK4, # NO ERROR # CSN$MIS$ACT: CART$LB$ERR, # PART OF LABEL MATCHED # CSN$USE$ACT: CSN$IN$USE, # CSN IN USE # CELL$EMP$ACT: CELL$EMP, # SPECIFIED CELL EMPTY # CELL$FLL$ACT: CELL$FULL, # SPECIFIED CELL FULL # EX$DMARK$ACT: EX$DMARK, # EXCESSIVE DMARKS # UNK$CART$ACT: UNK$CART, # NO CARTRIDGE LABEL MATCH # URDERR$ACT: UN$RD$ERR, # UNRECOVERABLE READ ERROR # UWTERR$ACT: UN$WRT$ERR, # UNRECOVERABLE WRITE ERROR # VOL$ERR$ACT: VOL$HD$ERR, # VOLUME HEADER ERROR # M86HW$PR$ACT: M86$HDW$PR, # M860 HARDWARE PROBLEM # RMSER$ACT: RMS$FL$ERR, # DISK FILE ERROR # DSKFUL$ACT: DISK$FULL, # DISK FULL # ATTER$ACT: ATTACH$ERR, # ATTACH ERROR # SMA$OFF$ACT: SMA$OFF, # SM IS OFF # EOI$ACT: EOI; # END OF INFORMATION ON FILE # CONTROL EJECT; # * CHECK THE RESPONSE TYPE. # IF REQTYPE EQ TYP"TYP3" THEN # TYPE 3 UCP REQUEST # BEGIN GOTO RESPACT3[RESPCODE]; END IF REQTYPE EQ TYP"TYP4" THEN # TYPE 4 UCP REQUEST # BEGIN GOTO RESPACT4[RESPCODE]; END IF REQTYPE NQ 0 THEN # ILLEGAL ERROR TYPE # BEGIN GOTO ERR; END # * PROCESS RESPONSE FROM CATALOG/MAP ACCESS ROUTINES. # IF RESPCODE EQ CMASTAT"INTLK" THEN # CATALOG/MAP INTERLOCKED # BEGIN DBERRCODE = S"DC$M$INTLK"; DBERR(DBERRCODE); RETURN; END IF RESPCODE EQ CMASTAT"ATTERR" THEN # ATTACH ERROR # BEGIN DBERRCODE = S"DPF$PROB"; DBERR(DBERRCODE); RETURN; END IF RESPCODE EQ CMASTAT"NOSUBCAT" THEN # NO SUCH SUBCATALOG # BEGIN DBERRCODE = S"DNO$SUBCAT"; DBERR(DBERRCODE); RETURN; END IF RESPCODE EQ CMASTAT"ORDERR" THEN # *FCT* ORDINAL OUT OF RANGE # BEGIN DBERRCODE = S"DORD$ERR"; DBERR(DBERRCODE); RETURN; END GOTO ERR; # ILLEGAL RESPONSE CODE # # * PROCESS RESPONSE CODES FOR TYPE 3 UCP REQUESTS. # OK3$ACT: # NO ERROR # RETURN; INTLCK$ACT: # CATALOG/MAP FILE INTERLOCKED # DBERRCODE = S"DC$M$INTLK"; DBERR(DBERRCODE); RETURN; NOPEN$ACT: # CATALOG/MAP NOT OPEN # DBERRCODE = S"DC$M$NOPEN"; DBERR(DBERRCODE); RETURN; RESUB$ACT: # RESUBMIT REQUEST # GOTO ERR; SCATEX$ACT: # SUBCATALOG ALREADY EYISTS # GOTO ERR; NOSUB$ACT: # NO SUCH SUBCATALOG # DBERRCODE = S"DNO$SUBCAT"; DBERR(DBERRCODE); RETURN; PFPROB$ACT: # PF PROBLEM # DBERRCODE = S"DPF$PROB"; DBERR(DBERRCODE); RETURN; NEMPTY$ACT: # MSC NOT EMPTY # GOTO ERR; ILLORD$ACT: # *FCT* ORDINAL OUT OF RANGE # DBERRCODE = S"DORD$ERR"; DBERR(DBERRCODE); RETURN; NFROZ$ACT: # NON FROZEN FRAGMENT # DBERRCODE = S"DFROZ$NSET"; DBERR(DBERRCODE); RETURN; GR$FL$ACT: # GROUP FULL # GOTO ERR; # * PROCESS RESPONSE CODES FOR TYPE 4 UCP REQUESTS. # OK4$ACT: # NO ERROR # RETURN; CSN$MIS$ACT: # CSN CARTRIDGE MISMATCH # DBERRCODE = S"DCART$LB$ERR"; DBERR(DBERRCODE); RETURN; CSN$USE$ACT: # CSN IN USE # DBERRCODE = S"DCSN$IN$USE"; DBERR(DBERRCODE); RETURN; CELL$EMP$ACT: # CELL EMPTY # DBERRCODE = S"DCELL$EMP"; DBERR(DBERRCODE); RETURN; CELL$FLL$ACT: # CELL FULL # GOTO ERR; EX$DMARK$ACT: # EXCESSIVE DEMARKS # GOTO ERR; UNK$CART$ACT: # NO CARTRIDGE LABEL MATCH # DBERRCODE = S"DUNK$CART"; DBERR(DBERRCODE); RETURN; URDERR$ACT: # UNRECOVERABLE READ ERROR # DBERRCODE = S"DUN$RD$ERR"; DBERR(DBERRCODE); RETURN; UWTERR$ACT: # UNRECOVERABLE WRITE ERROR # GOTO ERR; VOL$ERR$ACT: # VOLUME HEADER ERROR # DBERRCODE = S"DVOL$HD$ERR"; DBERR(DBERRCODE); RETURN; M86HW$PR$ACT: # M860 HARDWARE ERROR # DBERRCODE = S"DSYS$ERR"; DBERR(DBERRCODE); RETURN; RMSER$ACT: # DISK FILE ERROR # DBERRCODE = S"DDSKFL$ERR"; DBERR(DBERRCODE); RETURN; DSKFUL$ACT: # DISK FULL # DBERRCODE = S"DDISK$FULL"; DBERR(DBERRCODE); RETURN; ATTER$ACT: # ATTACH ERROR # DBERRCODE = S"DATT$ERR"; DBERR(DBERRCODE); RETURN; SMA$OFF$ACT: # SMA OFF # DBERRCODE = S"DSMA$OFF"; DBERR(DBERRCODE); RETURN; EOI$ACT: # EOI ON FILE # GOTO ERR; ERR: DBMSG$PROC[0] = PROCNAME; # ABNORMAL TERMINATION # MESSAGE(DBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END # DBRESP # TERM PROC DBVSN(Y,Z,MAPENT,FLAG); # TITLE - DBVSN - SEARCH SMMAP FOR THE CSN. # BEGIN # DBVSN # # ** DBVSN - SEARCH SMMAP FOR CSN. * * PROC DBVSN(Y,Z,MAPENT,FLAG) * * ENTRY (DBARG$SMID) = SM-ID. * (DBARG$CN) = DIGIT PORTION OF CSN. * (DBARG$CM) = CARTRIDGE MANUFACTURER CODE. * * EXIT (Y) = Y COORDINATE OF MATCHING CSN. * (Z) = Z COORDINATE OF MATCHING CSN. * (MAPENT) = SMMAP ENTRY. * (FLAG) = ERROR STATUS. * 0, NO ERROR * 1, CSN NOT FOUND. * * MESSAGES SSDEBUG ABNORMAL, DBVSN. * * NOTES THE SMMAP IS SEARCHED SEQUENTIALLY FOR * MATCHING CSN. # ITEM Y I; # Y COORDINATE OF MATCHING CSN # ITEM Z I; # Z COORDINATE OF MATCHING CSN # ARRAY MAPENT [0:0] S(3);; # SMMAP ENTRY # ITEM FLAG I; # ERROR STATUS # # **** PROC DBVSN - XREF LIST BEGIN. # XREF BEGIN PROC MESSAGE; # DISPLAYS MESSAGE # PROC MGETENT; # GET SMMAP ENTRY # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # END # **** PROC DBVSN - XREF LIST END. # DEF PROCNAME #"DBVSN."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMS *CALL COMBCPR *CALL COMBMAP *CALL COMTDBP *CALL COMTDBG ITEM I I; # LOOP INDUCTION VARIABLE # ITEM MAPADDR I; # FWA OF BUFFER TO HOLD ENTRY # CONTROL EJECT; FLAG = 0; # INITIALIZE # MAPADDR = LOC(MAPENT[0]); P = MAPADDR; # * SEARCH SMMAP FOR MATCHING VSN. # FASTFOR I = 1 STEP 1 UNTIL MAXORD DO BEGIN # SEARCH SMMAP # MGETENT(DBARG$SMID[0],I,MAPADDR,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # ABNORMAL TERMINATION # BEGIN DBMSG$PROC[0] = PROCNAME; MESSAGE(DBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END IF CM$CCOD[0] EQ DBARG$CM[0] AND CM$CSND[0] EQ DBARG$CN[0] THEN # VSN MATCH FOUND # BEGIN Y = ( MAXORD - I )/( MAX$Z + 1 ); Z = MAXORD - I - ( MAX$Z + 1 )* Y; RETURN; END END # SEARCH SMMAP # FLAG = 1; # MATCHING VSN NOT FOUND # RETURN; END TERM