Trailing-Edge
-
PDP-10 Archives
-
BB-H506E-SM
-
cobol/source/rmsio.mac
There are 20 other files named rmsio.mac in the archive. Click here to see a list.
; UPD ID= 3551 on 5/14/81 at 4:48 PM by WRIGHT
TITLE RMSIO 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.
;EDITS
;NAME DATE COMMENT
;JEH 13-APR-84 [1116] Reset file status before retrying file open
;JEH 18-JUL-83 [1073] Add $ERASE call if CLOSE WITH DELETE
;SMI 14-OCT-82 [1046] Fix CHECKPOINT with RMS files for DELETE, and
; REWRITE.
;JSM 18-OCT-82 [1045] Use $MESSAGE in RMSGET as first RMS-20 call to
; initialize RMS-20 global data symbols.
;RLF 08-OCT-82 [1044] Space fill record area
;RJD 21-APR-82 [1020] Test for CHECKPOINT with RMS files
;RJD 29-APR-82 [1022] Deallocate memory if OPEN fails
SEARCH LBLPRM ;GET LIBOL PARAMETERS
;GET APPROPRIATE SYSTEM SYMBOLS
;Note: The monitor symbol universal files must be searched before
;COMUNI to avoid conflicts with LOAD and STORE macros
IFN TOPS20, SEARCH MONSYM,MACSYM
IFE TOPS20, SEARCH UUOSYM,MACTEN
SEARCH COMUNI ;GET COMMON SYMBOLS, MACROS
SEARCH FTDEFS ;FILE-TABLE DEFINITIONS
SEARCH RMSINT ;AND RMS SYMBOLS
SALL
HISEG
.COPYRIGHT ;Put COPYRIGHT statement in .REL file.
;****** MAGIC NUMBERS FIXED IN NEXT VERSION OF RMSINT ********
BA$OVH==6 ;HEADER WORDS IN A BUCKET
BA$WPU==^D512 ; WORDS PER BUCKET UNIT
;*************************************************************
T0=0
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
;RMS ENTRY POINTS
ENTRY OP.MIX ;OPEN RMS INDEXED FILE
ENTRY CL.MIX ;CLOSE RMS INDEXED FILE
ENTRY WT.MIR ;WRITE- RMS INDEXED RANDOM
ENTRY WT.MIS ;WRITE- RMS INDEXED SEQUENTIAL
ENTRY RD.MIR ;READ- RMS INDEXED RANDOM
ENTRY RD.MIS ;READ- RMS INDEXED SEQUENTIAL
ENTRY DL.MIR ;DELETE RMS INDEXED (RANDOM ACCESS)
ENTRY DL.MIS ;DELETE RMS INDEXED (SEQUENTIAL ACCESS)
ENTRY RW.MIR ;REWRITE- RMS INDEXED (RANDOM ACCESS)
ENTRY RW.MIS ;REWRITE- RMS INDEXED (SEQUENTIAL ACCESS)
ENTRY ST.MEQ ;START- RMS EQUAL
ENTRY ST.MGT ;START- RMS GREATER THAN
ENTRY ST.MNL ;START- RMS NOT LESS THAN
;ROUTINES CALLED BY OTHER PARTS OF LIBOL:
ENTRY RMSGET ;GET RMS IN CORE AND TELL IT WHERE THE CORE MANAGER IS
DEFINE TYPE (ADDR),<
IFN TOPS20,<
HRROI T1,ADDR
PSOUT%
>
IFE TOPS20,<
OUTSTR ADDR
>
>
OPDEF PJRST [JRST]
SUBTTL EXTERNAL ROUTINES AND SYMBOLS
;ROUTINES IN LBLERR:
EXTERN LBLERR ;THE ERROR ROUTINE
EXTERN SETFS ;SET FILE-STATUS FROM FS.FS
EXTERN SETEFS ;SET ERROR-FILE-STATUS VARIABLES
EXTERN CHKUSE ;CHECK FOR USE PROCEDURE
EXTERN RMSERP ;RMS-ERROR REPORT FOR UNEXPECTED ERRORS
;CONVERSION ROUTINES:
EXTERN C.D6D7,C.D7D6,C.D6D9,C.D9D6,C.D7D9,C.D9D7
;IN LILOWS:
EXTERN CVPRM. ;2-WORD BLOCK TO HOLD CONVERSION PARAMETERS
EXTERN FS.ZRO,FS.IF,FS.FS
IFN TOPS20,<
EXTERN ER.JSE ;JSYS ERROR CODE STORED FOR $ERROR PROCESSING
>
IFE TOPS20,<
EXTERN ER.E10 ;TOPS10 ERROR CODE STORED FOR $ERROR PROCESSING
>
EXTERN ER.RBG ;RMS BUG ERROR CODE
SUBTTL DEFINITIONS (SHARED WITH CBLIO)
F.RAD==3 ;FUNCT. FUNCTION TO RETURN CORE AT ADDRESS
F.PAG==15 ;FUNCT. FUNCTION TO GET CORE ON PAGE BOUNDARY
;FLAGS FOR OLD V12B STYLE THINGS, IN F.WFLG
DDMASC==400000 ;DEVICE DATA MODE IS ASCII
DDMEBC==100000 ;DEVICE DATA MODE IS EBCDIC
OPNIN==20000 ;FILE IS OPEN FOR INPUT
OPNOUT==10000 ;FILE IS OPEN FOR OUTPUT
;SOME V12B THINGS THAT WILL BE COMPLETELY DIFFERENT IN V13
FT.BBL: POINT 1,F.WBLC(FT),6 ;FILE IS IN OVERLAY
FT.BLF: POINT 1,D.LF(FT),16 ;LOCKED
FT.MRS: POINT 12,F.WMRS(FT),17 ;MAX RECORD SIZE (CHARACTERS)
FT.PPN: POINT 18,F.RPPN(FT),35 ;ADDRESS OF USER-NUMBER
FT.DIO: POINT 1,F.WDIO(FT),5 ;DEFERRED OUTPUT BIT
FT.CKP: POINT 1,F.CKP(FT),9 ;CHECKPOINT OUTPUT
FT.CRC: POINT 8,F.CRC(FT),17 ;[1020] CHECKPOINT RECORD COUNT
FT.NAB: POINT 6,F.WNAB(FT),5 ;NUMBER OF ALTERNATE BUFFERS
;FOR CALLS TO CHKUSE:
UP%ERR==0 ;CHECK FOR ERROR USE PROCEDURE
UP%OER==1 ;FILENAME OPEN USE PROCEDURE
IFE TOPS20,<
;PAGE THAT RMS USES FOR ITS GLOBAL STORAGE
.RGLBP==572 ;AND THE NEXT ONE, TOO..
>;END IFE TOPS20
;RANDOM FLAG DEFINITIONS THAT FOR V13 WILL BE DEFINED IN FTDEFS
CF%CNV==1B18 ;CONVERSION REQUIRED
LF%FNA==1B32 ;FILENAME IS IN ASCII
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)
SUBTTL PROTOTYPE RMS STRUCTURES
;HA HA THE RMS PEOPLE MADE THIS NECESSARY.
;PROTOTYPE FAB:
PRFAB: FAB$B
FAB$E
PRFABL==.-PRFAB ;LENGTH OF PROTOTYPE FAB
;PROTOTYPE RAB:
PRRAB: RAB$B
RAB$E
PRRABL==.-PRRAB ;LENGTH OF PROTOTYPE RAB
;PROTOTYPE XAB:
PRXAB: XAB$B KEY
X$FLG XB$CHG ;DEFAULT IS TO ALLOW KEYS TO CHANGE
XAB$E
PRXABL==.-PRXAB ;LENGTH OF PROTOTYPE XAB
SUBTTL SETIO - ROUTINE TO SETUP FOR I/O
;CALLED BY EVERY I/O ENTRY POINT
SETIO: MOVEM ARG,BS.AGL## ;SAVE BASE OF ARG LIST
HRRZ FT,(ARG) ;GET FILE-TABLE ADDRESS
HLLZ FLG,(ARG) ;GET ARG-LIST FLAGS
SKIPE FTL,D.RMSP(FT) ;GET LIBOL FILE-TABLE ADDRESS
;IF THIS IS AN OPEN, IT WILL SKIP UNLESS
; THE FILE IS ALREADY OPEN. ALL OTHER
; VERBS WILL NOT SKIP HERE.
HRR FLG,D.F1(FT) ;GET LIBOL FILE FLAGS
;ZERO THE ERROR STATUS WORDS
MOVE T1,[FS.ZRO,,FS.FS] ;ZERO THE ERROR STATUS WORDS
BLT T1,FS.IF
POPJ PP, ;RETURN
SUBTTL RMSGET - GET RMS, AND SET IT UP
;THIS ROUTINE WILL ONLY BE USED FOR LIBOL 12B. V13 DOESN'T NEED
; ANY SUCH THING.
;CALL: PUSHJ PP,RMSGET
; <RETURN HERE>, OR IF ERRORS, GO TO KILL
; USES AC1-AC4
IFN TOPS20,<
RMSNMP: POINT 7,[ASCIZ/SYS:RMSCOB.EXE/] ;SPECIAL EXE FILE FOR RMS
>;END IFN TOPS20
IFE TOPS20,<
RMSNMP: SIXBIT /SYS/
SIXBIT /RMSCOB/
SIXBIT /EXE/
0
0 ;PROJ,,PROG
RMS.FP,,RMS.LP ;WHICH PAGES OF RMSCOB.EXE TO MERGE
>;END IFE TOPS20
RMSGET: MOVEI T1,ER$BUG ;GET RMS "BUG" ERROR CODE
MOVEM T1,ER.RBG ;TELL LBLERR
IFN TOPS20,<
SKIPE SLRSW.## ;WAS PROGRAM COMPILED WITH /R?
JRST RMSGSR ;YES, JUST FIND ENTRY VECTOR
MOVX T1,GJ%OLD!GJ%SHT
MOVE T2,RMSNMP
GTJFN%
ERJMP RGETE1 ;?NO RMS
PUSH PP,T1 ;SAVE THE JFN
MOVEI T1,.FHSLF ;SAVE ENTRY VECTOR INFO
GEVEC% ; (GET% SMASHES IT)
PUSH PP,T2 ;SAVE THE INFO
MOVE T1,-1(PP) ;GET BACK JFN
HRLI T1,.FHSLF ;READ INTO SAME FORK
TXO T1,GT%NOV ;DON'T OVERLAY EXISTING PAGES!
GET%
ERJMP RGETE2 ;FAILED
MOVEI T1,.FHSLF ;GET RMS'S ENTRY VECTOR
GEVEC%
MOVE T4,T2 ;SAVE IN T4
POP PP,T2 ;ENTRY VECTOR INFO
MOVEI T1,.FHSLF
SEVEC% ;SET IT BACK TO WHAT IT WAS
POP PP,(PP) ;FORGET JFN, DON'T CARE ANYMORE
;TELL SYSTEM THAT WE HAVE AN RMS ENTRY VECTOR
SKIPA T2,T4 ;ENTRY VECTOR WORD
RMSGSR: MOVE T2,[RMS.EV##] ;GET RMS'S ENTRY VECTOR WORD
JUMPE T2,RSBADV ;BAD ENTRY VECTOR
HRRZ T1,T2 ;Get address of start of entry vector
MOVE T1,2(T1) ;Get version number word
MOVEM T1,RMSVR.## ;Save it incase LIBOL wants to print it
MOVEI T1,.FHSLF ;SET MY FORK'S
SDVEC% ;RMS ENTRY VECTOR
;DISABLE TRAPS FOR REFS OF NON-EX PAGE
; SO PA1050 DOESN'T BOMB OUT RMS
MOVEI T1,.FHSLF
MOVX T2,1B<.ICNXP>
DIC%
$MESSAGE ;[1045] TURN ON RMS-20 INTERNAL MESSAGE
;[1045] REPORTING AND ALSO INITIALIZE THE
;[1045] AREA FOR RMS-20 GLOBAL DATA SYMBOLS.
POPJ PP, ;RETURN
>;END IFN TOPS20
IFE TOPS20,<
;TOPS10 - READ IN RMS
SKIPE SLRSW.## ;SKIP IF NOT /R
POPJ PP, ;EVERYTHING TAKEN CARE OF
;SAVE ACS OVER MERGE. UUO CALL
MOVE T1,[T1,,ACSAV0##]
BLT T1,ACSAV0+16 ;SAVE ACS THRU PP
;See if RMS is already part of the OTS
MOVE T1,[.PAGCA,,RMS.FP]
PAGE. T1, ;Get access info for page
HALT ;Should never fail
JUMPL T1,RMSMRG ;Does not exist yet
MOVE T1,RMS.FP*1000+.JBHNM
CAMN T1,['RMSCOB'] ;Is it what we expected?
JRST RMSGOT ;Yes, we already have RMS
RMSMRG: MOVEI T1,RMSNMP ;POINT TO NAME BLOCK
MERGE. T1, ;MERGE IN RMS
HALT . ;TYPE MONITOR ERROR MESSAGE AND DIE
RMSGOT: MOVE T1,[ACSAV0,,T1]
BLT T1,PP ;RESTORE ACS
;Save version number of RMS for LIBOL error printing
HLRZ T1,RMSNMP+5 ;Get starting page number
LSH T1,^D9 ;Shift to make address
MOVE T1,4(T1) ;Get version number from EXE file
MOVEM T1,RMSVR.## ;Save RMS version number
;DO THE PAGE. UUO TO CREATE THE PAGES THAT RMS NEEDS
MOVE T1,[.PAGCD,,[EXP 2
EXP .RGLBP
EXP .RGLBP+1]]
PAGE. T1, ;CREATE THE PAGES FOR RMS GLOBAL STORAGE
JRST PGUFAI ;;FAILED, GO COMPLAIN
POPJ PP, ;ALL OK, RETURN
PGUFAI: TYPE [ASCIZ/?PAGE. UUO FAILED -- CANNOT SET UP RMS STORAGE
/]
JRST KILL.## ;GO BOMB OUT PROGRAM
>;END IFE TOPS20
;STORE POINTER TO THIS BLOCK IN RMS ENTRY VECTOR
;RSEBLK: EXP FUNCT.## ;ADDRESS OF FUNCT. ROUTINE
;ERRORS GETTING RMS
IFN TOPS20,<
;GTJFN FAILED
RGETE1: TYPE [ASCIZ/? /]
HRRZ T1,RMSNMP ;GET NAME
TYPE <(T1)> ;TYPE IT
TYPE [ASCIZ/ is not accessible/]
JRST RSFAIL ;SAY "RMS-SYSTEM FAILURE"
;THE "GET" FAILED
RGETE2: TYPE [ASCIZ/? /]
POP PP,(PP) ;FORGET ENTRY VECTOR INFO
MOVEI T1,.FHSLF ;GET THE ERROR
GETER%
CAMN T2,[.FHSLF,,GETX3] ;TRYNG TO OVERLAY EXISTING PAGES?
JRST RGETE3 ;YES
TYPE [ASCIZ/Can't GET /]
HRRZ T1,RMSNMP ;GET ADDR OF THE ASCIZ NAME
TYPE <(T1)> ;TYPE NAME
TYPE [ASCIZ/: /]
PUSHJ PP,LSTFER ;TYPE LAST ERROR IN THIS FORK
RSFAIL: $ERROR (E.500,SV.KIL) ;RMS-SYSTEM FAILURE
RGETE3: TYPE [ASCIZ/?Can't GET RMS: Program too big/]
JRST RSFAIL ;RMS-SYSTEM FAILURE ERROR
RSBADV: TYPE [ASCIZ/RMS entry vector is invalid -- RMS not loaded?/]
JRST RSFAIL ;GO DIE OFF
>;END IFN TOPS20
IFN TOPS20,<
SUBTTL LSTFER - ROUTINE TO TYPE LAST ERROR IN THIS FORK
;CALL: PUSHJ PP,LSTFER
; <RETURN HERE ALWAYS>
LSTFER: MOVEI T1,.PRIOU ;OUTPUT TO TERMINAL
HRLOI T2,.FHSLF ;LAST ERROR IN THIS FORK
SETZ T3, ;ALL OF THE TEXT
ERSTR%
JFCL
JFCL
POPJ PP, ;RETURN
>;END IFN TOPS20
;SAVE AC ROUTINE.
;THIS SAVES ALL THE IMPORTANT ACS USED BY RMSIO.
SVPACS: EXCH P1,(PP) ;SAVE P1,GET CALLER PC
HRLI P1,(PP) ;GET ADDRESS WHERE P1 IS SAVED
PUSH PP,FLG ;SAVE FLAGS
PUSH PP,FT ;SAVE FILE-TABLE PTR
PUSH PP,FTL ;SAVE OTHER FILE-TABLE PTR
PUSHJ PP,SAVJMP ;STACK NEW RETURN PC AND JUMP
SOS -4(PP) ;NON-SKIP RETURN, COMPENSATE CPOPJ1
POP PP,FTL ;RESTORE FTL
POP PP,FT ;RESTORE FT
POP PP,FLG ;RESTORE FLG
POP PP,P1 ;RESTORE P1
AOS (PP) ;INCREMENT PC
POPJ PP, ;RETURN
;THE FOLLOWING INSTRUCTION RESTORES P1 AND DISPATCHES TO THE CALLER.
SAVJMP: JRA P1,(P1) ;RETURN TO CALLER
SUBTTL OP.MIX -- OPEN RMS INDEXED FILE
;CALL:
; MOVEI 16,ARGLIST
; PUSHJ PP,OP.MIX
; <RETURN>
;ARGUMENT FORMAT:
;
;ARGLIST: FLAG-BITS,,FILTAB-ADDR
; 0,,ADDR-OF-KEY-INFO
;
;FLAG-BITS:
OPN%IN==1B9 ;OPEN FOR INPUT
OPN%OU==1B10 ;OPEN FOR OUTPUT
OPN%IO==1B11 ;OPEN FOR I-O
; ALL BITS 9-11 ON FOR OPEN I-O
;NO REWIND, OPEN EXTEND, OPEN REVERSED NOT SUPPORTED
;KEY INFORMATION:
; OCT NUMBER OF KEYS
; (2 WORDS FOR EACH KEY, AS FOLLOWS):
; XWD BYTE POSITION,,KEY SIZE
; XWD FLAGS,,DATATYPE
;
; WHERE FLAGS ARE:
KI%DUP==1B0 ;DUPLICATE KEYS ALLOWED
;
;AND DATATYPE VALUES ARE:
; SIXBIT=0, ASCII=1, EBCDIC=2
;NO REWIND, OPEN EXTEND, OPEN REVERSED NOT SUPPORTED.
OP.MIX: PUSHJ PP,SETIO ;SETUP FOR I/O
LDB T0,FT.CRC ;[1020] IS THERE CHECKPOINTING?
JUMPE T0,.+2 ;[1020] NO
MOVEM T0,D.CRC(FT) ;[1020] YES, INITIALIZE RECORD COUNT
;CAN'T OPEN FILE FROM OVERLAY
LDB T1,FT.BBL
JUMPE T1,OPEOVL
;CAN'T OPEN FILE IF ALREADY OPEN
TXNE FLG,LF%INP!LF%OUT ;IS THE FILE OPEN?
JRST OPEALO ;YES, ERROR
;CAN'T OPEN FILE IF IT IS "LOCKED"
LDB T1,FT.BLF
JUMPN T1,OPELCK
;FALL TO NEXT PAGE IF EVERYTHING OK SO FAR
;CHECK FOR FILES THAT SHARE THE SAME BUFFER. NONE OF THEM
; MAY BE OPEN AT THIS POINT.
HLRZ T4,F.LSBA(FT) ;FILTAB THAT SHARES THE SAME BUFFER
OP.M0A: JUMPE T4,OP.MX0 ;JUMP IF NO ONE SHARES
CAIN T4,(FT) ;HAVE WE CHECKED ALL "SBA" FILES?
JRST OP.MX0 ;YES
LDB T1,[POINT 1,F.RMS(T4),7] ;RMS BIT FOR THIS FILE
JUMPN T1,OP.SA1 ; JUMP IF THIS SBA FILE IS AN RMS FILE
; NON-RMS, V12B FILES:
HLL T4,F.WFLG(T4) ;GET THE FLAGS
TLNE T4,OPNIN!OPNOUT ;SKIP IF ANY FILES ARE NOT OPEN
JRST OP.M0B ;GIVE ERROR
JRST OP.SA2
; END OF NON-RMS, V12B FILES
; RMS FILES ONLY FOR V12B, THIS CODE WILL BE VALID FOR ALL V13 FILES
OP.SA1: HRR T1,D.F1(T4) ;GET V13 STYLE FLAGS FOR THIS FILE
TXNE T1,LF%INP!LF%OUT ;IS THIS FILE OPEN?
JRST OP.M0B ;YES, GIVE ERROR
; END OF RMS CODE
OP.SA2: HLRZ T4,F.LSBA(T4) ;GET NEXT "SBA" FILTAB
JRST OP.M0A ;LOOP
;** ERROR: ANOTHER FILE THAT SHARES THE SAME BUFFER IS ALREADY OPEN
OP.M0B: $ERROR (E.504,SV.KIL,MT.FIL)
;** ERROR: FILE CANNOT BE OPENED: ALREADY OPEN
OPEALO: $ERROR (E.509,SV.KIL,MT.FIL)
;** ERROR: FILE IS LOCKED
OPELCK: $ERROR (E.510,SV.KIL,MT.FIL)
;** ERROR: CAN'T OPEN FILE IN OVERLAY (TEMP ERROR)
OPEOVL: $ERROR (E.511,SV.KIL,MT.FIL)
;HERE IF OPEN IS GOING OK SO FAR.
;SEE IF CONVERSION REQUIRED. IF YES, SET UP AN ALTERNATE RECORD
; AREA AND KEY BUFFER.
;NOTE: FROM HERE UNTIL AFTER FUNCT. IS CALLED,
; WE WILL USE TEMPORARY VARIABLES ON THE STACK.
; 0(PP) = # WORDS NEEDED FOR CONVERSION RECORD BUFFER
; -1(PP) = # WORDS NEEDED FOR CONVERSION KEY BUFFER
OP.MX0: PUSH PP,[0] ; SET # WORDS NEEDED FOR CONVERSION
PUSH PP,[0] ; BUFFERS
MOVE T3,F.WFLG(FT) ;GET FLAGS
;** CHANGE IN V13:
LDB T1,[POINT 3,T3,14] ;GET INTERNAL RECORDING MODE
LDB T2,[POINT 3,T3,2] ;GET EXTERNAL RECORDING MODE
CAMN T1,T2 ;THE SAME?
JRST OP.M0C ;YES
;Conversion is required.
; Find the size of the largest key, and reserve some words
;for the conversion key buffer.
; Then reserve as many words as we need to store the converted record.
MOVX T1,CF%CNV ;NOTE "CONVERSION REQUIRED"
IORM T1,D.F1(FT)
TXO FLG,CF%CNV ;NOTE CONVERSION REQUIRED
;SET T4= # BYTES/WORD FOR THIS RECORDING MODE
MOVE T3,F.WFLG(FT) ;GET COMPILER FLAGS
MOVEI T4,6 ; ASSUME SIX BYTES PER WORD
TLNE T3,DDMASC ; IS IT ASCII?
MOVEI T4,5 ;YES, FIVE BYTES PER WORD
TLNE T3,DDMEBC ; IS IT EBCDIC?
MOVEI T4,4 ;YES, FOUR BYTES PER WORD
;FIND T1=SIZE OF LARGEST KEY
HRRZ T3,BS.AGL ;LOOK AT THE KEY INFO
HRRZ T3,1(T3) ;SO WE CAN FIND THE LARGEST KEY
MOVE T2,(T3) ;T2= NUMBER OF KEYS
ADDI T3,1 ;T3 POINTS TO FIRST 2-WORD KEY BLOCK
SETZ T1, ;ANYTHING IS BIGGER THAN THIS
OP.M0E: HRRZ T0,(T3) ;GET SIZE OF THIS KEY
CAILE T0,(T1) ;SKIP IF NO BIGGER THAN ANOTHER KEY
HRRZ T1,T0 ;USE THIS ONE
ADDI T3,2 ;BUMP UP TO NEXT KEY INFO BLOCK
SOJG T2,OP.M0E ;LOOP FOR ALL KEYS
ADDI T1,-1(T4) ;FIND # WORDS NEEDED
IDIV T1,T4
MOVEM T1,-1(PP) ;STORE ON THE STACK
;GET T1= # WORDS NEEDED FOR THE RECORD
LDB T1,FT.MRS ;GET MAX RECORD SIZE
ADDI T1,-1(T4)
IDIV T1,T4 ;GET # WORDS NEEDED
MOVEM T1,0(PP) ;STORE ON THE STACK
;GET CORE FOR RMS-TYPE BLOCKS: FAB, RAB, AND KEY XAB'S.
; GET T1:= # WORDS NEEDED, STORE IN FUN.A2
OP.M0C: MOVEI T1,.RCLEN ;NEED A CONTROL-BLOCK
ADDI T1,FA$LNG ; AND A FAB
ADDI T1,RA$LNG ; AND A RAB
;FIND # OF KEYS, PUT IN T2
HRRZ T3,BS.AGL ;LOOK AT BASE OF ARG LIST
HRRZ T3,1(T3) ;GET ADDR OF KEY INFO
MOVE T2,(T3) ;FIRST WORD = # OF KEYS
IMULI T2,XA$LNG ; NEED THIS MANY WORDS FOR EACH KEY
ADD T1,T2 ;ADD TO NUMBER OF WORDS NEEDED
ADD T1,(PP) ;ADD NUMBER OF WORDS NEEDED FOR
ADD T1,-1(PP) ; CONVERSION BUFFERS
MOVEM T1,FUN.A2 ;** STORE # WORDS NEEDED **
MOVEI ARG,1+[-5,,0
XWD 0,FUN.A0##
XWD 0,[ASCIZ/LBL/]
XWD 0,FUN.ST##
XWD 0,FUN.A1##
XWD 0,FUN.A2##]
MOVEI T1,F.PAG ;FUNCTION WE WANT
MOVEM T1,FUN.A0## ;STORE FUNCTION
SETZM FUN.ST## ;CLEAR STATUS
SETZM FUN.A1## ; AND ADDRESS RETURNED
PUSHJ PP,FUNCT.## ;CALL FUNCT. ROUTINE
POP PP,T4 ;RESTORE # WORDS USED FOR CONVERSION BUFFERS
POP PP,T3 ;KEY BUFFER
SKIPE FUN.ST## ;STATUS MUST BE 0...
JRST MNCR ; ? NOPE - NO CORE AVAILABLE
;STORE POINTER TO CONTROL-BLOCK IN THE FILE-TABLE
HRRZ FTL,FUN.A1## ;GET ADDRESS OF CORE WE GOT
MOVEM FTL,D.RMSP(FT) ; SAVE ADDR OF RMS CONTROL-BLOCK
;FTL:= ADDR OF CONTROL BLOCK.
;STORE # WORDS OF MEMORY WE JUST OBTAINED IN THE CONTROL BLOCK
MOVE T1,FUN.A2## ;(IT'S STILL HERE)
MOVEM T1,.RCMEM(FTL)
; STORE ADDR OF FAB, RAB, AND FIRST XAB IN THE CONTROL BLOCK
MOVEI T1,.RCLEN(FTL) ;ADDR OF FAB
MOVEM T1,.RCFAB(FTL) ;STORE ADDR OF FAB
ADDI T1,FA$LNG
MOVEM T1,.RCRAB(FTL) ;ADDR OF THE RAB
ADDI T1,RA$LNG
TXNN FLG,CF%CNV ;SKIP IF CONVERSION REQUIRED
JRST OP.M0D ;NO
MOVEM T1,.RCCRB(FTL) ;CONVERSION RECORD BUFFER
ADD T1,T4 ;ADD # WORDS NEEDED FOR RECORD BUFFER
MOVEM T1,.RCCKB(FTL) ;CONVERSION KEY BUFFER
ADD T1,T3 ;ADD # WORDS NEEDED FOR KEY BUFFER
;MAKING SURE TO PRESERVE T1 FOR OP.M0D, WE WILL NOW
; GET THE ADDRESSES OF THE CONVERSION ROUTINES, AND STORE THEM
; IN .RCCRS:
MOVE T0,F.WFLG(FT) ;GET COMPILER FLAGS
LDB T2,[POINT 2,T0,14] ;INTERNAL RECORDING MODE..
LDB T3,[POINT 2,T0,2] ;EXTERNAL RECORDING MODE..
XCT GETCRF(T2) ;GET "FROM" ROUTINE
HRLM T4,.RCCRS(FTL) ;STORE IN LH(.RCCRS)
EXCH T2,T3 ;NOW GET THE REVERSE ROUTINE
XCT GETCRF(T2)
HRRM T4,.RCCRS(FTL) ;STORE IN RH(.RCCRS)
JRST OP.M0D ;GO ON
;XCT TABLE
GETCRF: HRRZ T4,CV.A(T3) ;GET ASCII TO .. ROUTINE
HRRZ T4,CV.E(T3) ;GET EBCDIC TO.. ROUTINE
HRRZ T4,CV.S(T3) ;GET SIXBIT TO.. ROUTINE
;CONVERSION TABLES.
CV.A: 0 ;7-7 NO CONVERSION
C.D7D9 ;7-9
C.D7D6 ;7-6
CV.E: C.D9D7 ;9-7
0 ;9-9 NO CONVERSION
C.D9D6 ;9-6
CV.S: C.D6D7 ;6-7
C.D6D9 ;6-9
0 ;6-6 NO CONVERSION
;COME HERE IF FUNCT. FAILED TRYING TO GET CORE FOR THE OPEN
MNCR: MOVEI T1,^D30 ;SET FILE-STATUS TO
MOVEM T1,FS.FS ; "PERMANENT ERROR"
PUSHJ PP,SETFS
$ERROR (E.503,SV.FAT,MT.FIL,MNCR1) ;NOT ENOUGH CORE TO OPEN FILE
;ERROR HAS BEEN TRAPPED BY THE USER, NOW HE WANTS TO "IGNORE" IT
MNCR1: POPJ PP, ;** RETURN FROM OPEN **
;Come here with T1 = address where we will put the first XAB.
; Conversion buffers have been allocated if necessary.
OP.M0D: MOVEM T1,.RCXAB(FTL) ;ADDR OF THE FIRST XAB
;Now setup the RMS structures. (the assigned space is
;empty at this point).
;Start with the prototypes.
HRLZI T1,PRFAB ;FROM PROTOTYPE FAB
HRR T1,.RCFAB(FTL) ; TO REAL FAB
HRRZI T2,PRFABL-1(T1) ;COPY ALL OF PROTOTYPE
BLT T1,(T2)
HRLZI T1,PRRAB ;FROM PROTOTYPE RAB
HRR T1,.RCRAB(FTL) ; TO REAL RAB
HRRZI T2,PRRABL-1(T1) ;COPY ALL OF PROTOTYPE
BLT T1,(T2)
;MAKE RAB POINT TO THE FAB.
MOVE T3,.RCRAB(FTL) ;T3 POINTS TO RAB
MOVE T1,.RCFAB(FTL) ;T1 POINTS TO FAB
$STORE T1,FAB,(T3)
;STORE INFO INTO THE XAB'S.
HRRZ T3,BS.AGL ;LOOK AT BASE OF ARG LIST
HRRZ T3,1(T3) ;GET ADDR OF KEY INFO
MOVEM T3,.RCKIN(FTL) ;SAVE IT FOR OTHER OPERATIONS
MOVE T4,(T3) ;T4:= FIRST WORD = # OF KEYS
MOVN T4,T4 ;GET -N
HRLZ T4,T4 ;GET -N,,0
MOVE T2,.RCXAB(FTL) ;T2= ADDR OF FIRST XAB
ADDI T3,1 ;T3 POINTS TO FIRST 2-WORD KEY BLOCK
;HERE WITH T2= ADDRESS OF XAB
; RH(T4)= NUMBER OF THIS KEY
; T3= ADDRESS OF THIS KEY BLOCK
OP.MX1: HRLZI T1,PRXAB ;COPY A PROTOTYPE XAB
HRR T1,T2
BLT T1,PRXABL-1(T2) ;COPY WHOLE PROTOTYPE
HRRZ T1,T4 ;;THE NUMBER OF THIS KEY
$STORE T1,REF,(T2) ;STORE IN REF FIELD
TXNE FLG,OPN%IN ;IF OPEN FOR INPUT OR I/O
JRST OP.MX3 ;DON'T HAVE TO SET IT UP
HLRZ T1,(T3) ;GET POSITION OF THE KEY
$STORE T1,POS,(T2) ;STORE IN XAB
HRRZ T1,(T3) ;GET SIZE OF THE KEY
$STORE T1,SIZ,(T2) ;STORE IN XAB
;
; THE DATATYPE PASSED IN THE KEY BUFFER IS NOT USED. IT IS ASSUMED
; TO BE THE SAME AS THE INTERNAL RECORDING MODE. WE WILL TELL RMS
; THAT THE DATATYPE IS THE SAME AS THE EXTERNAL RECORDING MODE.
MOVE T0,F.WFLG(FT) ;GET COMPILER FT FLAGS
MOVEI T1,XB$SIX ;ASSUME SIXBIT
TLNE T0,DDMASC ; IF ASCII,
MOVEI T1,XB$STG ;GET ASCII DATATYPE
TLNE T0,DDMEBC ; IF EBCDIC,
MOVEI T1,XB$EBC ;GET EBCDIC DATATYPE
$STORE T1,DTP,(T2) ;STORE IN XAB
;STORE KEY-SPECIFIC FLAGS
$FETCH T1,FLG,(T2) ;GET INITIAL FLAGS
PUSH PP,T2 ;SAVE AN AC FOR A SEC..
HLLZ T2,1(T3) ;GET FLAGS FOR THIS KEY
TXNE T2,KI%DUP ;DUPLICATES ALLOWED?
TXO T1,XB$DUP ; YES, SET FLAG
POP PP,T2 ;RESTORE T2
$STORE T1,FLG,(T2) ;STORE THE FLAGS
OP.MX3: AOBJP T4,OP.MX2 ;JUMP IF NO MORE KEYS
ADDI T3,2 ;BUMP TO NEXT KEY INFO BLOCK
MOVEI T1,XA$LNG(T2) ;ADDR OF NEXT XAB
$STORE T1,NXT,(T2) ;STORE IN THIS XAB
MOVE T2,T1 ;GO BACK WITH T2= NEXT XAB
JRST OP.MX1 ;LOOP FOR ALL KEYS
;HERE WHEN ALL KEY XAB'S HAVE BEEN CREATED
OP.MX2: MOVE T2,.RCXAB(FTL) ;T2 POINTS TO FIRST XAB
$FETCH T1,FLG,(T2) ;GET THE FLAGS
TXZ T1,XB$CHG ; VALUES MAY NOT CHANGE FOR PRIMARY KEY
$STORE T1,FLG,(T2) ; (THIS GETS RID OF DEFAULT XB$CHG)
;*** SETUP THE FAB ***
; MOST OF THE INFORMATION IS IN THE NORMAL FILE-TABLE.
MOVE T4,.RCFAB(FTL) ;T4 POINTS TO THE FAB
;FILE ACCESS DESIRED
SETZ T1, ;T1 WILL LIST THE OPERATIONS WE WANT TO DO
;IF OPEN FOR INPUT, NO BITS WILL BE SET IN "FAC".
TXNE FLG,OPN%OU ;OPEN FOR OUTPUT?
TXO T1,FB$PUT ;"PUT" ACCESS
TXNE FLG,OPN%IO ;OPEN FOR I-O?
TXO T1,FB$DEL!FB$UPD ;YES, ALSO ALLOW 'DELETE' AND 'UPDATE'
$STORE T1,FAC,(T4) ;STORE ACCESS WANTED
;OTHERS ACCESS
SETZ T1, ;ALWAYS SET TO 0 FOR V12B
$STORE T1,SHR,(T4) ;STORE OTHERS ACCESS
;FILE NAME
; RMS WANTS THIS IN ASCIZ.
PUSHJ PP,PICKFN ;CONVERT VALUE-OF-ID TO RMS FILENAME
JRST RFNFER ;ERROR, GO RECOVER FROM FNF ERROR
TXO FLG,LF%FNA ;"FILENAME IS OK TO TYPE NOW"
HRRM FLG,D.F1(FT) ; REMEMBER THAT
MOVE T4,.RCFAB(FTL) ;GET PTR TO FAB AGAIN
;FILE ORGANIZATION
; THIS IS RETURNED TO US IF OPEN FOR INPUT OR I/O
MOVEI T1,FB$IDX ;*** WE ONLY DO INDEXED FILES FOR NOW
$STORE T1,ORG,(T4)
;*** RECORD ATTRIBUTES -- ALL ZERO FOR INDEXED FILES ***
;FILE OPTIONS
LDB T1,FT.DIO ;DEFERRED WRITE
SKIPE T1 ;SKIP IF USER DIDN'T SPECIFY "DEFERRED WRITE"
MOVEI T1,FB$DFW ; SET THE BIT
$STORE T1,FOP,(T4) ;IN "FILE-OPTIONS"
;XAB ADDRESS
MOVE T1,.RCXAB(FTL)
$STORE T1,XAB,(T4)
; ** Leave maximum record size (MRS) at zero **
; This allows a file to be created and then later
; the record size increased.
;BYTE SIZE
MOVE T0,F.WFLG(FT) ;GET COMPILER FLAGS
LDB T1,[POINT 2,T0,2] ;GET DEVICE DATA MODE
MOVE T2,[7
9
6](T1) ;GET BYTE SIZE DEPENDING ON MODE
$STORE T2,BSZ,(T4)
;T1 STILL CONTAINS THE MODE..
;BUCKET SIZE
MOVE T2,[5
4
6](T1) ;GET BYTES/WORD DEPENDING ON MODE
LDB T1,FT.MRS ;GET MAXIMUM RECORD SIZE
IDIV T1,T2 ;GET T1=# WORDS, T2=REMAINDER
SKIPE T2 ;ROUND UP
ADDI T1,1
ADDI T1,BA$OVH ;# HEADER WORDS PER BUCKET
IDIVI T1,BA$WPU ;GET # BUCKET UNITS NEEDED
SKIPE T2
ADDI T1,1 ;ROUND UP
$STORE T1,BKS,(T4)
;SPACE FILL THE RECORD AREA
MOVE T0,F.WFLG(FT) ;[1044] GET FLAGS
LDB T3,[POINT 2,T0,2]
MOVE T2,[5
4
6](T3) ;[1044] BYTE/WORD IN T2
LDB T1,FT.MRS ;[1044] MAX RECORD SIZE
IDIV T1,T2 ;[1044] # OF WORDS
SKIPE T2 ;[1044] ROUND UP IF
ADDI T1,1 ;[1044] ANY REMAINDER
LDB T3,[POINT 2,T0,14];[1044] INTERNAL DATA MODE
MOVE T0,SPCTLE(T3) ;[1044] GET SPACE
MOVE T2,F.RREC(FT) ;[1044] GET RECORD PTR
MOVEM T0,(T2) ;[1044] FILL FIRST LOC WITH SPACE
HRLI T0,(T2) ;[1044] THE FROM ADR
HRRI T0,1(T2) ;[1044] THE TO ADR
ADDI T1,-1(T2) ;[1044] THE UNTIL ADR
BLT T0,(T1) ;[1044] FILL WITH SPACES
MOVE T0,F.WFLG(FT) ;[1066] RESTORE SWITCH AC.
;RECORD FORMAT
MOVEI T1,FB$VAR ;VARIABLE LENGTH FORMAT
$STORE T1,RFM,(T4)
;SETUP SOME THINGS IN THE RAB, SINCE WE KNOW WHERE THE RECORD IS.
MOVE T2,.RCRAB(FTL) ;POINT TO THE RAB
HRRZ T1,F.RREC(FT) ;POINT TO RECORD
TXNE FLG,CF%CNV ;IF CONVERSION REQUIRED,
HRRZ T1,.RCCRB(FTL) ;POINT TO CONVERTED RECORD BUFFER
$STORE T1,UBF,(T2) ;TELL RMS WHERE RECORD AREA IS
$STORE T1,RBF,(T2) ;. .
HRRZ T1,.RCCKB(FTL) ;GET KEY BUFFER IF CONVERSION REQUIRED.
TXNE FLG,CF%CNV ;IF WE MADE A KEY BUFFER ADDRESS,
$STORE T1,KBF,(T2) ;TELL RMS WHERE IT IS
;TELL RMS HOW MANY BUFFERS IT WILL NEED (1 PAGE EACH).
; WE WILL LET IT USE 1 BUFFER FOR EACH KEY, PLUS THREE.
; (ASK ANWAR FOR DETAILS)
;FIND # OF KEYS
HRRZ T3,BS.AGL ;BASE OF ARG LIST
HRRZ T3,1(T3) ;GET ADDRESS OF KEY INFO
MOVE T1,(T3) ;T1:=FIRST WORD = # OF KEYS
ADDI T1,3 ;GET # KEYS + 3
LDB T3,FT.NAB ; GET NUMBER HE SPECIFIED
JUMPE T3,ORABS1 ;JUMP IF HE DIDN'T SPECIFY ANY
;IN COBOL-74, HE HAS SPECIFIED THE ABSOLUTE # OF BUFFERS
; (IN COBOL-68, THIS IS # ALTERNATE (ADDITIONAL) BUFFERS)
MOVEI T1,0 ;WE MIGHT HAVE TO LET RMS DECIDE
CAIN T3,77 ;DID HE SAY A NUMBER LESS THAN 1?
JRST ORABS1 ;YES, LET RMS DECIDE
CAIL T3,3 ;MUST BE AT LEAST THREE
MOVE T1,T3 ;OK, USE THE NUMBER HE SPECIFIED
ORABS1: $STORE T1,MBF,(T2) ;TELL RMS
;SETUP BYTE PTR TO THE USER'S RECORD IN THE RMS CONTROL BLOCK.
; (THIS WILL DEFINITELY BE NEEDED FOR CONVERSION, AT LEAST).
HRRZ T1,F.RREC(FT) ;POINT TO RECORD
MOVE T2,F.WFLG(FT) ;GET COMPILER FLAGS
LDB T2,[POINT 2,T2,14] ;GET INTERNAL REC. MODE.
;0= ASCII, 1=EBCDIC, 2=SIXBIT
HRL T1,[(POINT 7,)
(POINT 9,)
(POINT 6,)](T2) ;GET LH OF BYTE PTR.
MOVEM T1,.RCBPR(FTL) ;STORE BYTE PTR TO RECORD.
;CALL RMS. IF OPEN OUTPUT, DO A $CREATE.
; IF OPEN INPUT, DO A $OPEN
; IF OPEN I-O, DO A $OPEN
TXNE FLG,OPN%IO ;OPEN I-O?
JRST OP.MXA ;YES
TXNE FLG,OPN%IN ;OPEN INPUT?
JRST OP.MXB ;YES
;OPEN OUTPUT
OP.MXC: MOVE T2,.RCFAB(FTL) ;POINT TO FAB
$FETCH T1,FOP,(T2) ;GET FOP BITS NOW
IORI T1,FB$SUP ;SET SUPERCEDE MODE
$STORE T1,FOP,(T2)
$CREATE <(T2)>,OPCER ;** DO THE CREATE **
SKIPE FS.FS ;DID WE SET FILE-STATUS TO NON-ZERO?
POPJ PP, ;YES, * RETURN FROM OPEN *
PUSHJ PP,DOCONN ;DO THE CONNECT
SKIPE FS.FS ;DID WE SET FILE-STATUS TO NON-ZERO?
POPJ PP, ;YES, CONNECT ERROR RECOVERED, FILE IS CLOSED
TXO FLG,LF%OUT ;FILE IS NOW OPEN FOR OUTPUT
HRRM FLG,D.F1(FT) ;SET IN FILE-TABLE
PUSHJ PP,SETFS ;SET THE FILE-STATUS TO 00
JRST OPNDON ;DONE
;ERROR RETURN FROM $CREATE
OPCER: MOVE T2,.RCFAB(FTL) ;ADDR OF THE FAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
CAIN T1,ER$COF ;RMS CAN'T OPEN FILE?
JRST OPCER1 ;YES, SAY WHY
CAIN T1,ER$FNF ;FILE-NOT-FOUND ERROR
JRST OPOFNF ;YES
CAIN T1,ER$PRV ;PROTECTION VIOLATION?
JRST OPOPRV ;YES
TYPE [ASCIZ/
?LIBOL: Error on $CREATE
/]
;RMS-SYSTEM FAILURES, THE FAB HAS THE ERROR STUFF IN IT
RSFAIF: MOVE T2,.RCFAB(FTL) ;POINT TO FAB
RSFAI1: $FETCH P1,STS,(T2) ;STS IN P1
$FETCH P2,STV,(T2) ;STV IN P2
PUSHJ PP,RMSERP ;REPORT RMS ERROR
RSFAI2: $ERROR (E.500,SV.KIL,MT.FIL) ;ERROR 500 WITH FILENAME
;RMS-SYSTEM FAILURES, THE RAB HAS THE ERROR STUFF IN IT
RSFAIR: MOVE T2,.RCRAB(FTL) ;POINT TO RAB
JRST RSFAI1
OPCER1: TYPE [ASCIZ/
?RMS can't create file
/]
JRST RSFAIF ;ERROR WITH FILENAME
;OPEN I-O
OP.MXA: MOVE T2,.RCFAB(FTL) ;POINT TO FAB
$OPEN <(T2)>,OPOER ;** DO THE OPEN **
TRNA ;NORMAL RETURN
JRST OP.MXA ;TRY-AGAIN RETURN
SKIPE FS.FS ;DID WE SET FILE-STATUS NON-ZERO?
POPJ PP, ;Yes, ** ERROR IGNORED, return from OPEN **
PUSHJ PP,CHKOPF ;CHECK PARAMETERS RETURNED TO US
PUSHJ PP,CHKPRK ;Check primary key dup flag
SKIPE FS.FS ;Error 507 or 523 given and user ignored it?
JRST OPMXAI ;Yes
PUSHJ PP,DOCONN ;DO THE CONNECT
SKIPE FS.FS ;FILE STATUS NON-ZERO?
POPJ PP, ;YES, CONNECT FAILED, RETURN
OPMXAJ: TXO FLG,LF%INP!LF%OUT!LF%IO ;FILE IS OPEN FOR IO
HRRM FLG,D.F1(FT) ;SET IN FILE-TABLE
PUSHJ PP,SETFS ;SET THE FILE-STATUS TO 00
JRST OPNDON ;DONE
OPMXAI: PUSH PP,FS.FS ;Save file-status word
SETZM FS.FS ;To test it..
PUSHJ PP,DOCONN ;Try to do connect
SKIPN FS.FS ;Did connect fail?
JRST [POP PP,FS.FS ;No, restore file-status of "PERM error"
JRST OPMXAJ] ;Go set "FILE is open" bits and return
POP PP,(PP) ;Return newest set file-status
JRST OPMXAJ ;Remember file is open, though
;RMS $OPEN ERROR COMES HERE
OPOER: MOVE T2,.RCFAB(FTL) ;ADDR OF THE FAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
CAIN T1,ER$FNF ;FILE NOT FOUND?
JRST OPOFNF ;YES
CAIN T1,ER$COF ;RMS CAN'T OPEN FILE?
JRST OPOER1 ;SAY WHY
CAIN T1,ER$FLK ;FILE ALREADY LOCKED (BY SOME OTHER JOB)
JRST OPOFLK ;YES
CAIN T1,ER$PRV ;PROTECTION VIOLATION?
JRST OPOPRV ;YES
TYPE [ASCIZ/
?LIBOL: Error on $OPEN
/]
JRST RSFAIF ;RMS-SYSTEM FAILURE
;FILE NOT FOUND - ERROR FOR $OPEN OR $CREATE
OPOFNF: $FETCH T1,STV,(T2) ;FETCH THE JSYS ERROR CODE
IFN TOPS20,<
MOVEM T1,ER.JSE ;STORE FOR ERROR PRINTOUT
$ERROR (E.508,SV.FAT,MT.FIL!MT.JSE,RFNFER)
>;END IFN TOPS20
IFE TOPS20,<
SETO T2, ;INCASE ONE DOESN'T MATCH
CAIN T1,ERIPP%
MOVEI T2,0 ;GET TOPS10 ERROR CODE
CAIN T1,ERDNA%
MOVEI T2,1
CAIN T1,ERNSD%
MOVEI T2,2
CAIN T1,ERSNF%
MOVEI T2,3
JUMPL T2,OPOFN1 ;NO ADDITIONAL STATUS WE CAN USE
MOVEM T2,ER.E10 ;SAVE TOPS10 ERROR CODE
$ERROR (E.508,SV.FAT,MT.FIL!MT.E10,RFNFER)
OPOFN1: $ERROR (E.508,SV.FAT,MT.FIL,RFNFER)
>;END IFE TOPS20
OPOER1: TYPE [ASCIZ/
?Can't open file
/]
JRST RSFAIF ;RMS-SYSTEM FAILURE
;PROTECTION VIOLATION - THIS IS SIMILAR TO "FILE NOT FOUND"
; FROM USER'S POINT OF VIEW
;GO TO "RFNFER" IF HE WANTS TO TRAP THE ERROR - IT WILL CLEAR CORE
; AND RETURN FROM THE "OPEN" STATEMENT
OPOPRV: $ERROR (E.521,SV.FAT,MT.FIL,RFNFER)
;Here if file is already locked - probably someone else has the file
; open for I-O
OPOFLK: $ERROR (E.520,SV.FAT,MT.FIL!MT.OER,OPOFL1)
;Ignore OPEN error for "file is busy"
OPOFL1: MOVEI T1,UP%OER ;Check for filename OPEN
PUSHJ PP,CHKUSE ;Skip if that special case.
;[D1022] POPJ PP, ;No, regular error
PJRST RFNFER ;[1022] Jump to routine to release core
SETZM FS.FS ;[1116] Clear the file status
PUSHJ PP,SETFS ;[1116] Set it in the appropriate locations
AOS (PP) ;GIVE A TRY-AGAIN RETURN
POPJ PP, ;RETURN..
;OPEN INPUT
OP.MXB: MOVE T2,.RCFAB(FTL) ;POINT TO FAB
$OPEN <(T2)>,OPOER ;** DO THE OPEN **
TRNA ;NORMAL RETURN
JRST OP.MXB ;TRY-AGAIN RETURN
SKIPE FS.FS ;DID WE SET FILE-STATUS NON-ZERO?
POPJ PP, ;YES, ERROR IGNORED. * RETURN FROM OPEN *
PUSHJ PP,CHKOPF ;CHECK PARAMETERS RETURNED TO US
PUSHJ PP,CHKPRK ;Check primary key dup flag
SKIPE FS.FS ;Error 507 or 523 happen?
JRST OPMXBI ;Yes
PUSHJ PP,DOCONN ;DO THE CONNECT
SKIPE FS.FS ;FILE-STATUS SET NON-ZERO?
POPJ PP, ;YES, ERROR IGNORED, * RETURN FROM OPEN *
OPMXBJ: TXO FLG,LF%INP ;FILE IS NOW OPEN FOR INPUT
HRRM FLG,D.F1(FT) ;STORE UPDATED FLAGS
PUSHJ PP,SETFS ;SET THE FILE-STATUS TO 00
JRST OPNDON ;DONE
OPMXBI: PUSH PP,FS.FS ;Save file-status word
SETZM FS.FS ;To test it..
PUSHJ PP,DOCONN ;Try to do connect
SKIPN FS.FS ;Did connect fail?
JRST [POP PP,FS.FS ;No, restore file-status of "PERM error"
JRST OPMXBJ] ;Go set "FILE is open" bits and return
POP PP,(PP) ;Return newest set file-status
JRST OPMXBJ ;Remember file is open, though
;HERE WHEN OPEN IS DONE (RMS $CREATE/$OPEN AND $CONNECT)
OPNDON: POPJ PP, ;SUCCESS, RETURN
;COME HERE IF USER WANTS TO RECOVER FROM "FILE NOT FOUND" TYPE ERROR
; THE FILE IS NOT OPENED, WE MUST RELEASE THE CORE WE GOT AND RETURN
; FROM THE OPEN STATEMENT
RFNFER: PUSHJ PP,ROPCOR ;RELEASE CORE FROM THE OPEN
POPJ PP, ; RETURN FROM OPEN, OR OPOER ERROR ROUTINE
SPCTLE: ASCII / / ;[1044] ASCII SPACES
BYTE (9) 100,100,100,100 ;[1044] EBCDIC
SIXBIT / / ;[1044] SIXBIT
;CHKOPF: Routine to check parameters of the file we just opened
;Called after $OPEN returned successfully
; RMS has stored the parameters it found in the prologue of the
;file in the FAB and XAB's we gave it.
;
;Inputs:
; FTL points to RMS file table
;Call:
; PUSHJ PP,CHKOPF
; <return here if no error or error ignored>
; Doesn't return if user doesn't trap the error
;Uses T1-T4
;
;Notes:
;1) If we are opening a file that was created with more keys
; than we specified, no error will be generated. (this is a feature!)
;2) If the file organization is wrong, error 519 is given. This
; may be trapped (and ignored) by a USE procedure.
;3) If anything else is wrong, error 507 will be generated, which
; may be trapped by a USE procedure. If there is no USE procedure,
; a specific error message will be printed.
;4) Skips if there was no error, or an error was ignored and the
; file was left open.
;FTL POINTS TO THE RMS-CONTROL BLOCK
CHKOPF: MOVE T2,.RCFAB(FTL) ;GET PTR TO FAB RETURNED
;MAKE SURE FILE ORGANIZATION IS INDEXED
$FETCH T1,ORG,(T2) ;GET FILE ORGANIZATION
CAIE T1,FB$IDX ;MUST BE INDEXED
JRST ERORG ;?WRONG ORGANIZATION
;CHECK MAX RECORD SIZE
$FETCH T1,MRS,(T2) ;Get file's value
JUMPE T1,CHKOP0 ;Zero means unlimited.
LDB T3,FT.MRS ;GET program max record size
CAMGE T1,T3 ;Skip if user will be able to write
; a record.
JRST CKFE0 ;NO, COMPLAIN
;CHECK THE KEY INFORMATION
CHKOP0: HRRZ T3,.RCKIN(FTL) ;GET ADDRESS OF KEY INFO
MOVE T4,(T3) ;T4= # OF KEYS
MOVN T4,T4
HRLZ T4,T4 ;GET -N,,0
MOVE T2,.RCXAB(FTL) ;T2= ADDRESS OF FIRST XAB
ADDI T3,1 ;T3 POINTS TO FIRST 2-WORD BLOCK
;HERE WITH T2= ADDRESS OF XAB
; RH(T4)= NUMBER OF THIS KEY (0 thru n)
; T3= ADDRESS OF THIS KEY BLOCK
CHKOP1: PUSH PP,T4 ;SAVE KEY NUMBER
HLRZ T4,(T3) ;T4= POSITION OF THE KEY
$FETCH T1,POS,(T2) ;GET POSITION RETURNED
CAME T1,T4 ;DO THEY MATCH?
JRST [POP PP,T4 ;NO, GIVE ERROR
JRST CKFE1]
HRRZ T4,(T3) ;GET SIZE OF THE KEY IN PROGRAM
$FETCH T1,SIZ,(T2) ;GET SIZE OF KEY IN THE FILE
CAME T1,T4 ;BETTER MATCH..
JRST [POP PP,T4 ;;NO, ERROR
JRST CKFE2]
$FETCH T1,DTP,(T2) ;GET DATATYPE OF THE KEY
MOVE T0,F.WFLG(FT) ;GET COMPILER FT FLAGS
MOVEI T4,XB$SIX ;ASSUME SIXBIT
TLNE T0,DDMASC ; IF ASCII,
MOVEI T4,XB$STG ;GET ASCII DATATYPE
TLNE T0,DDMEBC ; IF EBCDIC,
MOVEI T4,XB$EBC ;GET EBCDIC DATATYPE
CAME T1,T4 ;DOES PROGRAM DATATYPE MATCH FILE'S?
JRST [POP PP,T4 ;NO, GIVE ERROR
JRST CKFE3]
HRRZ T1,(PP) ;Get this key number
JUMPE T1,CHKOP2 ;If primary key, don't check dup flag yet
$FETCH T1,FLG,(T2) ;GET FLAGS
HLLZ T4,1(T3) ;GET FLAGS FOR THIS KEY
TXNE T1,XB$DUP ;DOES FILE SAY "DUPS ALLOWED" FOR THIS KEY?
JRST [TXNE T4,KI%DUP ;YES, IS DUPLICATES ALLOWED IN PROGRAM?
JRST CHKOP2 ;YES, ALL OK
POP PP,T4 ;NO, GIVE ERROR
JRST CKFE4]
TXNN T4,KI%DUP ;NO DUPS ALLOWED IN FILE, IN PROGRAM?
JRST CHKOP2 ;ALL OK
POP PP,T4 ;NO, GIVE ERROR
JRST CKFE4
;ALL OK
CHKOP2: POP PP,T4 ;RESTORE KEY AOBJN PTR.
AOBJP T4,CPOPJ ;Return if done all keys
ADDI T3,2 ;BUMP TO NEXT KEY INFO BLOCK
$FETCH T2,NXT,(T2) ;FETCH ADDRESS OF NEXT XAB
JRST CHKOP1 ;AND LOOP
;CHKOPF ROUTINE (CONT'D)
;COME HERE WITH MINOR ERROR MESSAGE NUMBER IN T1
CKFEEP: PUSH PP,T1 ;SAVE
MOVEI T1,^D30 ;SET FILE-STATUS TO 30
MOVEM T1,FS.FS
PUSHJ PP,SETFS ;SO USER CAN SEE THAT THERE WAS A PROBLEM
MOVEI T1,UP%ERR ;CHECK FOR ERROR USE PROCEDURE
PUSHJ PP,CHKUSE
JRST CKFEE1 ;NONE
POP PP,T1 ;Fix stack
$ERROR (E.507,SV.FAT,MT.FIL,CPOPJ) ;LET HIM TRAP IT
;HERE IF NO USE PROCEDURE. TYPE MESSAGE AND BOMB HIM OUT
CKFEE1: TYPE [ASCIZ/
?LBLEOO Error on OPEN: /]
POP PP,T1 ;GET MESSAGE NUMBER (MINOR)
TYPE @CKERS(T1) ;TYPE MESSAGE
$ERROR (E.507,SV.KIL,MT.FIL) ;GIVE FATAL ERROR
;CHKOPF errors that could happen
CKERS: [ASCIZ/Maximum record size of program is larger than file's/] ;0
[ASCIZ/Key position in program differs from file's/] ;1
[ASCIZ/Key length of program differs from file's/] ;2
[ASCIZ/Datatype of key in program differs from file's/] ;3
[ASCIZ/Key flags specified in program differ from file's key flags/] ;4
NMCERS==.-CKERS ;NUMBER OF ERROR MESSAGES
;DEFINE ERROR MESSAGE ROUTINES FOR THE MINOR ERRORS
DEFINE CKFEE(NN),<
CKFE'NN: MOVEI T1,NN ;GET MINOR ERROR NUMBER
JRST CKFEEP ;AND REPORT ERROR
>
%NN==0 ;INDEX FOR THE REPEAT..
REPEAT NMCERS,<
CKFEE(\%NN)
%NN==%NN+1
>
;ERROR - WRONG ORGANIZATION
ERORG: MOVEI T1,^D30 ;SET FILE-STATUS TO 30
MOVEM T1,FS.FS
PUSHJ PP,SETFS ;SO USER CAN SEE THAT THERE WAS A PROBLEM
$ERROR (E.519,SV.FAT,MT.FIL,ERORGR) ;GIVE TRAPPABLE ERROR
;HERE IF USER WANTS TO IGNORE THE ERROR
; SET FLAGS SAYING THAT THE FILE IS OPEN, then call CLOSE.
ERORGR: TXO FLG,LF%INP ;"FILE IS OPEN FOR INPUT"
HRRM FLG,D.F1(FT) ;STORED UPDATED FLAGS
MOVE T1,BS.AGL ;GET BASE OF OPEN ARG LIST
MOVE T1,(T1) ;GET FILE-TABLE & FLAGS
TLZ T1,-1 ; JUST GET FILE-TABLE ADDR
PUSH PP,T1 ;SAVE ON STACK
MOVEI ARG,(PP) ;POINT TO ARG ON STACK
PUSHJ PP,CL.MIX ;CLOSE THE FILE
POP PP,(PP) ;FIX STACK
POPJ PP, ;RETURN
;CHKPRK - Check open file primary key duplicates flag
;* Sigh * COBOL is a bitch.
; This routine checks the XAB returned by RMS to see if the file
;we just opened (for INPUT or I-O) has the "duplicates allowed"
;bit set for the primary key. If so, the assumptions made by
;the COBOL standard do not apply, since COBOL does not ever
;allow duplicates in the primary key. So LIBOL will generate an
;error code.
; However, many users will probably want to read or update their
;RMS files which were defined this way with COBOL programs. Instead
;of simply bombing out their programs, we have decided to let them
;trap this condition and continue with the file opened if they want.
;The error code will be "523", and file status will be set to 30.
;Inputs:
; FTL points to RMS file table
;Call:
; PUSHJ PP,CHKPRK
; <here if no error or error ignored by user>
; Doesn't return if error and he didn't trap it
CHKPRK: MOVE T2,.RCXAB(FTL) ;T2:= addr of first XAB returned
$FETCH T1,FLG,(T2) ;Get flags
TXNN T1,XB$DUP ;Duplicates allowed?
POPJ PP, ;No, return
MOVEI T1,^D30 ;"Permanent error"
MOVEM T1,FS.FS
PUSHJ PP,SETFS ;Set user's file-status word
$ERROR (E.523,SV.FAT,MT.FIL,CPOPJ) ;Give error, let him trap it
;DOCONN - ROUTINE TO DO A $CONNECT
;CALLED AFTER THE $OPEN OR $CREATE WAS SUCCESSFUL
;IF IT FAILS, $ERROR IS CALLED AND FILE STATUS SET TO 30
;IF THE ERROR IS TRAPPABLE, A USE PROCEDURE IS CALLED.
;
;IF ERROR HAPPENS AND THE USER TRAPPED IT, MEMORY IS CLEANED
;UP AND THE FILE IS CLOSED.
;
DOCONN: MOVE T2,.RCRAB(FTL) ;POINT TO THE RAB
$CONNECT <(T2)>,CONERR ;DO IT
POPJ PP, ; RETURN
;CONNECT FAILED
CONERR: MOVE T2,.RCRAB(FTL) ;ADDR OF THE FAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
CAIN T1,ER$DME ;DYNAMIC MEMORY EXHAUSTED
JRST CONDME ;YES
TYPE [ASCIZ/
?LIBOL: $CONNECT failed
/]
JRST RSFAIR ;RMS-SYSTEM FAILURE
;DYNAMIC MEMORY EXHAUSED, LET USER TRAP THIS IF HE WANTS
; (This will most likely happen in $CONNECT)
CONDME: MOVEI T1,^D30 ;SET FILE-STATUS
MOVEM T1,FS.FS ; "PERMANENT ERROR"
PUSHJ PP,SETFS ;SET IT
$ERROR (E.503,SV.FAT,MT.FIL,CONDM1)
;HERE IF THE ERROR RETURNS (HE TRAPPED IT AND WANTS TO IGNORE IT).
;CLEAN UP AND RETURN TO USER
CONDM1: MOVE T2,.RCFAB(FTL) ;T2 POINTS TO FAB
$CLOSE <(T2)>,CONDM2 ;** CLOSE THE FILE **
PUSHJ PP,ROPCOR ;RELEASE THE CORE
POPJ PP, ;AND RETURN
CONDM2: TYPE [ASCIZ/?$CLOSE failed trying to recover from $CONNECT error
/]
JRST RSFAIF ;FAB HAS ERROR STUFF IN IT
;PICKFN - PICKUP FILENAME FROM VALUE-OF-ID AND STORE IT IN
; THE RMS FAB.
;ACS T1-T4 ARE SMASHED.
PICKFN: MOVEI T1,.RCFNM(FTL) ;STORE THE FILENAME ADDRESS
$STORE T1,FNA,(T4) ; IN THE FIELD
MOVSI T4,(POINT 7,) ;MAKE T4= BYTE PTR TO OUTPUT STRING
HRR T4,T1
;FIRST STORE DEVICE NAME
HRRZ T1,F.WDNM(FT) ;GET ADDR OF DEVICE NAME
HRLI T1,(POINT 6,) ;MAKE BYTE PTR TO IT
MOVEI T2,6 ;MAXIMUM OF 6 CHARACTERS
PICKF0: ILDB C,T1 ;GET A CHAR OF DEVICE NAME
JUMPE C,PICKF1 ;NULL IS DONE
ADDI C,40 ;MAKE IT ASCII
IDPB C,T4 ;STORE ON STRING
SOJG T2,PICKF0 ;.. FOR ALL CHARS IN DEVICE NAME
PICKF1: MOVEI C,":" ;COLON TO DELIMIT DEVICE NAME
IDPB C,T4 ;PUT THAT ON STRING
IFN TOPS20,< ;CHECK FOR USER-NUMBER, IF HE SUPPLIED ONE,
; TRANSLATE TO DIRECTORY STRING OVERWRITING
; THE DEVICE NAME IN ASCII STRING.
LDB T1,FT.PPN ;T1= ADDRESS OF USER-NUMBER
JUMPE T1,PCKF1A ;JUMP IF NO USER-NUMBER
MOVE T2,T4 ;PUT NULL ON END OF DEVICE STRING
SETZ T3,
IDPB T3,T2
MOVE T2,(T1) ;FETCH PPN
MOVEI T1,.RCFNM(FTL) ;POINT TO FILENAME
HRLI T1,(POINT 7,)
MOVE T3,T1 ;FROM..
PPNST% ;TRANSLATE PPN TO STRING..
ERJMP PCKF1B ;ERROR
MOVE T4,T1 ;GET UPDATED PTR
PCKF1A:
>;END IFN TOPS20
;NOW THE FILE NAME
MOVE T1,F.WVID(FT) ;T1:=BYTE PTR TO VALUE OF ID
LDB T2,[POINT 6,T1,11] ;T2= BYTE SIZE
;OLD STYLE (BEFORE V13) VID IS 9 CHARS LONG.
MOVEI T3,6 ;GET SIX CHARS OF NAME
PICKF2: ILDB C,T1 ;GET A CHAR
CAIN T2,6 ;SIXBIT?
ADDI C,40 ;YES, CONVERT TO ASCIZ
CAIN T2,9 ;EBCDIC
LDB C,PTR.97## ; YES, CONVERT TO ASCII
CAIG C," " ;SPACE OR NULL OR CONTROL CHAR?
JRST PICKF3 ;YES, THAT'S THE END
IDPB C,T4 ;STORE IN PTR
SOJN T3,PICKF2
PICKF3: MOVEI C,"." ;TO DELIMIT FILE NAME
IDPB C,T4
SOJLE T3,.+3 ;SKIP BLANKS TO EXTENSION
IBP T1
JRST .-2
MOVEI T3,3 ;3 CHARS OF EXTENSION
PICKF4: ILDB C,T1
CAIN T2,6 ;SIXBIT?
ADDI C,40 ;YES, CONVERT TO ASCII
CAIN T2,9 ;EBCDIC?
LDB C,PTR.97## ; YES, CONVERT TO ASCII
CAIN C," " ;DONE EXT?
JRST PICKF5 ;YES
IDPB C,T4 ;STORE IN PTR
SOJN T3,PICKF4 ;LOOP
PICKF5:
IFE TOPS20,< ;APPEND USER-NUMBER AS A [P,PN] IF GIVEN
LDB T1,FT.PPN ;T1= ADDRESS OF USER-NUMBER
JUMPE T1,PCKF5D ;HE DIDN'T SUPPLY ONE
MOVEI T2,"[" ;START PPN
IDPB T2,T4
HLRZ T1,(T1) ;GET PROJECT NUMBER
PUSHJ PP,T4OCT ;APPEND TO T4 THE OCTAL NUMBER
MOVEI T2,"," ;TO SEPARATE PROJ AND PROG
IDPB T2,T4
LDB T1,FT.PPN ;GET ADDR OF PPN AGAIN
HRRZ T1,(T1) ;GET PROGRAMMER NUMBER
PUSHJ PP,T4OCT ;APPEND TO STRING
MOVEI T2,"]" ;TO END PPN
IDPB T2,T4
PCKF5D:
>;END IFE TOPS20
SETZ C, ;NULL TO END STRING
IDPB C,T4
JRST CPOPJ1 ;DONE, RETURN SUCCESSFUL
IFE TOPS20,< ;APPEND OCTAL NUMBER IN T1 TO STRING IN T4
T4OCT: IDIVI T1,8 ;DIVIDE BY RADIX
HRLM T2,(PP) ;STORE DIGIT
SKIPE T1 ;ALL DONE?
PUSHJ PP,T4OCT ;NO, RECURSE
HLRZ T1,(PP) ;GET BACK DIGIT
ADDI T1,"0" ;MAKE ASCII
IDPB T1,T4 ;STORE
POPJ PP, ;UNWIND
>;END IFE TOPS20
;HERE IF ERROR TRYING TO TRANSLATE PPN
IFN TOPS20,<
PCKF1B: MOVEI T1,.FHSLF ;GET JSYS ERROR
GETER%
MOVEM T2,ER.JSE ;SAVE JSYS ERROR MNENOMIC
;GIVE "FILE-NOT-FOUND" LIBOL ERROR
$ERROR (E.508,SV.FAT,MT.FIL!MT.JSE,CPOPJ)
>;END IFN TOPS20
SUBTTL CL.MIX - CLOSE RMS INDEXED FILE
;ARGLIST: FLAG-BITS,,FILTAB-ADDR
;
; WHERE FLAG-BITS ARE:
CLS%CF==1B12 ;CLOSE FILE = 0
CLS%LK==1B13 ;LOCK, LOCKED FILES MAY NOT BE REOPENED
CLS%DL==1B14 ;CLOSE WITH DELETE
;THE FOLLOWING ARE NOT SUPPORTED:
; END-OF-FILE LABEL, END-OF-VOLUME LABEL, BEGINNING-OF-VOLUME LABEL,
; CLOSE REEL, NO REWIND, UNLOAD.
CL.MIX: PUSHJ PP,SETIO ;SETUP FOR IO
TXNN FLG,LF%INP+LF%OUT ;SKIP IF FILE WAS OPEN
JRST CLMER1 ;NO, GIVE ERROR
TXNE FLG,CLS%LK ;CLOSE WITH LOCK?
PUSHJ PP,[SETO T1, ;YES, SET THE FLAG
DPB T1,FT.BLF
POPJ PP,] ;CONTINUE CLOSE CODE
;HERE IF OK TO CLOSE FILE
MOVE T2,.RCFAB(FTL) ;T2 POINTS TO FAB
$CLOSE <(T2)>,RCLSER ;** CLOSE THE FILE **
TXNN FLG,CLS%DL ;[1073] CLOSE WITH DELETE?
JRST CL.AFT ;[1073] NO
MOVE T2,.RCFAB(FTL) ;[1073] YES, POINT AT FAB
$ERASE <(T2)>,RCLSER ;[1073] ** DELETE THE FILE **
;CLOSE WAS SUCCESSFUL. RELEASE THE CORE.
CL.AFT: PUSHJ PP,ROPCOR ;[1073] * RELEASE CORE FROM OPEN *
PUSHJ PP,SETFS ;SET FILE-STATUS TO 00
POPJ PP, ;ALL DONE, RETURN TO USER
;CLOSE WAS UNSUCCESSFUL. REPORT THE ERROR
;** NOTE: IF THIS IS CHANGED TO RECOVER, WE MUST CHANGE FILE'S
; STATE TO BE "UNF" (UNLESS IT WAS "ATE": THEN IT REMAINS "ATE")
RCLSER: TYPE [ASCIZ/
?LIBOL: $CLOSE failed
/]
JRST RSFAIF ;RMS-SYSTEM FAILURE
;FILE WAS NOT OPEN
CLMER1: $ERROR (E.512,SV.KIL,MT.FIL) ;FILE WAS NOT OPEN
;ROPCOR routine: Release core obtained at OPEN time
;This is called by OPEN (incase errors happen) or CLOSE (normal case)
;with FTL and FT set up. This routine gets rid of the FTL block.
;If the core cannot be released, this causes a fatal LIBOL error,
; else it will return .+1
ROPCOR: MOVEM FTL,FUN.A1## ;ARG1= ADDRESS
MOVE T1,.RCMEM(FTL) ;ARG2= SIZE
MOVEM T1,FUN.A2## ; OF BLOCK TO RETURN
MOVEI ARG,1+[-5,,0
XWD 0,FUN.A0##
XWD 0,[ASCIZ/LBL/]
XWD 0,FUN.ST##
XWD 0,FUN.A1##
XWD 0,FUN.A2##]
MOVEI T1,F.RAD ;FUNCTION WE WANT
MOVEM T1,FUN.A0## ;STORE FUNCTION
SETZM FUN.ST## ;CLEAR STATUS
PUSHJ PP,FUNCT.## ;CALL FUNCT. ROUTINE
SETZM D.RMSP(FT) ;CLEAR POINTER TO THE RMS CONTROL BLOCK
SKIPE T1,FUN.ST ;STATUS NON-ZERO?
JRST CRCOR ;?CAN'T RELEASE CORE
TXZ FLG,LF%INP+LF%OUT+LF%IO ;NOT OPENED ANY MORE
TXZ FLG,CF%CNV+LF%FNA ;CLEAR TEMP FLAGS
HRRM FLG,D.F1(FT) ;SAVE UPDATED FLAGS
POPJ PP, ;RETURN
CRCOR: TYPE [ASCIZ/
?LIBOL: Couldn't release core from the RMS OPEN/]
JRST RSFAI2 ;*** FIX ***
SUBTTL RMS WRITE ENTRY POINTS
;ARG FORMAT:
;ARG-ADDR: FLAG-BITS,,FILTAB-ADDR
; WRT-REC-LENGTH,,KEY-BUFFER-ADDRESS
;
;FLAGS-BITS:
WT%NIK==1B9 ;NO "INVALID KEY" CLAUSE GIVEN
; "USE PROCEDURE" INSTEAD
;HERE WHEN THE ACCESS MODE OF THE FILE IS RANDOM OR DYNAMIC
WT.MIR: PUSHJ PP,WTSET ;SETUP TO DO "WRITE"
MOVE T2,.RCRAB(FTL) ;POINT TO THE RAB FOR THIS FILE
MOVEI T1,RB$KEY ;SIGNAL KEYED ACCESS
$STORE T1,RAC,(T2) ; FOR RANDOM READ
;ADDRESS OF RECORD WAS ALREADY STORED BY "OPEN".
;STORE SIZE OF RECORD
WRTMI1: MOVE T1,BS.AGL ;SIZE OF RECORD TO WRITE IS HERE
HLRZ T1,1(T1) ; IN THE ARG LIST
$STORE T1,RSZ,(T2)
PUSH PP,T2 ;[1020] SAVE THE RAB FOR FLUSH
;;;READY TO DO THE $PUT ;;;
$PUT <(T2)>,PUTERR ;** DO THE PUT **
PUSHJ PP,CHKSDP ;CHECK FOR SUCCESSFUL RETURN, BUT DUPLICATE KEY
POP PP,T2 ;[1020] RESTORE THE RAB
MOVE T1,FS.FS ;GET FILE STATUS
;[D1020] CAIL T1,^D10 ;SEE IF SOME KIND OF AT-END/INVALID KEY
;[D1020] CAILE T1,^D29
CAIG T1,^D9 ;[1020] SEE IF SOME KIND OF AT-END/INVALID KEY
JRST CHKPT ;[1020]
CAIG T1,^D29 ;[1020]
JRST CPOPJ1 ;[1020]
CHKPT: LDB T0,FT.CRC ;[1020] CHECKPOINTING?
JUMPE T0,CHKPT1 ;[1020] NO
SOSE D.CRC(FT) ;[1020] DECREMENT COUNT - TIME TO OUTPUT?
JRST CHKPT1 ;[1020] NOT YET
LDB T0,FT.CRC ;[1020] GET COUNT
MOVEM T0,D.CRC(FT) ;[1020] RESET COUNT
$FLUSH <(T2)>,FSHERR ;[1020] WRITE REC TO DISK
CHKPT1: ;[1020]
PJRST SETFS ;SET FILE-STATUS, AND GIVE NORMAL RETURN
FSHERR: TYPE [ASCIZ/
?LIBOL: $FLUSH failed
/] ;[1020] RETURN ERROR MESSAGE
JRST RSFAIR ;[1020] RMS SYSTEM ERROR
CPOPJ1: AOS (PP) ;GIVE SKIP RETURN
CPOPJ: POPJ PP, ;FOR "INVALID KEY"
;ERROR ON $PUT
PUTERR: MOVE T2,.RCRAB(FTL) ;ADDR OF THE RAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
; CAIN T1,ER$CHG ;KEY CANNOT BE CHANGED?
; JRST PUTERC ;YES, GIVE ERROR
CAIN T1,ER$DUP ;DUPLICATE KEY?
JRST PUTERD ;YES
; CAIN T1,ER$REX ;RECORD ALREADY EXISTS?
; JRST PUTERD ;YES, "DUPLICATE KEY"
CAIN T1,ER$SEQ ;OUT OF SEQUENCE?
JRST SEQERR ;YES, RETURN STATUS
TYPE [ASCIZ/
?LIBOL: $PUT failed
/]
JRST RSFAIR ;RMS SYSTEM ERROR
PUTERD: MOVEI T1,^D22 ;DUPLICATE KEY, ERROR 22
JRST PUTERI
SEQERR: MOVEI T1,^D21 ;SEQUENCE ERROR, ERROR 21
PUTERI: MOVEM T1,FS.FS ;STORE IN FILE-STATUS WORD
PUSHJ PP,SETFS ;SET IT
POPJ PP, ;RETURN
;HERE WHEN THE ACCESS MODE OF THE FILE IS SEQUENTIAL
WT.MIS: PUSHJ PP,WTSET ;SETUP TO DO "WRITE"
;THIS HAS RETURNED IF FILE WAS OPEN FOR OUTPUT OR I-O.
; BUT ONLY "OUTPUT" IS ALLOWED WHEN ACCESS MODE IS SEQUENTIAL.
TXNE FLG,LF%IO ;SKIP IF NOT I-O
JRST WTMSE0 ;OPEN I-O, ILLEGAL
;THE STANDARD SAYS WE ARE SUPPOSED TO MAKE SURE THAT THE
; KEY BEING WRITTEN IS NOT LE THE LAST KEY THAT WAS WRITTEN,
; AND IF IT WAS, GIVE AN "INVALID KEY".
; LUCKILY, RMS RETURNS A UNIQUE ERROR CODE (ER$SEQ) FOR THIS CONDITION.
MOVE T2,.RCRAB(FTL) ;T2 POINTS TO THE RAB FOR THIS FILE
MOVEI T1,RB$SEQ ;SEQUENTIAL ACCESS
$STORE T1,RAC,(T2) ;STORE IT
JRST WRTMI1 ;JOIN COMMON WRITE CODE
;"Attempt to WRITE indexed file / seq access mode not OPEN for OUTPUT"
WTMSE0: $ERROR (E.515,SV.KIL,MT.FIL)
;ROUTINE TO SETUP TO DO "WRITE"
; DOESN'T RETURN IF ERRORS
WTSET: PUSHJ PP,SETIO ;SETUP FOR IO
TXNN FLG,LF%OUT ;SKIP IF OPEN FOR OUTPUT FOR I-O
JRST WTSETE ;FILE NOT OPEN FOR OUTPUT OR I-O
MOVE T1,.RCSTE(FTL) ;GET FILE'S STATE
CAIN T1,RC.SUR ;IF SUCCESSFUL READ WAS JUST DONE,
MOVEI T1,RC.UNF ; SET STATE TO "UNDEFINED"
MOVEM T1,.RCSTE(FTL) ;STORE NEW STATE
MOVE T2,.RCRAB(FTL) ;POINT TO RAB
MOVEI T1,RB$LOA ;ALWAYS USE LOAD PERCENTAGES
MOVE T0,D.CRC(FT) ;[1020]] IF TIME TO CHECKPOINT
CAIE T0,1 ;[1020]] DON'T TURN ON WRITE BEHIND
TXO T1,RB$WBH ; AND WRITE BEHIND
$STORE T1,ROP,(T2) ; NEXT REC. PTR SHOULD BE UNAFFECTED.
TXNN FLG,CF%CNV ;SKIP IF CONVERSION REQUIRED
POPJ PP, ;NO, JUST RETURN
;COPY RECORD AREA TO BUFFER ADDRESS
;ENTER HERE FROM "RWST" CODE
COPRCB: MOVE T1,.RCBPR(FTL) ;FROM
MOVEM T1,CVPRM. ; SAVE PARAMETER
HRRZ T1,.RCCRB(FTL) ;TO
HRLI T1,440000 ;GET STARTING BP.
HRRZ T2,BS.AGL ;POINT TO BASE OF ARG LIST
HLRZ T2,1(T2) ;GET REC LENGTH
DPB T2,[POINT 12,T1,17] ;STORE LENGTH
MOVEM T1,CVPRM.+1 ; SAVE 2ND PARAMETER
PUSHJ PP,SVPACS ;SAVE ALL PERMANENT ACS
MOVEI ARG,CVPRM. ;POINT TO PARAMS
HLRZ T1,.RCCRS(FTL) ;CONVERT FROM RECORD
PUSHJ PP,(T1) ;CALL ROUTINE
POPJ PP, ;ALL OK, RETURN
;"Attempt to WRITE and file not open for OUTPUT"
WTSETE: $ERROR (E.513,SV.KIL,MT.FIL)
SUBTTL RMS READ ENTRY POINTS
;ARG FORMAT:
;ARG-ADDR: FLAG-BITS,,FILTAB-ADDR
; [XWD KEY# OF REF,,ADDR OF KEY BUFFER] ;IF RANDOM READ
; WHERE FLAG-BITS ARE:
RD%NXT==1B9 ;READ NEXT RECORD
RD%KYR==1B10 ;KEY REFERENCE SPECIFIED
RD%NER==1B11 ;NO ERROR RETURN - DO "USE" PROCEDURE
;RD.MIR: READ RANDOMLY
RD.MIR: PUSHJ PP,RDSET ;SETUP FOR READ
TXNE FLG,CF%CNV ;IF CONVERSION REQUIRED,
PUSHJ PP,RKBSET ;SETUP KEY BUFFER
;LOOKS GOOD. DO AN INDEXED-FILE RANDOM READ.
MOVE T2,.RCRAB(FTL) ;POINT TO RAB
;SET KEY BUFFER ADDRESS
HRRZ T1,BS.AGL ;GET BASE OF ARG LIST
HRRZ T1,1(T1) ; FETCH ADDRESS OF KEY BUFFER
TXNE FLG,CF%CNV ;UNLESS CONVERSION REQUIRED,
HRRZ T1,.RCCKB(FTL) ; THEN GET CONVERTED KEY BUFFER
$STORE T1,KBF,(T2) ; TELL RMS WHERE KEY IS
;SET "KEY OF REFERENCE"
SETZ T1, ;ASSUME PRIMARY KEY
TXNN FLG,RD%KYR ;WAS ANY SPECIFIED?
JRST RD.MI2 ;NO, USE 0
HRRZ T1,BS.AGL ;GET BASE OF ARG LIST
HLRZ T1,1(T1) ;GET T1= WHICH KEY
RD.MI2: $STORE T1,KRF,(T2) ;STORE "KEY OF REFERENCE"
MOVEM T1,.RCKRF(FTL) ;AND REMEMBER WHICH KEY IT IS
;SET "KEY BUFFER SIZE"
HRRZ T3,.RCKIN(FTL) ;POINT TO KEY INFO
LSH T1,1 ;EACH IS TWO WORDS LONG
ADDI T3,1(T1) ;POINT TO APPROPRIATE KEY-INFO BLOCK
HRRZ T1,0(T3) ;GET KEY SIZE
$STORE T1,KSZ,(T2) ;STORE SIZE OF KEY BLOCK
;SET "USER BUFFER SIZE"
LDB T1,FT.MRS ;GET MAXIMUM RECORD SIZE
$STORE T1,USZ,(T2)
;SET "ACCESS MODE = RANDOM"
MOVEI T1,RB$KEY ;KEYED ACCESS
$STORE T1,RAC,(T2)
;SET RECORD OPTIONS TO JUST "SET NEXT REC PTR"
MOVEI T1,RB$NRP
$STORE T1,ROP,(T2)
;;;; ALL READY TO DO THE $GET ;;;
$GET <(T2)>,RDRERR ;DO IT
MOVE T1,FS.FS ;GET FILE-STATUS
JUMPE T1,RDDOK ;OK
CAIN T1,^D23 ;INVALID KEY?
AOS (PP) ;YES, RETURN .+2
POPJ PP, ;RETURN
;HERE IF THE $GET WAS SUCCESSFUL. WE WILL RETURN .+1 TO USER,
; AFTER CONVERTING THE RECORD BACK TO THE INTERNAL MODE.
RDDOK: PUSHJ PP,SETFS ;SET FILE-STATUS TO 00
TXNE FLG,CF%CNV ;IF CONVERSION REQUIRED,
PUSHJ PP,RDCVB ; GO DO IT
MOVEI T1,RC.SUR ;SUCCESSFUL READ JUST DONE.
MOVEM T1,.RCSTE(FTL) ;SAVE STATE
;RETURN # OF CHARACTERS READ
MOVE T2,.RCRAB(FTL) ;POINT TO RAB
$FETCH T1,RSZ,(T2) ;GET # CHARACTERS READ
MOVEM T1,D.CLRR(FT) ;[V12B] STORE IN FILE TABLE
POPJ PP, ;RETURN .+1 TO USER
;RANDOM READ FAILED
RDRERR: MOVE T1,.RCSTE(FTL) ;GET STATE OF FILE
CAIN T1,RC.SUR ; "SUCCESSFUL READ DONE"?
MOVEI T1,RC.UNF ;NOT ANY MORE!
MOVEM T1,.RCSTE(FTL) ;SAVE NEW STATE
MOVE T2,.RCRAB(FTL) ;ADDR OF THE RAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
CAIN T1,ER$RNF ;RECORD NOT FOUND?
JRST RDRIVK ;YES, RETURN "INVALID KEY"
TYPE [ASCIZ/
?LIBOL: $GET failed
/]
JRST RSFAIR ;RMS-SYSTEM FAILURE
RDRIVK: MOVEI T1,^D23 ;FILE STATUS TO SET
MOVEM T1,FS.FS ;PUT HERE
PUSHJ PP,SETFS ;SET THE STATUS
TXNE FLG,RD%NER ;NO INVALID KEY CLAUSE PROVIDED?
PUSHJ PP,SETEFS ; YEAH, GO SET THE ERROR-STATUS VARIABLES
POPJ PP,
;RD.MIS: READ SEQUENTIALLY
RD.MIS: PUSHJ PP,RDSET ;SETUP FOR READ
;GIVE ERROR IF FILE IS ALREADY "AT END"
MOVE T1,.RCSTE(FTL) ;GET STATE OF FILE
CAIN T1,RC.ATE ; IF "AT END",
JRST RDMSE1 ;GIVE ERROR
;LOOKS GOOD. DO AN INDEXED-FILE SEQUENTIAL READ.
MOVE T2,.RCRAB(FTL) ;POINT TO RAB
;SET THE CURRENT KEY OF REFERENCE
MOVE T1,.RCKRF(FTL) ;THIS IS USUALLY 0 FOR PRIMARY KEY
$STORE T1,KRF,(T2)
;SET RECORD BUFFER ADDRESS
HRRZ T1,F.RREC(FT) ;POINT TO RECORD
TXNE FLG,CF%CNV ;UNLESS CONVERSION REQUIRED,
HRRZ T1,.RCCRB(FTL) ;THEN READ RECORD INTO INTERMEDIATE BUFFER
$STORE T1,UBF,(T2) ;TELL RMS WHERE RECORD AREA IS
;SET "USER BUFFER SIZE"
LDB T1,FT.MRS ;GET MAXIMUM RECORD SIZE
$STORE T1,USZ,(T2)
;SET "ACCESS MODE = SEQUENTIAL"
MOVEI T1,RB$SEQ ;SEQUENTIAL ACCESS
$STORE T1,RAC,(T2)
;SET "READ AHEAD" BIT , GAMBLING THAT THE USER WILL BE PROCESSING
; THE FILE SEQUENTIALLY FOR A WHILE
MOVEI T1,RB$RAH ;READ AHEAD
$STORE T1,ROP,(T2)
;;;; ALL READY TO DO THE $GET ;;;
$GET <(T2)>,RDSERR ;DO IT
MOVE T1,FS.FS ;GET FILE-STATUS NOW
JUMPE T1,RDDOK ;JUMP TO CONVERT BACK IF NECESSARY
CAIN T1,^D10 ; AT END?
AOS (PP) ;YES, TAKE "AT END" PATH
POPJ PP, ;.. OR RETURN SUCCESS
;READ IN SEQUENTIAL MODE FAILED. THIS SHOULD ONLY HAPPEN ON EOF.
RDSERR: MOVE T2,.RCRAB(FTL) ;GET ADDRESS OF RAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
CAIN T1,ER$EOF ;END OF FILE REACHED?
JRST RDEOF ;YES
MOVE T1,.RCSTE(FTL) ;GET STATE OF FILE
CAIN T1,RC.SUR ; "SUCCESSFUL READ DONE"?
MOVEI T1,RC.UNF ;NOT ANY MORE!
MOVEM T1,.RCSTE(FTL) ;SAVE NEW STATE
TYPE [ASCIZ/
?RMS SEQ READ FAILED
/]
JRST RSFAIR ;RMS-SYSTEM FAILURE
RDEOF: MOVEI T1,^D10 ;SET FILE STATUS TO 10
MOVEM T1,FS.FS ;SET UP THE STATUS WORD
PUSHJ PP,SETFS ;STORE INTO USER VARIABLE, IF ANY
TXNE FLG,RD%NER ;SKIP IF "AT END" CLAUSE PROVIDED
PUSHJ PP,SETEFS ;GO SET THE ERROR-STATUS VARIABLES
MOVEI T1,RC.ATE ;"FILE IS AT END"
MOVEM T1,.RCSTE(FTL) ;SAVE STATE
POPJ PP, ;RETURN TO RMS
;ERROR: ATTEMPT TO READ SEQUENTIALLY, BUT FILE IS ALREADY AT END
RDMSE1: $ERROR (E.518,SV.KIL,MT.FIL)
SUBTTL READ- SETUP ROUTINES
RDSET: PUSHJ PP,SETIO ;SETUP FOR DOING IO
TXNN FLG,LF%INP ;SKIP IF OPEN FOR INPUT
JRST RDSTE1 ;NO--GIVE ERROR
POPJ PP, ;DONE, RETURN
;FILE WAS NOT OPEN FOR INPUT
RDSTE1: $ERROR (E.505,SV.KIL,MT.FIL)
SUBTTL READ- RECORD CONVERSION ROUTINE
;COPY RECORD READ FROM CONVERTED BUFFER TO REAL BUFFER
RDCVB: MOVE T1,F.WFLG(FT) ;GET FT FLAGS
;** CHANGE IN V13:
LDB T1,[POINT 2,T1,2] ;GET DEVICE DATA MODE
HRL T2,[(POINT 7,)
(POINT 9,)
(POINT 6,)](T1) ;GET PART OF B.P.
HRR T2,.RCCRB(FTL) ;GET ADDRESS PART
MOVEM T2,CVPRM. ;;SAVE 1ST PARAMETER
MOVE T2,.RCBPR(FTL) ;START 2ND PARAMTER - BP TO RECORD
LDB T1,FT.MRS ;GET MAXIMUM RECORD SIZE
DPB T1,[POINT 12,T2,17] ;STORE IN PARAM
MOVEM T2,CVPRM.+1 ;STORE 2ND PARAMETER
PUSHJ PP,SVPACS ;SAVE PERM ACS
MOVEI ARG,CVPRM. ;POINT TO PARAMS
HRRZ T1,.RCCRS(FTL) ;GET ROUTINE TO CONVERT TO RECORD
PUSHJ PP,(T1) ;CALL IT
POPJ PP, ;DONE, RETURN
SUBTTL RKBSET - COPY KEY BUFFER TO TEMP CONVERTED AREA
;COPY KEY BUFFER TO CONVERTED KEY BUFFER
;THIS ROUTINE IS CALLED WHEN DOING KEYED ACCESS.
; IT EXPECTS THAT ARG-LIST+1 IS
; XWD KEY-OF-REFERENCE,,KEY-BUFFER-ADDRESS
RKBSET: HRRZ T1,BS.AGL ;GET BASE OF ARG LIST
HLRZ T1,1(T1) ;GET KEY OF REFERENCE
HRRZ T3,.RCKIN(FTL) ;POINT TO KEY INFO
LSH T1,1 ;EACH IS TWO WORDS LONG
ADDI T3,1(T1) ;POINT TO APPROPRIATE KEY-INFO BLOCK
HRRZ T1,0(T3) ;GET KEY SIZE
;ENTER HERE WHEN THE KEY SIZE IS IN T1
RKBST1: HRRZ T4,.RCCKB(FTL) ;POINT TO CONVERTED KEY BUFFER
HRLI T4,440000 ;LH = BYTE RESIDUE
DPB T1,[POINT 12,T4,17] ;STORE IN REST OF PARAM
MOVEM T4,CVPRM.+1 ;SAVE PARAM+1
MOVE T1,.RCBPR(FTL) ;GET BP TO RECORD
HRRZ T2,BS.AGL ;REPLACE RECORD ADDR WITH KEY BUFFER ADDR
HRR T1,1(T2)
MOVEM T1,CVPRM. ;SAVE PARAM+0
PUSHJ PP,SVPACS ;SAVE PERM ACS.
MOVEI ARG,CVPRM. ;ARGUMENTS TO CONVERSION ROUTINE ARE HERE
HLRZ T1,.RCCRS(FTL) ;GET A ROUTINE TO CONVERT FROM KEY BUFFER MODE.
PUSHJ PP,(T1) ;;CALL IT
POPJ PP, ;RETURN
SUBTTL RMS DELETE - INDEXED FILE
;ARG FORMAT:
;ARG-ADDR: FLAG-BITS,,FILTAB-ADDR
;ARG-ADDR+1: [PRIMARY KEY BUFFER ADDRESS] ;RANDOM DELETE ONLY
;FLAGS-BITS:
DL%NIK==1B9 ;NO INVALID KEY CLAUSE GIVEN
; "USE PROCEDURE" INSTEAD
DL.MIR: PUSHJ PP,DLST ;START DELETE, RETURN IF OK
MOVE T1,.RCSTE(FTL) ;GET FILE'S STATE
CAIN T1,RC.SUR ;IF SUCCESSFUL READ WAS JUST DONE,
MOVEI T1,RC.UNF ; SET STATE TO "UNDEFINED"
MOVEM T1,.RCSTE(FTL) ;STORE NEW STATE
;DO A $FIND TO POSITION TO THE RECORD
PUSHJ PP,FNDIT
JRST DLMIRE ;?CAN'T FIND THAT RECORD
;NOW DELETE THE RECORD
MOVE T2,.RCRAB(FTL) ;POINT TO RAB AGAIN
JRST DLGO ;GO DO THE $DELETE
;HERE IF THE FIND FAILED
DLMIRE: JRST CPOPJ1 ;RETURN "INVALID KEY"
DL.MIS: PUSHJ PP,DLST ;START DELETE, RETURN IF OK
; THE LAST I-O MUST HAVE BEEN A SUCCESSFUL READ STMT.
MOVE T1,.RCSTE(FTL) ;GET FILE'S STATE
CAIE T1,RC.SUR ; SKIP IF SUCCESSFUL READ WAS JUST DONE
JRST DLMSE2 ;NO, GIVE ERROR
MOVEI T1,RC.UNF ;SET NEW STATE TO "UNDEFINED"
MOVEM T1,.RCSTE(FTL)
; WE WILL DELETE THE RECORD READ.
DLGO: MOVE T2,.RCRAB(FTL) ;POINT TO RAB
MOVEI T1,RB$WBH ;ONLY WRITE BEHIND
$STORE T1,ROP,(T2) ;STORE RECORD OPTIONS
PUSH PP,T2 ;[1046] SAVE RAB
$DELETE <(T2)>,DELSER ;SEQ. DELETE ERROR
POP PP,T2 ;[1046] RESTORE RAB
LDB T0,FT.CRC ;[1046] CHECKPOINTINT ?
JUMPE DLG1 ;[1046] NO
SOSE D.CRC(FT) ;[1046] DECREMENT COUNT, TIME TO OUTPUT ?
JRST DLG1 ;[1046] NOT YET
LDB T0,FT.CRC ;[1046] GET COUNT
MOVEM T0,D.CRC(FT) ;[1046] RESET IT
$FLUSH <(T2)>,FSHERR ;[1046] WRITE RECORD (S) TO DSK
DLG1: PUSHJ PP,SETFS ;[1046] SET FILE-STATUS TO 0
POPJ PP, ;AND RETURN TO USER PROG.
DELSER: MOVE T2,.RCRAB(FTL) ;ADDR OF THE RAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
TYPE [ASCIZ/
?$DELETE failed
/]
JRST RSFAIR ;RMS-SYSTEM FAILURE
;"DELETE of seq. access file was not immediately proceeded
; by a successful READ"
DLMSE2: $ERROR (E.517,SV.KIL,MT.FIL)
SUBTTL RMS REWRITE ENTRY POINTS
;ARG FORMAT:
;ARG-ADDR: FLAG-BITS,,FILTAB-ADDR
;ARG-ADDR+1: REWRITE RECORD LENGTH,,KEY-BUFFER-ADDRESS
;FLAG-BITS:
RW.NIK==1B9 ;NO "INVALID KEY" CLAUSE GIVEN
RW.MIR: PUSHJ PP,RWST ;START REWRITE
MOVE T1,.RCSTE(FTL) ;GET FILE'S STATE
CAIN T1,RC.SUR ;IF SUCCESSFUL READ WAS JUST DONE,
MOVEI T1,RC.UNF ; SET STATE TO "UNDEFINED"
MOVEM T1,.RCSTE(FTL) ;STORE NEW STATE
PUSHJ PP,FNDIT ;FIND THE RECORD
JRST RWMIRE ;?CAN'T FIND THE KEY
;NOW UPDATE THE RECORD
RWGO: MOVE T2,.RCRAB(FTL) ;POINT TO RAB
;ADDRESS OF RECORD - ALREADY SETUP BY OPEN
;SIZE OF RECORD -- FROM ARG LIST.
MOVE T1,BS.AGL
HLRZ T1,1(T1) ;GET SIZE OF RECORD
$STORE T1,RSZ,(T2) ;STORE IT
PUSH PP,T2 ;[1046] SAVE RAB
;RECORD ACCESS OPTIONS ARE LEFT AT "0" (FNDIT SET THEM)
$UPDATE <(T2)>,UPDERR ;** DO THE UPDATE **
PUSHJ PP,CHKSDP ;CHECK FOR SUCCESSFUL RETURN, BUT DUPLICATE KEY
POP PP,T2 ;[1046] RESTORE RAB
MOVE T1,FS.FS ;GET FILE-STATUS
CAIL T1,^D20
CAILE T1,^D29 ;SOME KIND OF INVALID KEY?
JRST UPDOK ;NO
JRST CPOPJ1 ;YES, RETURN "INVALID KEY"
UPDOK: LDB T0,FT.CRC ;[1046] CHECKPOINTING ?
JUMPE UPDO1 ;[1046] NO
SOSE D.CRC(FT) ;[1046] DECREMENT COUNT - TIME TO OUTPUT ?
JRST UPDO1 ;[1046] NOT YET
LDB T0,FT.CRC ;[1046] GET COUNT
MOVEM T0,D.CRC(FT) ;[1046] RESET COUNT
$FLUSH <(T2)>,FSHERR ;[1046] UPDATE DISK
UPDO1: PUSHJ PP,SETFS ;SET FILE-STATUS WORD
POPJ PP, ;AND RETURN SUCCESSFULLY
UPDERR: MOVE T2,.RCRAB(FTL) ;POINT TO RAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
CAIN T1,ER$DUP ;DUPLICATE KEY?
JRST UPDERK ;YES
CAIN T1,ER$CHG ;KEYS CANNOT BE CHANGED?
JRST UPDERC ;YES
CAIN T1,ER$RSZ ;ATTEMPT TO CHANGE RECORD SIZE?
JRST UPDERS ; FATAL ERROR FOR USER
TYPE [ASCIZ/
?LIBOL: $UPDATE failed
/]
JRST RSFAIR
;DUPLICATE KEY ERROR ON UPDATE
UPDERK: MOVEI T1,^D22 ;SET FILE-STATUS
MOVEM T1,FS.FS
PUSHJ PP,SETFS
POPJ PP, ;AND RETURN
;KEYS CANNOT BE CHANGED BY UPDATE
;LOOK AT STV TO SEE WHICH KEY CAUSED THE PROBLEM
UPDERC: $FETCH T1,STV,(T2) ;GET KEY NUMBER
JUMPE T1,RWMISE ;PRIMARY KEY: READ SEQ FAILURE
$ERROR (E.506,SV.FAT,MT.FIL,CPOPJ) ;"ATTEMPT TO CHANGE KEY VALUE"
;*** ERROR: USER ATTEMPTED TO CHANGE RECORD SIZE.
UPDERS: $ERROR (E.522,SV.KIL,MT.FIL)
;HERE IF THE FIND FAILED
RWMIRE: JRST CPOPJ1 ;RETURN "INVALID KEY"
RW.MIS: PUSHJ PP,RWST ;START REWRITE
;CHECK HERE TO SEE IF LAST OPERATION WAS A SUCCESSFUL READ
MOVE T1,.RCSTE(FTL) ;GET FILE'S STATE
CAIE T1,RC.SUR ; SKIP IF SUCCESSFUL READ WAS JUST DONE
JRST RWMSE2 ;NO, GIVE ERROR
MOVEI T1,RC.UNF ;SET NEW STATE TO "UNDEFINED"
MOVEM T1,.RCSTE(FTL)
MOVE T2,.RCRAB(FTL) ;POINT TO RAB
MOVEI T1,RB$SEQ ;SIGNAL SEQUENTIAL ACCESS
$STORE T1,RAC,(T2)
MOVEI T1,RB$WBH ;ONLY WRITE BEHIND
$STORE T1,ROP,(T2) ;STORE RECORD OPTIONS
JRST RWGO ;GO DO REWRITE
;HERE IF WE TRIED TO CHANGE THE PRIMARY KEY
;THIS IS AN INVALID KEY CONDITION
RWMISE: MOVEI T1,^D21 ;FILE-STATUS VALUE
MOVEM T1,FS.FS ;STORE IT
PJRST SETFS ;TELL USER PROGRAM, RETURN FROM UPDERR
;"SEQ MODE REWRITE WAS NOT IMMEDIATELY PROCEEDED BY A SUCCESSFUL READ"
RWMSE2: $ERROR (E.516,SV.KIL,MT.FIL) ;GIVE KILL ERROR
;ROUTINE TO FIND A RECORD
; CALLED FROM RANDOM DELETE OR REWRITE.
;THIS ROUTINE SKIPS IF THE $FIND WAS SUCCESSFUL
;IT EXPECTS TO FIND THE KEY BUFFER ADDRESS IN RH(ARG-LIST + 1)
FNDIT: MOVE T2,.RCRAB(FTL) ;MAKE T2 POINT TO THE RAB
MOVEI T1,RB$KEY ;SIGNAL KEYED ACCESS
$STORE T1,RAC,(T2)
;SET KEY OF REFERENCE TO THE PRIMARY KEY
MOVEI T1,0
$STORE T1,KRF,(T2)
;SET SIZE OF KEY
HRRZ T4,.RCKIN(FTL) ;POINT TO KEY INFO
HRRZ T4,1(T4) ;GET SIZE OF PRIMARY KEY IN BYTES
$STORE T4,KSZ,(T2)
;SET KEY BUFFER ADDRESS
TXNE FLG,CF%CNV ;CONVERSION REQUIRED?
JRST FNDIT1 ;YES
MOVE T1,BS.AGL ;GET BASE OF ARG LIST
HRRZ T1,1(T1) ;GET KEY BUFFER ADDRESS
$STORE T1,KBF,(T2) ;TELL RMS
JRST FNDIT2 ;GO ON
;CONVERT THE KEY FROM @RH( ARG-LIST + 1) TO THE KEY BUFFER
FNDIT1: MOVE T1,T4 ;GET KEY SIZE
PUSHJ PP,RKBST1 ; CONVERT THE KEY
MOVE T2,.RCRAB(FTL) ;RESTORE T2
;TELL FIND WE WANT KEY=
FNDIT2: MOVEI T1,0 ;NO ALTERNATE OPTIONS
$STORE T1,ROP,(T2)
;** DO IT **
$FIND <(T2)>,FNDITE ;** START = RECORD **
MOVE T2,.RCRAB(FTL)
MOVE T1,FS.FS ;GET STATUS
JUMPE T1,CPOPJ1 ;SKIP RETURN IF OK
POPJ PP, ;ERROR RETURN
;HERE IF $FIND FAILED TRYING TO POSITION TO THE RECORD.
; THIS IS PROBABLY A "RECORD NOT FOUND" = INVALID KEY ERROR
FNDITE: MOVE T2,.RCRAB(FTL) ;ADDR OF THE RAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
CAIN T1,ER$RNF ;RECORD NOT FOUND?
JRST FNDITF ;YES, SET "INVALID KEY/NO RECORD"
TYPE [ASCIZ/
?LIBOL: $FIND failed for REWRITE or DELETE
/]
JRST RSFAIR
FNDITF: MOVEI T1,^D23 ;SET "INVALID KEY - RECORD NOT FOUND"
MOVEM T1,FS.FS
JRST SETFS ;SET IT AND RETURN
;ROUTINE TO CHECK FOR DUPLICATE KEY WRITTEN (WRITE OR REWRITE).
;; IT LOOKS AT THE STS RETURNED IN THE RAB, AND CHECKS FOR "SU$DUP".
; IF THAT SUCCESS CODE IS GIVEN, SET FS.FS TO 02.
CHKSDP: MOVE T2,.RCRAB(FTL) ;POINT TO RAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
CAIE T1,SU$DUP ; SUCCESSFUL, BUT DUPLICATE KEYS?
POPJ PP, ;NO, LEAVE FS.FS ALONE.
MOVEI T1,02 ;PUT 02 IN FS.FS
MOVEM T1,FS.FS
POPJ PP, ;AND RETURN
;ROUTINE TO START REWRITE
; ONLY RETURNS IF THINGS ARE OK
RWST: PUSHJ PP,SETIO ;SETUP FOR IO
TXNN FLG,LF%IO ;SKIP IF OPEN FOR IO
JRST RWENIO ;NOT OPEN IO, COMPLAIN
TXNN FLG,CF%CNV ;SKIP IF RECORD NEEDS CONVERTING
POPJ PP, ;ALL OK, RETURN
;COPY RECORD AREA TO BUFFER ADDRESS
;LH (ARG-LIST+1) IS THE LENGTH OF THE RECORD TO WRITE
JRST COPRCB ;GO DO IT LIKE "WRITE" DOES
;ROUTINE TO START DELETE
; ONLY RETURNS IF THINGS ARE OK
DLST: PUSHJ PP,SETIO ;SETUP FOR IO
TXNN FLG,LF%IO ;SKIP IF OPEN FOR IO
JRST DLENIO ;NOT OPEN IO, COMPLAIN
POPJ PP, ;RETURN
RWENIO: $ERROR (E.502,SV.KIL,MT.FIL)
DLENIO: $ERROR (E.501,SV.KIL,MT.FIL)
SUBTTL RMS START ENTRY POINTS
;ARG FORMAT:
;ARG-ADDR: FLAG-BITS,,FILTAB-ADDR
;ARG-ADDR+1: KEY OF REF,,KEY BUFFER ADDRESS
;ARG-ADDR+2: [LENGTH OF APPROXIMATE KEY]
;
; WHERE START FLAG-BITS ARE DEFINED AS:
;
STA%EQ==3B13 ;EQUAL TO (IF 0)
STA%NL==1B12 ;NOT LESS THAN
STA%GT==1B13 ;GREATER THAN
STA%AK==1B14 ;START WITH APPROXIMATE KEY
STA%NI==1B15 ;NO "INVALID KEY" CLAUSE GIVEN
; "USE PROCEDURE" INSTEAD
;IF STA%AK IS 0, THEN ARG-ADDR+2 IS NOT USED
ST.MEQ: PUSHJ PP,STAST ;START "START"
MOVEI T1,RB$NRP ;SET NEXT RECORD PTR
$STORE T1,ROP,(T2) ;STORE
JRST ST.GO ;ALL DONE, GO
ST.MGT: PUSHJ PP,STAST ;START "START"
MOVEI T1,RB$KGT!RB$NRP ;GREATER THAN
$STORE T1,ROP,(T2) ;STORE
JRST ST.GO ;AND GO
ST.MNL: PUSHJ PP,STAST ;START "START"
MOVEI T1,RB$KGE!RB$NRP ;GREATER OR EQUAL
$STORE T1,ROP,(T2) ;STORE
ST.GO: $FIND <(T2)>,FNDERR ;** DO THE FIND **
MOVE T1,FS.FS ;GET STATUS
JUMPE T1,FNDOK ;RETURN OK IF ZERO
CAIL T1,^D20 ;SOME KIND OF INVALID KEY?
CAILE T1,^D29
POPJ PP, ;NO, AN IGNORED ERROR
AOS (PP) ;INVALID KEY RETURN
POPJ PP,
FNDOK: PUSHJ PP,SETFS ;SET FILE-STATUS TO ZERO
MOVEI T1,RC.UNF ;SET FILE'S STATE TO "UNDEFINED"
MOVEM T1,.RCSTE(FTL) ; (THIS CLEARS "AT END" IF SET)
POPJ PP, ;NORMAL RETURN
;RMS-ERROR ROUTINE IF $FIND FAILED
FNDERR: MOVE T2,.RCRAB(FTL) ;ADDR OF THE RAB
$FETCH T1,STS,(T2) ;GET STATUS RETURNED
CAIN T1,ER$RNF ;RECORD NOT FOUND?
JRST FNDE23 ;YES, SET "INVALID KEY/NO RECORD"
TYPE [ASCIZ/
?$FIND FAILED
/]
JRST RSFAIR
FNDE23: MOVEI T1,^D23 ;SET FILE-STATUS
MOVEM T1,FS.FS
PUSHJ PP,SETFS ;FOR "INVALID KEY"
POPJ PP, ;AND RETURN
;ROUTINE TO SETUP FOR DOING A "START". RETURNS ONLY IF EVERYTHING
; IS OK, WITH ACS SET UP.
STAST: PUSHJ PP,SETIO ;SETUP FOR IO
TXNN FLG,LF%INP ;SKIP IF OPEN FOR INPUT OR I-O
JRST STASE1 ;NO, GIVE ERROR
MOVE T1,.RCSTE(FTL) ;GET FILE'S STATE
CAIN T1,RC.SUR ; WAS LAST THING A SUCCESSFUL READ?
MOVEI T1,RC.UNF ;YES, SET NEW STATE TO "UNDEFINED"
MOVEM T1,.RCSTE(FTL) ;SAVE UPDATED STATE
MOVE T2,.RCRAB(FTL) ;T2 POINTS TO RAB
MOVEI T1,RB$KEY ;SIGNAL KEYED ACCESS
$STORE T1,RAC,(T2)
;STORE KEY OF REFERENCE, AND KEY BUFFER ADDRESS
MOVE T1,BS.AGL ;GET BASE OF ARG LIST
HLRZ T3,1(T1) ;GET KEY OF REFERENCE FROM ARG LIST
$STORE T3,KRF,(T2) ;TELL RMS
MOVEM T3,.RCKRF(FTL) ;REMEMBER THE KEY OF REFERENCE
TXNN FLG,CF%CNV ;IS CONVERSION REQUIRED?
JRST STAS1 ;NO, SKIP THIS
HRRZ T3,.RCCKB(FTL) ; USE CONVERTED BUFFER ADDRESS
$STORE T3,KBF,(T2) ;TELL RMS
;SET T1= SIZE OF KEY TO MOVE, THEN CALL RKBST1 TO MOVE IT
TXNE FLG,STA%AK ;START WITH APPROX. KEY?
JRST STAS0 ;YES, USE KEY SIZE GIVEN
PUSHJ PP,RKBSET ;MOVE WHOLE KEY
MOVE T2,.RCRAB(FTL) ;RESTORE T2
JRST STAS2 ;GO ON
;MOVE # CHARS NEEDED FOR APPROX. KEY
STAS0: MOVE T1,BS.AGL ;POINT TO ARG LIST
MOVE T1,2(T1) ;GET SIZE OF KEY PASSED IN ARG LIST
PUSHJ PP,RKBST1 ;MOVE THE KEY TO KEY BUFFER
MOVE T2,.RCRAB(FTL) ;;RESTORE T2
JRST STAS2 ;GO ON
;NO CONVERSION REQUIRED
STAS1: HRRZ T3,1(T1) ;GET KEY BUFFER ADDRESS FROM ARG LIST
$STORE T3,KBF,(T2) ;TELL RMS
;FALL INTO STAS2
;HERE WHEN KEY HAS BEEN MOVED AND CONVERTED AS NECESSARY.
;STORE SIZE OF KEY IN THE RAB
STAS2: TXNE FLG,STA%AK ;APPROXIMATE KEY?
JRST STAS3 ;YES, USE SIZE IN ARG LIST
HRRZ T4,.RCKIN(FTL) ;POINT TO KEY INFO
HRRZ T3,BS.AGL ;GET KEY OF REF.
HLRZ T3,1(T3) ; INTO T3
LSH T3,1 ;EACH IS TWO WORDS
ADDI T4,1(T3) ;POINT TO APPROPRIATE KEY-INFO BLOCK
HRRZ T1,(T4) ;GET KEY SIZE
$STORE T1,KSZ,(T2) ;STORE SIZE OF KEY BLOCK
POPJ PP, ;RETURN OK
STAS3: MOVE T1,BS.AGL ;POINT TO ARG LIST
MOVE T1,2(T1) ;GET SIZE OF KEY PASSED IN ARG LIST
$STORE T1,KSZ,(T2) ;STORE SIZE OF KEY BLOCK
POPJ PP, ;AND RETURN
;HERE TO GIVE ERROR BECAUSE "START" WAS CALLED AND FILE
; WAS NOT OPEN FOR INPUT OR I-O
STASE1: $ERROR (E.514,SV.KIL,MT.FIL)
END