Trailing-Edge
-
PDP-10 Archives
-
BB-H506E-SM
-
cobol/source/lblerr.mac
There are 13 other files named lblerr.mac in the archive. Click here to see a list.
; UPD ID= 3499 on 4/24/81 at 11:21 AM by WRIGHT
TITLE LBLERR FOR LIBOL V12C
SUBTTL D. WRIGHT
SEARCH COPYRT
SALL
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1979, 1985
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;***** V12B *****
;WHO DATE COMMENT
;JSM 16-JUN-83 [1071] ZERO OUT FILE-STATUS ERROR NUMBER BEFORE ASSEMBLING IT
;RLF 15-FEB-83 [1053] Change error message to "file is busy".
;LEM 8-APR-82 [1017]RESET ERRNUM WHEN RETRYING TO OPEN A BUSY RMS FILE
;****
SEARCH COMUNI ;GET COMMON SYMBOLS, MACROS
IFN TOPS20, SEARCH MONSYM,MACSYM
IFE TOPS20, SEARCH UUOSYM,MACTEN
SEARCH LBLPRM ;GET LIBOL PARAMETERS
SEARCH FTDEFS ;AND FILE-TABLE DEFINITIONS
SALL
HISEG
.COPYRIGHT ;Put COPYRIGHT statement in .REL file.
T1=1 ;NOT DEFINED IN COMUNI YET
T2=2
T3=3
T4=4
P1=5 ;PERM. AC (SAVED ACROSS SUBROUTINES)
P2=6
P3=7
P4=10
C=11
FT=12 ;FILE TABLE PTR (PERM)
FTL=13
FLG=14
ARG=16
PP=17
;THE FOLLOWING ARE DEFINED IN RMSIO ALSO, FOR NOW.. [12B]
LF%FNA==1B32 ;ASCII FILE NAME AVAILABLE FOR TYPING
LF%INP==1B33 ;FILE IS OPEN FOR INPUT
LF%OUT==1B34 ;FILE IS OPEN FOR OUTPUT
LF%IO==1B35 ;FILE IS OPEN FOR I-O (ALL 3 BITS ON)
UP%ERR==0 ;ERROR USE PROCEDURE
UP%OER==1 ;FILENAME OPEN USE PROCEDURE
;VERBS TO BE DEFINED IN COMUNI IN V13
VB.PTR: POINT 4,T1,3 ;BYTE POINTER TO GET VERB VALUE
;WHEN T1 IS LOADED UP WITH @BS.AGL
V%OPEN==1 ;OPEN
V%CLOS==2 ;CLOSE
V%READ==3 ;READ
V%WRIT==4 ;WRITE
V%RWRT==5 ;REWRITE
V%DELT==6 ;DELETE
V%STRT==7 ;START
;TABLE OF VALUES TO ADD TO FS.EN, INDEXED BY THE ABOVE NUMBER
ENADDT: 0 ;NO 0 VERB
^D100000000 ;OPEN
^D200000000 ;CLOSE
^D600000000 ;READ
^D300000000 ;WRITE
^D400000000 ;REWRITE
^D500000000 ;DELETE
^D900000000 ;START
;OPEN BITS (DEFINED IN LBLPRM IN V13)
OPN%IN==1B9 ;FILE BEING OPENED FOR INPUT
OPN%OU==1B10 ;FILE BEING OPENED FOR OUTPUT
OPN%IO==1B11 ;FILE BEING OPENED FOR I-O (ALL 3 BITS ON)
SUBTTL MACROS, OPDEFS
DEFINE TYPE (ADDR),<
IFN TOPS20,<
HRROI T1,ADDR
PSOUT%
>;END IFN TOPS20
IFE TOPS20,<
OUTSTR ADDR
>
>;END DEFINE TYPE
DEFINE $TYPT1,<
IFN TOPS20, PBOUT% ;TYPE IT
IFE TOPS20, OUTCHR T1 ;TYPE IT
>;END DEFINE $TYPT1
CRLF: ASCIZ/
/ ;A CRLF
SUBTTL INTERFACE TO OTHER LIBOL MODULES
ENTRY LBLERR ;ROUTINE TO DO THE LIBOL ERROR
ENTRY SETEFS ;SET ERROR FILE-STATUS ITEMS, IF ANY
ENTRY SETFS ;SET FIRST FILE-STATUS ITEM, IF ANY
ENTRY CHKUSE ;CHECK FOR A USE PROCEDURE
ENTRY RMSERP ;RMS ERROR REPORT
EXTERN ER.PC ;PC WHEN LBLERR CALLED
EXTERN ER.MCL ;MONITOR CALL NUMBER THAT CAUSED THE ERROR
EXTERN ER.FLG ;FLAGS,, ERROR-NUMBER
EXTERN ER.HIJ ;"HIJ" OF THE 10-DIGIT ERROR NUMBER
EXTERN ER.RBG ;RMS BUG ERROR CODE
; UNLESS CD=0
IFN TOPS20,<
EXTERN ER.JSE ;JSYS ERROR
>
IFE TOPS20,<
EXTERN ER.E10 ;TOPS10 ERROR CODE
>
FT.RMS: POINT 1,F.RMS(FT),7 ;RMS BIT IN FILE-TABLE
FT.PPN: POINT 18,F.RPPN(FT),35 ;ADDR OF USER-NUMBER
FT.RUP: POINT 18,F.REUP(FT),35 ;ADDRESS OF ERROR USE PROCEDURE
FT.UPO: POINT 1,F.WOUP(FT),6 ;=1 IF ERROR USE PROCEDURE FOR OPEN
BP%SEV: POINT 3,ER.FLG,2 ;ERROR SEVERITY CODE
BP%FNM: POINT 1,ER.FLG,17 ;"FILENAME WANTED" BIT
BP%BRN: POINT 1,ER.FLG,16 ;"BLOCK#, REC# WANTED" BIT
IFN TOPS20,<
BP%JSE: POINT 1,ER.FLG,15 ;"JSYS ERROR AVAILABLE" BIT
>
IFE TOPS20,<
BP%E10: POINT 1,ER.FLG,15 ;"TOPS10 ERROR AVAILABLE" BIT
>
BP%ENO: POINT 12,ER.FLG,35 ;ERROR NUMBER 1 THRU 999
BP%IVB: POINT 1,ER.FLG,14 ; This error is from an I-O verb
BP%OER: POINT 1,ER.FLG,13 ; Filename on OPEN error
SUBTTL LBLERR ENTRY
;THIS ROUTINE IS CALLED VIA THE $ERROR MACRO, WHICH EXPANDS AS
; FOLLOWS:
;
; MOVE T2,[FLAGS+SEVERITY,,ERROR-NUMBER]
; MOVEI T3,MONCAL ;MONITOR-CALL CODE, IF GIVEN
; JSP T1,LBLERR
; JRST RETURN-ADDR
LBLERR: MOVEM T1,ER.PC ;SAVE ERROR PC
MOVEM T2,ER.FLG ;SAVE FLAGS, ERR-NUM
MOVEM T3,ER.MCL ;SAVE MONITOR CALL CODE
;CHECK TO SEE IF A USE PROCEDURE WILL BE CALLED
LDB T1,BP%SEV ;GET SEVERITY
CAIE T1,SV.FAT ;IF NOT "FATAL",
JRST LBLER0 ; DON'T INVOKE A "USE" PROCEDURE
LDB T1,BP%FNM ;IS THIS A FILE ERROR?
JUMPE T1,LBLER0 ; NO, DON'T DO A "USE" PROCEDURE
LDB T1,BP%OER ;CHECK FOR OPEN ERROR
JUMPE T1,LBLEOP ;No, don't check for that one.
MOVEI T1,UP%OER ;Check for filename OPEN use procedure
PUSHJ PP,CHKUSE ;..
CAIA ;None
JRST LBLECU ;Got one, use that!
LBLEOP: MOVEI T1,UP%ERR ;CHECK FOR ERROR USE PROCEDURE
PUSHJ PP,CHKUSE ;IS THERE ONE?
JRST LBLER0 ;NO USE PROCEDURE, TYPE ERROR MESSAGE
; JRST LBLECU ;Libol error procedure, not OPEN use procedure
;CALL THE USE PROCEDURE SUPPLIED BY THE USER
LBLECU: PUSH PP,T1 ;SAVE ADDRESS..
MOVEI T1,^D30 ;SET FILE-STATUS TO 30 FOR ALL
MOVEM T1,FS.FS ; ERROR-USE PROCEDURES
PUSHJ PP,SETFS ;SET USER-SUPPLIED VARIABLE (IF ANY)
PUSHJ PP,SETEFS ;SET ERROR-STATUS WORDS, IF ANY
POP PP,T1 ;RESTORE ADDRESS OF USE PROCEDURE
PUSH PP,FT ;SAVE FILE-TABLE PTR
PUSH PP,FTL
PUSHJ PP,(T1) ;CALL ERROR USE PROCEDURE
;WARNING: THIS MAY SMASH ALL ACS EXCEPT PP
POP PP,FTL
POP PP,FT ;;RESTORE FILE-TABLE PTR
;CHECK THE IGNORE FLAG.
;THE ERROR IS IGNORED IF THE USER SPECIFIED AN IGNORE FLAG VALUE OF NON-ZERO.
SKIPE T1,F.WPAC(FT) ;DID USER SUPPLY AN IGNORE-FLAG VARIABLE?
SKIPN T1,(T1) ; AND IS IT SET NON-ZERO?
JRST LBLER0 ;NOT BOTH TRUE, GO TO ERROR MESSAGE AND KILL
;IGNORE THE ERROR! (GO BACK TO RETURN ADDRESS)
HRRZ T1,ER.PC ;GET PC
JRST (T1) ;RETURN THERE
SUBTTL LBLERR - ERROR TYPEOUT
;HERE IF WE MUST TYPE THE ERROR OUT FOR HIM.
; EITHER:
; 1) NO ERROR USE PROCEDURE IS AVAILABLE.
; 2) ONE HAS BEEN CALLED, AND THE USER DID NOT SET THE "IGNORE" FLAG.
;V12B: ONLY RMS ERRORS WILL USE THE NEW MACRO. ERRORS START AT ^D500,
; SO WE WILL SAVE SPACE BY TEMPORARILY ALLOCATING MESSAGES STARTING AT 500.
LBLER0: PUSHJ PP,OUTBF.## ;OUTPUT THE TTY BUFFER, GO INTO
; IMMEDIATE OUTPUT MODE
TYPE CRLF ;TYPE A CRLF
LDB T1,BP%SEV ;GET SEVERITY
MOVEI T2,[ASCIZ/?LBL/] ;ASSUME FATAL
CAIN T1,SV.WRN ;JUST A WARNING?
MOVEI T2,[ASCIZ/%LBL/] ;YES
CAIN T1,SV.INF ;INFORMATIONAL?
MOVEI T2,[ASCIZ/[LBL/] ;YES
TYPE <(T2)> ;TYPE THE HEADER PART
IFN TOPS20,<
MOVEI T1,.PRIOU ;TO PRIMARY OUTPUT
LDB T2,BP%ENO ; GET ERROR MESSAGE NUMBER
MOVX T3,3B17!NO%ZRO!^D10 ;TYPE 3 DIGITS, WITH LEADING 0'S
NOUT% ;TYPE THE ERROR NUMBER
ERJMP .+1 ;ONLY ERRORS ARE BUGS (IMPOSSIBLE!)
>;END IFN TOPS20
IFE TOPS20,<
LDB T2,BP%ENO ; GET ERROR MESSAGE NUMBER
IDIVI T2,^D100 ;GET HUNDREDS
ADDI T2,"0" ;MAKE ASCII
OUTCHR T2 ;TYPE HUNDREDS
IDIVI T3,^D10 ;GET TENS & ONES
ADDI T3,"0" ;MAKE ASCII
OUTCHR T3
ADDI T4,"0"
OUTCHR T4
>;END IFE TOPS20
TYPE [ASCIZ/ /] ;TYPE A SPACE BEFORE THE TEXT
;TYPE THE MAIN MESSAGE TEXT
LDB T2,BP%ENO ;GET ERROR NUMBER AGAIN
;AN ERROR NUMBER OF ZERO INDICATES AN INTERNAL LIBOL ERROR
JUMPE T2,[TYPE [ASCIZ/Internal LIBOL error/]
JRST LBLER1]
SUBI T2,^D500 ;[V12B] GET REAL INDEX INTO TABLE
TYPE @ER500(T2) ;[V12B] TYPE THE ERROR TEXT
LDB T2,BP%SEV ;GET SEVERITY
CAIE T2,SV.INF ; INFORMATIONAL?
JRST LBLER1 ;NO
TYPE <[ASCIZ/]
/]> ;FINISH THAT LINE
JRST LBLE1A ;AND SKIP CRLF
LBLER1: TYPE CRLF ;TYPE A CRLF
LBLE1A:
IFN TOPS20,<
;TYPE JSYS ERROR IF HE WANTS IT
LDB T1,BP%JSE ;"JSYS ERROR WANTED" BIT
JUMPE T1,LBLE1B ;JUMP IF NOT SPECIFIED
TYPE [ASCIZ/ TOPS20 JSYS error: /]
HRRZ T2,ER.JSE ;GET ERROR CODE
PUSHJ PP,TOCT ;TYPE OCTAL NUMBER
TYPE [ASCIZ/ = /]
MOVEI T1,.PRIOU ;;TYPE IT
HRRZ T2,ER.JSE ;GET ERROR CODE
HRLI T2,.FHSLF ;MY PROCESS
SETZ T3, ;ALL OF IT
ERSTR% ;TYPE IT
JRST [TYPE [ASCIZ/* Undefined error number */]
JRST .+1]
JFCL ;(IMPOSSIBLE)
TYPE CRLF ;TYPE CRLF
>;END IFN TOPS20
IFE TOPS20,< ;TYPE TOPS10 ERROR CODE IF HE WANTS IT
LDB T1,BP%E10 ;"TOPS10 ERROR WANTED" BIT
JUMPE T1,LBLE1B ;NOT SPECIFIED
TYPE [ASCIZ/ TOPS10 UUO error: /]
HRRZ T2,ER.E10 ;GET ERROR CODE
TYPE @ET0(T2) ;TYPE THE ERROR TEXT
TYPE CRLF ;AND A CRLF
>;END IFE TOPS20
;TYPE LIBOL ERROR NUMBER
LBLE1B: TYPE [ASCIZ/ LIBOL error number: /]
SKIPN FS.EN ;ALREADY SET UP?
PUSHJ PP,SETEN ;NO, SET IT UP
MOVE T1,@BS.AGL## ;GET CONTENTS OF BASE OF ARG LIST TO GET VERB
LDB T1,VB.PTR ;GET VERB
MOVE T2,ENADDT(T1) ;GET NUMBER TO ADD
IDIV T2,[^D100000000] ;GET NUMBER OF THE VERB
PUSHJ PP,TWODIG ;;PRINT TWO DIGITS
MOVE T2,ER.MCL ;GET CD = MONITOR CALL CODE
PUSHJ PP,TWODIG ;PRINT 'EM
;ROUTINE GETFTP GETS FILE-TYPE CODE IN T2, ISAM BLOCK TYPE (IF ANY) IN T3
PUSHJ PP,GETFTP ;GET TYPE OF FILE BEING ACCESSED
PUSHJ PP,TWODIG ;PRINT IT
MOVEI T1,"0"(T3) ;GET THE ASCII DIGIT IN T1
$TYPT1
MOVEI T1,"." ;DELIMIT LAST THING.
$TYPT1
LDB T1,BP%ENO ;GET ERROR NUMBER
SKIPE ER.MCL ;CD=0?
HRRZ T1,ER.HIJ ;NO, GET USER-SUPPLIED NUMBER
IDIVI T1,^D100 ;GET T1=H
IDIVI T2,^D10 ;GET T2=I, T3=J
ADDI T1,"0" ;MAKE ASCII DIGIT
IFN TOPS20,<
PBOUT%
MOVEI T1,"0"(T2)
PBOUT%
MOVEI T1,"0"(T3)
PBOUT%
>
IFE TOPS20,<
OUTCHR T1
ADDI T2,"0"
OUTCHR T2
ADDI T3,"0"
OUTCHR T3
>
TYPE CRLF ;FINISH WITH CRLF
;TYPE FILENAME IF HE WANTS THAT
LBLER2: LDB T1,BP%FNM ;GET "FILENAME WANTED" BIT
JUMPE T1,LBLER3 ;JUMP IF NOT WANTED
TYPE [ASCIZ/ File: /]
MOVEI T4,^D30 ;30 CHARS MAX
MOVE T3,[POINT 6,(FT)] ;POINT AT FILENAME
LBLFER: ILDB T1,T3 ;GET CHAR
CAIE T1,0 ;TERMINATE ON A SPACE
SOJGE T4,LBLFR1 ;OR SATISFIED CHARACTER COUNT
JRST LBLFR2
LBLFR1: ADDI T1,40 ;CONVERT TO ASCII
$TYPT1 ;TYPE CHARACTER IN T1
JRST LBLFER ;LOOP
;TYPE ASCII NAME OR VALUE-OF-ID
LBLFR2: LDB T1,FT.RMS ;IS THIS AN RMS FILE?
JUMPE T1,LBLFR3 ;JUMP IF NO
SKIPN T3,D.RMSP(FT) ;IS AN RMS-BLOCK SET UP?
JRST LBLFR3 ;NO
MOVE T1,D.F1(FT) ;GET FLAGS RMS HAS SET
TXNN T1,LF%FNA ;SKIP IF FILENAME IN ASCII IS AVAILABLE
JRST LBLFR3 ;NO
TYPE [ASCIZ/: /]
TYPE <.RCFNM(T3)> ;TYPE THE FILENAME STRING
JRST LBLFR4 ;DONE, TYPE CRLF
;TYPE FROM VALUE OF ID
LBLFR3: SKIPN T3,F.WVID(FT) ;BP TO VALUE OF ID
JRST LBLFR4 ;EXIT IF NO VID.
TYPE <[ASCIZ/: [/]>
MOVEI T4,^D9 ;NINE CHARACTERS
LBLF3A: ILDB T1,T3 ;GET NEXT CHARACTER
TLNN T3,100 ;SKIP IF ASCII
ADDI T1,40 ;CONVERT SIXBIT TO ASCII
TLNN T3,600 ; EBCDIC?
LDB T1,IPT971## ;YES, CONVERT CHAR IN T1
$TYPT1 ;TYPE IT
SOJG T4,LBLF3A ;DO ALL 9 CHARACTERS
MOVEI T1,"]" ;END WITH CLOSING SQUARE BRACKET
$TYPT1
;TYPE OUT VALUE OF USER-NUMBER IF SUPPLIED
LDB T1,FT.PPN ;GET ADDRESS OF USER-NUMBER
JUMPE T1,LBLFR4 ;EXIT IF NONE GIVEN
PUSH PP,(T1) ;SAVE VALUE
TYPE <[ASCIZ/ User-number: [/]>
HLRZ T2,(PP) ;GET LH
PUSHJ PP,TOCT ;TYPE OCTAL
MOVEI T1,","
$TYPT1
HRRZ T2,(PP) ;GET RH
PUSHJ PP,TOCT ;TYPE OCTAL
MOVEI T1,"]"
$TYPT1
POP PP,T2 ;FIX STACK, PUT PPN IN T2
;FOR TOPS20:
;WE COULD TRANSLATE, BUT DON'T BOTHER.
;THE USER CAN DO A "TRANSLATE" COMMAND.
LBLFR4: TYPE CRLF ;EXIT
JRST LBLER3
;TYPE BLOCK #, REC # IF HE WANTS THAT
LBLER3: LDB T1,BP%BRN ;GET "BLOCK#, REC# WANTED" BIT
JUMPE T1,LBLER4 ;JUMP IF NOT WANTED
TYPE [ASCIZ/ Block #: /]
TYPE [ASCIZ/Record #: /]
TYPE CRLF
;ALL DONE WITH ERROR PRINTING , RETURN TO USER OR GO TO KILL
LBLER4: LDB T1,BP%SEV ;GET SEVERITY
CAIE T1,SV.WRN ;IF WARNING,
CAIN T1,SV.INF ; OR INFORMATIONAL,
JRST @ER.PC ;RETURN TO USER
JRST KILL.## ;FINISH OFF ERROR PROCESSING
SUBTTL ERROR PRINT SUBROUTINES
;ROUTINE TO PRINT TWO DIGITS AND A "."
; T2/ NUMBER TO PRINT
TWODIG: MOVE T1,T2
IDIVI T1,^D10 ;T1=A, T2=B
IFN TOPS20,<
ADDI T1,"0" ;MAKE ASCII CHARACTER
PBOUT%
MOVEI T1,"0"(T2)
PBOUT%
MOVEI T1,"."
PBOUT%
>
IFE TOPS20,<
ADDI T1,"0"
ADDI T2,"0"
OUTCHR T1
OUTCHR T2
OUTCHR ["."] ;OUTPUT A DOT
>
POPJ PP,
;ROUTINE TO PRINT OCTAL NUMBER IN T2
TOCT:
IFN TOPS20,<
MOVEI T3,^D8
MOVEI T1,.PRIOU
NOUT%
JFCL
POPJ PP,
>;END IFN TOPS20
IFE TOPS20,<
IDIVI T2,^D8
HRLM T3,(PP)
SKIPE T2
PUSHJ PP,TOCT
HLRZ T1,(PP) ;GET DIGIT BACK
ADDI T1,"0" ;;MAKE IT ASCII
OUTCHR T1 ;TYPE DIGIT
POPJ PP, ;RECURSE
>;END IFE TOPS20
SUBTTL CHKUSE - CHECK FOR USE PROCEDURE
;CALL: MOVEI T1,UP%XXX ;TYPE OF USE PROCEDURE DESIRED
; PUSHJ PP,CHKUSE
; <HERE IF NO USE PROCEDURE OF THAT TYPE>
; <HERE IF YES, WITH ADDRESS IN T1>
CHKUSE: CAIN T1,UP%ERR ;ERROR USE PROCEDURE?
JRST CHKUS1 ;YES
CAIN T1,UP%OER ;FILENAME OPEN USE PROCEDURE?
JRST CHKUSO ;YES
$ERROR (0,SV.FAT) ;INTERNAL LIBOL ERROR
CHKUS1: LDB T1,FT.RUP ;GET ADDR OF ERROR USE PROCEDURE
JUMPE T1,CHKUS2 ;JUMP IF NONE
LDB T2,FT.UPO ;BUT IF IT WAS FOR OPEN,
JUMPN T2,CHKUS2 ; IT'S NOT THE ONE
AOS (PP) ;SKIP RETURN WITH ADDRESS IN T1
CPOPJ: POPJ PP,
;CHECK FOR GENERAL (NON-FILE SPECIFIC) USE PROCEDURE.
; LOOKS FOR INPUT, OUTPUT, IO, EXTEND DEPENDING ON HOW THE FILE WAS OPENED.
CHKUS2: HRRZ FLG,D.F1(FT) ;GET LIBOL FILE FLAGS
TXNE FLG,LF%INP!LF%OUT ;FILE OPEN?
JRST [MOVEI T1,0 ;ASSUME FOR INPUT
TXNE FLG,LF%OUT ;;OUTPUT?
MOVEI T1,5 ;YES, GET THIS OFFSET
TXNE FLG,LF%IO ;I-O?
MOVEI T1,^D10 ;YES, GET THIS OFFSET
JRST CHKUS3] ;HAVE MAJOR OFFSET
;FILE WAS NOT OPEN
;IF THIS IS AN OPEN STATEMENT, CHECK THE ARGLIST TO SEE
; HOW THE FILE IS BEING OPENED, AND USE THAT KIND OF USE PROCEDURE
MOVE T2,BS.AGL ;TO SEE WHAT KIND OF STATEMENT THIS IS
MOVE T1,(T2) ;GET FIRST WORD IN T1
LDB T1,VB.PTR ;GET VERB TYPE
CAIE T1,V%OPEN ;OPEN?
POPJ PP, ;NO, FILE NOT OPEN NOR BEING OPENED
MOVE T2,(T2) ;GET FIRST WORD IN T2
SETZ T1, ;T1 WILL BE OFFSET
TXNE T2,OPN%IN ;FILE BEING OPENED FOR INPUT?
JRST [TXNE T2,OPN%IO ;YES, I/O ALSO?
MOVEI T1,^D10 ;YES, OPEN I-O
JRST CHKUS3] ;NO, JUST INPUT, USE T1=0
TXNN T2,OPN%OU ;OPEN FOR OUTPUT?
POPJ PP, ;NO, CONFUSION HERE..
MOVEI T1,5 ;GET "OPEN FOR OUTPUT" OFFSET
;FILE WAS OPEN, WE HAVE T1= MAJOR OFFSET INTO USES
CHKUS3: HRRZ T2,USES.## ;GET ADDRESS OF USE TABLE
JUMPE T2,CPOPJ ;NO USE PROCEDURE, RETURN
ADD T2,T1 ;ADD OFFSET
HRRZ T1,(T2) ;GET THE TAG
JUMPE T1,CPOPJ ;NONE, SORRY
AOS (PP) ;GOT ONE, SKIP RETURN WITH ADDR IN T1
POPJ PP, ;RETURN
;Here to check for FILENAME on OPEN error use procedure.
CHKUSO: LDB T1,FT.RUP ;GET ADDR OF ERROR USE PROCEDURE
JUMPE T1,CPOPJ ;JUMP IF NONE
LDB T2,FT.UPO ; MAKE SURE THE "ON OPEN" BIT IS SET
JUMPE T2,CPOPJ ;IT'S NOT THE ONE
AOS (PP) ;GOT IT, SKIP RETURN WITH ADDRESS IN T1
POPJ PP,
SUBTTL RMSERP - TYPE RMS UNEXPECTED ERRORS OUT
;CALLED WITH STS IN P1, STV IN P2
RMSERP: CAMN P1,ER.RBG ;RMS BUG?
POPJ PP, ;YES, RMS ALREADY TYPED INFO
TYPE [ASCIZ/?Unexpected RMS error, STS= /]
MOVE T2,P1 ;TYPE STATUS IN OCTAL
PUSHJ PP,TOCT
TYPE [ASCIZ/, STV= /]
MOVE T2,P2
PUSHJ PP,TOCT
IFN TOPS20,<
;IF STV COULD BE A JSYS ERROR CODE, TYPE IT OUT
CAIL P2,600000
CAILE P2,677777 ;SEE IF WITHIN RANGE
JRST RMSER1 ;NO
TYPE [ASCIZ/,
JSYS error code = '/]
MOVEI T1,.PRIOU ;;TYPE IT
HRRZ T2,P2 ;GET ERROR CODE
HRLI T2,.FHSLF ;MY PROCESS
SETZ T3, ;ALL OF IT
ERSTR% ;TYPE IT
JRST [TYPE [ASCIZ/* Undefined error number */]
JRST .+1]
JFCL ;(IMPOSSIBLE)
MOVEI T1,"'" ;END QUOTE
$TYPT1 ;TYPE IT
>;END IFN TOPS20
RMSER1: TYPE CRLF
POPJ PP,
SUBTTL SETFS - SET FILE STATUS WORD
; This routine is called every time the FILE-STATUS changes, to
;update the user-supplied symbol, if any.
;
;Call: FS.FS/ file status to set (a 2-digit number)
; PUSHJ PP,SETFS
; <return here always>
SETFS: SKIPN T1,F.WPFS(FT) ;GET FILE-STATUS POINTER
POPJ PP, ;DONE IF NO POINTER
MOVE AC0,FS.FS## ;GET FILE-STATUS
PUSH PP,P1 ;SAVE P1
PUSH PP,P2 ;SAVE OTHER PERM ACS
PUSH PP,P3
PUSH PP,P4
PUSH PP,FTL
PUSH PP,FLG
PUSH PP,FT
PUSHJ PP,IGCNVT## ;MOVE IT TO DATA-ITEM
POP PP,FT
POP PP,FLG
POP PP,FTL
POP PP,P4
POP PP,P3
POP PP,P2
POP PP,P1 ;RESTORE P1
POPJ PP, ;DONE, RETURN
SUBTTL SETEFS - SET ERROR FILE-STATUS WORDS
; This routine is called prior to invoking an I/O ERROR USE procedure
;to set up the user-supplied FILE-STATUS items with all the information
;he needs to do intelligent things in the error procedure.
SETEFS: PUSH PP,P1 ;SAVE P1
PUSH PP,P2 ;SAVE OTHER PERM ACS
PUSH PP,P3
PUSH PP,P4
PUSH PP,FTL
PUSH PP,FLG
PUSH PP,FT ;FT IS AT 0(PP)
SKIPN T1,F.WPEN(FT) ; GET ERROR-NUMBER POINTER
JRST SETEF1 ;NO POINTER
PUSHJ PP,SETEN ;SETUP FS.EN
MOVE T1,F.WPEN(FT) ;GET PTR AGAIN
MOVE AC0,FS.EN## ;GET ERROR-NUMBER
PUSHJ PP,IGCNVT## ;MOVE IT TO DATA-ITEM
MOVE FT,(PP) ;GET FT FROM STACK
SKIPN T1,F.WPAC(FT) ; GET ACTION-CODE POINTER
JRST SETEF1 ;DONE IF NO POINTER
SETZM (T1) ;ZERO THE ACTION CODE
SKIPN T2,F.WPID(FT) ;GET VALUE-OF-ID POINTER
JRST SETEF1 ;NO POINTER, DONE
MOVE T1,F.WVID(FT) ;GET REAL VID POINTER
LDB T3,[POINT 2,T1,11] ;GET INPUT BYTE SIZE
LDB T4,[POINT 2,T2,11] ;GET OUTPUT BYTE SIZE
TLZ T2,7700 ;ZERO BYTE FIELD
MOVEI 16,1 ;SETUP PARAMETER WORD
PUSHJ PP,@IGTAB2##-1(T3) ;MOVE IT TO DATA ITEM
MOVE FT,(PP) ;RESTORE FT FROM STACK
SKIPN T1,F.WPBN(FT) ;BLOCK-NUMBER POINTER
JRST SETEF1 ;NONE, RETURN
MOVE T2,FS.BN## ;GET BLOCK-NUMBER
MOVEM T2,(T1) ;MOVE IT TO DATA-ITEM
SKIPN T1,F.WPRN(FT) ;RECORD-NUMBER POINTER
JRST SETEF1 ;NONE, RETURN
MOVE T2,FS.RN##
MOVEM T2,(T1) ;MOVE IT TO DATA-ITEM
SKIPN T2,F.WPFN(FT) ;POINTER TO FILE-NAME
JRST SETEF1 ;NONE
HRRI T1,F.WFNM(FT) ;ADDRESS OF FILE-NAME
HRLI T1,(POINT 6,) ;IN SIXBIT
LDB T4,[POINT 2,T2,11] ;GET OUTPUT BYTE SIZE
TLZ T2,7700 ;ZERO BYTE FIELD
MOVEI 16,1 ;SETUP PARAMETER WORD
PUSHJ PP,@IGTAB4##-1(T4) ;MOVE IT TO DATA-ITEM
MOVE FT,(PP) ;GET FT AGAIN
SKIPN T1,F.WPFT(FT) ;FILE-TABLE PTR WANTED?
JRST SETEF1 ;NO
MOVEM FT,(T1) ;YES, SAVE IT
;DONE-- RESTORE SAVED ACS
SETEF1: POP PP,FT
POP PP,FLG
POP PP,FTL
POP PP,P4
POP PP,P3
POP PP,P2
POP PP,P1 ;RESTORE P1
POPJ PP, ;DONE, RETURN
SUBTTL SETEN - SETUP FS.EN BECAUSE THE USER WANTS IT
;ASSUMES: FT POINTS TO FILE-TABLE OF CURRENT FILE
; BS.AGL IS THE BASE OF THE ARG LIST FOR THIS I/O VERB.
SETEN: ;[M1071]
SETZM FS.EN## ;[1071] ZERO OUT FILE-STATUS ERROR NUMBER
LDB T1,BP%IVB ;IS THIS AN I-O VERB? [M1071]
JUMPE T1,SETEN1 ;NO, ARGLIST IS NOT RELEVANT
MOVE T1,@BS.AGL## ;GET CONTENTS OF BASE OF ARG LIST TO GET VERB
LDB T1,VB.PTR ;GET VERB
MOVE T1,ENADDT(T1) ;GET NUMBER TO ADD
MOVEM T1,FS.EN ;[1017] STORE VERB TYPE
SETEN1: LDB T1,BP%ENO ; GET ERROR MESSAGE NUMBER
SKIPE ER.MCL ;CD=0?
HRRZ T1,ER.HIJ ;NO, GET USER-SUPPLIED NUMBER
ADDM T1,FS.EN ; ADD IT IN
MOVE T1,ER.MCL ;GET CD = MONITOR CALL CODE
IMULI T1,^D100000 ;SHIFT TO PROPER PLACE
ADDM T1,FS.EN ; ADD IT IN
POPJ PP,
SUBTTL GETFTP - GET FILE-TYPE CODE IN T2, ISAM-BLOCK TYPE IN T3
GETFTP: SETZB 2,3 ;FOR AN RMS FILE..
POPJ PP, ;DONE, RETURN
SUBTTL THE ERROR MESSAGES
DEFINE EE(NUM,TEXT),<
ER'NUM: [ASCIZ\TEXT\]
>
;[V12B] STARTING AT ERROR 500
EE 500,<RMS-SYSTEM failure> ;catch-all for many RMS funnies
EE 501,<Attempt to DELETE and file not open for I-O>
EE 502,<Attempt to REWRITE and file not open for I-O>
EE 503,<Not enough free memory to OPEN file>
EE 504,<Another file that shares same area is open>
EE 505,<Attempt to READ and file not open for INPUT or I-O>
EE 506,<Attempt to change secondary key value in RMS file
that does not allow that>
EE 507,<File parameters do not match program parameters>
EE 508,<File not found>
EE 509,<Cannot OPEN file: already open>
EE 510,<Cannot OPEN file: it has been closed with LOCK>
;;;;; ** TEMP MESSAGE UNTIL V13 ** ;;;;;;
EE 511,<Cannot OPEN file in an overlay>
EE 512,<Cannot CLOSE file: it is not open>
EE 513,<Attempt to WRITE and file not open for OUTPUT or I-O>
EE 514,<Attempt to START and file not open for INPUT or I-O>
EE 515,<Attempt to WRITE indexed file seq. access mode
and file not open for OUTPUT>
EE 516,<REWRITE in seq. access file was not immediately proceeded
by a successful READ.>
EE 517,<DELETE in seq. access file was not immediately proceeded
by a successful READ.>
EE 518,<Cannot READ sequentially: file is already AT END>
EE 519,<File is not an RMS indexed file>
EE 520,<File is busy.> ;[1053] CORRECT ERROR MESSAGE
EE 521,<Cannot OPEN file: System protection violation.>
EE 522,<Attempt to change record size on REWRITE.>
EE 523,<Primary key in RMS indexed file allows duplicates;
this is contrary to the COBOL language standard.>
SUBTTL TOPS10 ADDITIONAL ERROR VALUES
IFE TOPS20,<
DEFINE E10(NUM,TEXT),<
ET'NUM: [ASCIZ\TEXT\]
>
E10 0,<Invalid project/programmer number>
E10 1,<Device not available>
E10 2,<No such device>
E10 3,<SFD not found>
>;END IFE TOPS20
END