Trailing-Edge
-
PDP-10 Archives
-
bb-4157j-bm_fortran20_v11_16mt9
-
fortran-ots-debugger/forrms.mac
There are 7 other files named forrms.mac in the archive. Click here to see a list.
SEARCH MTHPRM,FORPRM
TV FORRMS RMS INTERFACE, 11(5023)
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1981, 1987
;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 AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
;++
; FACILITY: FORTRAN/RMS Interface
;
; ABSTRACT:
;
; Contains all routines which perform RMS I/O. Any code which
; must SEARCH RMSINT/RMSINJ must be in this module.
;
; ENVIRONMENT: FORTRAN Runtime System
;
; AUTHOR: Tom Speer
;
; CREATION DATE: 1-Dec-83
;
; MODIFIED BY:
COMMENT \
***** Begin Revision History *****
4065 JLC 6-Dec-83
Added some new entries for the skeleton.
4066 JLC 11-Jan-84
More new entries for the skeleton.
4072 JLC 24-Jan-84
Begin coding.
4102 JLC 17-Feb-84
Remove a global which was removed from FOROPN.
4122 JLC 2-May-84
Add some more globals.
4131 JLC 12-Jun-84
Add non-skip memory full return to %GTBLK call.
***** Begin Version 11 *****
5000 TGS 1-Jul-85
Implement RMS OPEN.
5001 TGS 1-Aug-85
Implement RMS INQUIRE.
5002 TGS 1-Sep-85
Implement RMS CLOSE.
5003 TGS 24-Oct-85
Implement RMS READ.
5004 TGS 10-Nov-85
Implement RMS WRITE.
5007 TGS 4-Jan-86
RMS error-handling.
5013 TGS 28-May-86
RMS file-positioning.
5014 MRB 6-JUN-86
Implement RMS UNLOCK statement. Routines %RMCUL, %RMUNL, FREE$
5016 MRB 16-Jun-86
Implement MAXREC keyword in open statements.
5023 TGS 18-Nov-86
Pre-diagnose ER$REX errors to avoid various network problems.
***** End Revision History *****
\
SUBTTL INTERN-EXTERN DECLARATIONS
;
; Conditional compilation Macros
;
;If FTEXT is zero, the processor does not support extended addressing
;RMS invocations. Such machines not only do not need the code in
;FORRMS, they can't compile it, since the .REQUIRE files
;for RMS are not on their system.
IF10,< IFNDEF FTEXT,<FTEXT==0> ;Default on -10
> ;End IF20
IF20,< IFNDEF FTEXT,<FTEXT==-1> ;Default on -20
> ;End IF20
;Tell which version we are assembling
IF1,<
IFN FTEXT,<PRINTX [Extended version]>
IFE FTEXT,<PRINTX [Non-Extended version]>
>
DEFINE IFRMS <IFN FTEXT> ;RMS can be invoked
DEFINE IFNRMS <IFE FTEXT> ;RMS cannot be invoked
;%IF20 conditionals are like IF20 ones, except that if FTEXT=0 (non-
; RMS environment) nothing within a %IF20 assembles at all.
; The RMSENT macro defines ENTRY points as POPJ's for a non-RMS
; environment--just enough defined so FOROTS can be compiled without error.
DEFINE %IF20, <
IFRMS> ;End %IF20
DEFINE RMSENT (NAM),<
ENTRY NAM ;;ENTRY on -10/-20
IF20,< ;;If -20
IFE FTEXT < ;;and not RMS-able
IRP <NAM>,<NAM': POPJ P,> ;;Dummy entries
> ;End IFE
> ;End IF20
> ;End RMSENT
%IF20,<
SEARCH RMSINJ
.REQUIRE SYS:RMSZER
.REQUIRE SYS:RTLZNM
.REQUIRE SYS:ZERBOO
.REQUIRE SYS:DYNBOO
> ;End %IF20
SEGMENT CODE
IF20,<
INTERN %ERMIN ;[5007]
ENTRY FNDRMS ;[5000]
RMSENT <%IRMS,%ORMS,%UORMS,%RMOPN,%RMLKP,%RMRFS> ;[5000]
RMSENT <%RMGXF,%RMOSW,%RMISW,%RSISW,%RMCLS,%RMREW,%RMBSR> ;[5000]
RMSENT <%RMEND,%RMSIN,%RMSOU,%RMRDW,%CHKBD> ;[5000]
RMSENT <%RMREN,%RMDSP,%RMEFN,%RMCSY> ;[5002]
RMSENT <%RMERR,%RMECL> ;[5007]
RMSENT <%RMCRW> ;[5004]
RMSENT <%RMCDL,%RMDEL> ;[5013]
RMSENT <%RMCUL,%RMUNL> ;[5014]
> ;End IF20
ENTRY %RMCKF ;[5000]
RMSENT <%RMDAB,%RMASV,%RMKOP,%RMDKB,%RMDFA> ;[5000]
RMSENT <%RMFND> ;[5004]
RMSENT <%RMECK> ;[5007]
RMSENT <%RSOSW> ;[5000]
EXTERN %POPJ,%POPJ1
IF20,<
;EXTERNS IN FORERR:
EXTERN %RMPDP,ERRPTR,OCTTYP,ASCTYP,%ERNM2,%ERNM3 ;[5007]
EXTERN INICHR,%RMEPT,FOREC2,EMSGT0,%ERPTR,ERRCNT ;[5007]
EXTERN LERRBF ;[5007]
EXTERN %ERIOS ;[5014]
;EXTERNS IN FORIO:
EXTERN %CUNIT ;[5000]
EXTERN SETPTR,%OCLR,RECLEN,PAGNUM ;[5003]
EXTERN A.REC,A.KVL,A.KRL,A.KID,D.KEY,EXPIRB,GETIRB ;[5003]
EXTERN GETORB,ORINI,BYTUSD,%SETAV,A.FMT ;[5004]
EXTERN %CUNIT,%BAKEF ;[5013]
EXTERN A.IOS ;[5014]
;EXTERNS IN FORMEM:
EXTERN %GTBLK,%FREBLK,%GTPGS,%FREPGS ;[5000]
EXTERN %GTSPC ;[5003]
EXTERN %MVBLK ;[5004]
;EXTERNS IN FOROPN:
EXTERN O.KEY,%TXTBF,TXTBF2,OPNSWT,KEYVAL,FNDSWT ;[5000]
EXTERN %ARGNM,SWRECT,FNSPNT,FNSCLR,%GNPNT,FNOJFN ;[5000]
EXTERN ASCFNS,RELJFN,%DOJFNS,RANALC,CHKBSZ,BSTAB ;[5000]
EXTERN %RSEOF,FDB,OPCNF ;[5000]
EXTERN UNKXST ;[5001]
EXTERN DSKREN,%RNAMD,%OLDDB,CLSDDB,SWDISC,JFNBLK ;[5002]
EXTERN ILLOUT,%SOCNT,%SETIN ;[5004]
EXTERN %SETOUT,%SETIN ;[5013]
;EXTERNS IN FOROTS:
EXTERN %FSECT,%ABFLG ;[5007]
EXTERN %DDBTAB,%UDBAD ;[5013]
;EXTERNS IN FORXIT:
EXTERN ABORT. ;[5000]
> ;End IF20
SUBTTL %RMKOP - Setup a FAB/XAB chain
;***************************************************************************
;* *
;* ENTRIES CALLED FROM FOROPN *
;* *
;***************************************************************************
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine allocates a FAB/XAB chain and fills in the XAB(s)
; with KEY specifier data. It is called from OPEN keyword processing
; and from DIAKEY when parsing a /KEY: in DIALOG mode. Deallocates
; any FAB/RAB/XAB which already exists for this (D), then allocates
; a new FAB/XAB chain.
;
; O.KEY points to an argument list of the form:
;
;
; -N,,0 ;N is KSPLEN*number_keys
; xM: IFIW TP%INT,[LB] ;primary key first char
; IFIW TP%INT,[UB] ;primary key last char
; IFIW type,0 ;type is TP%INT or TP%CHR
; .....
; IFIW TP%INT,[LB] ;last key first char
; IFIW TP%INT,[UB] ;last key last char
; IFIW type,0 ;type is integer or character
;
; If the arglist has been constructed in DIALOG, LB and UB values
; are immediate and the left half of each entry except for data
; type is zero.
;
; P1 is the secondary arglist pointer
; P2 is an AOBJN index: -Number_of_specifiers,,key_of_reference
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMKOP
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; O.KEY - Address of secondary argument list
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB(D) - Address of FAB
; XAB(D) - Address of XAB
; POS - Starting byte position of key
; SIZ - Size of key
; DTP - Key's datatype
; REF - Key-of-reference number
; NXT - Pointer to next XAB in chain
; STGFLG(D) - -1 if XAB chain has CHARACTER DTP
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4,P1,P2
; Deallocates any prexisting FAB/RAB/XAB on entry
;
;--
;[5000] New
IF10,<
%RMKOP: $SNH ;Should not get here on -10
> ;End IF10
%IF20,<
MAXCHR==^D255 ;CHARACTER keys must be equal to/less
;than this length
INTLEN==4 ;INTEGER keys must be 4 bytes long
%RMKOP: PUSHJ P,%RMDAB ;Deallocate any arg blocks
PUSHJ P,RMFAB ;Allocate a FAB
MOVEM T1,FAB(D) ;Save its address
SETZM STGFLG(D) ;Clear CHARACTER-in-XAB flag
SETZM PXBADR ;Initialize previous XAB address
MOVE P1,O.KEY ;Get address of secondary arglist
XMOVEI P1,@P1 ; alone
;Initialize AOBJN pointer with -number_of_specifiers,,key_of_reference#
HLRE T1,-1(P1) ;Get argument count
IDIVI T1,KSPLEN ;Get number of specifiers
MOVSI P2,(T1) ;-key_num,,key_ref
;TOP OF KEY_SPECIFIER LOOP
KEYLP: PUSHJ P,RMXAB ;Allocate a XAB
MOVE T4,T1 ;Copy current XAB address
SKIPN PXBADR ;Prime key XAB (no previous)?
MOVEM T4,XAB(D) ;Yes, save start of chain
;Get Lower Bound argument and store
MOVE T2,LBO(P1) ;Get LB argument
TLNE T2,-1 ;Immediate?
MOVE T2,(T2) ;No
MOVEM T2,SAVLB ;Save
PUSHJ P,%CHKBD ;Check validity
JRST KERR ;Bad
SUBI T2,1 ;LB-1: 0 is starting byte
$STORE T2,POS,<(T4)> ;Store starting byte
;Get Upper Bound argument
MOVE T2,UBO(P1)
TLNE T2,-1 ;Immediate?
MOVE T2,(T2) ;No
MOVEM T2,SAVUB ;Save
PUSHJ P,%CHKBD ;Check bound validity
JRST KERR ;Bad
SUBI T2,1 ;Adjust for zero start
$FETCH T1,POS,<(T4)> ;Get lower bound again
CAMGE T2,T1 ;UB greater than/equal to start?
JRST KERR ;No, bad argument
;Calculate key size as UB-LB+1 and store
MOVE T1,SAVLB ;Get user's lower bound
MOVE T2,SAVUB ;and upper
SUBI T2,-1(T1) ;UB-LB+1
$STORE T2,SIZ,<(T4)> ;Store in current XAB
;Get key data type
MOVX T2,XB$STG ;Default to string (CHARACTER)
LDB T1,[POINTR (DTO(P1),ARGTYP)] ;Get type
CAIN T1,TP%INT ;INTEGER?
MOVX T2,XB$IN4 ;Yes
$STORE T2,DTP,<(T4)> ;Store in current XAB
$FETCH T1,SIZ,<(T4)> ;Get key size
CAIE T2,XB$STG ;CHARACTER?
JRST NOTCHR ;No
SETOM STGFLG(D) ;Yes,flag it.
CAILE T1,MAXCHR ;Bigger than RMS max?
JRST KERR ;Yes, error
JRST STFLG ;No, go setup key attributes
NOTCHR: CAIE T2,XB$IN4 ;INTEGER?
$SNH ;No, bad arglist
CAIE T1,INTLEN ;Yes. Is length = 4?
JRST KERR ;No. bad key value
$STORE T1,SIZ,<(T4)>
;Set default DUP/CHG attributes
STFLG: MOVX T1,XB$CHG!XB$DUP ;Default allows DUP/CHG for non-prime
SKIPN PXBADR ;Prime XAB (no previous)?
SETZ T1, ;Yes, no DUP/CHG
$STORE T1,FLG,<(T4)> ;Store in current XAB
;Store the key-of-reference from AOBJN RH
HRRZ T1,P2
$STORE T1,REF,<(T4)>
;If not the first XAB allocated, establish a backward link and fill in
; X$NXT of the previous XAB.
SKIPE T1,PXBADR ;Was there a previous XAB?
$STORE T4,NXT,<(T1)> ;Yes, store the link
MOVEM T4,PXBADR ;Store current XAB address in previous
;BOTTOM OF KEY_SPECIFIER LOOP
ADDI P1,KSPLEN ;Move arg pntr to next section
AOBJN P2,KEYLP ;Increment key_num, key_ref and loop
;Here after all arglist processing. Link in either FAB F$XAB or (if there
; is one) CONFIG XAB X$NXT with start of chain.
PUSHJ P,LNKXAB ;Link to FAB or CONFIG
POPJ P, ;Return
;Here on argument-invalid errors in the arglist. Since we may have allocated
; a XAB but not yet fully linked it in the chain, we must complete the link
; so everything gets properly deallocated.
KERR: SKIPE T1,PXBADR ;Was there a previous XAB?
$STORE T4,NXT,<(T1)> ;Yes, link current to it
PUSHJ P,LNKXAB ;Link FAB or CONFIG
PUSHJ P,%RMDAB ;Deallocate everything
PUSHJ P,%RMDKB ; including the arglist
MOVE T1,KEYVAL ;Get keyword value
MOVEI T2,OPNSWT ;Find ASCII name for keyword
PUSHJ P,FNDSWT
MOVEM T1,%ARGNM ;Save for error
$DCALL IAV ;"?Ilegal value for /KEY:"
SEGMENT DATA
SAVLB: BLOCK 1 ;SAVE LOWER BOUND
SAVUB: BLOCK 1 ;SAVE UPPER BOUND
SEGMENT CODE
> ; End %IF20
SUBTTL %RMECK - Cleanup after failing FOROPN OPEN
;++
; FUNCTIONAL DESCRIPTION:
;
; Called after a failing FOROPN open-by-device call to DOOPEN.
; If the file is an RMS file, performs a dummy $CLOSE to release
; any network link. If TOPS-10 or non-RMS, a no-op.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMECK
; <Return here; always requests DIALOG>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T4.
; If file is RMS, $CLOSEs FAB.
;--
;[5007] New
IF10,<
%RMECK: POPJ P, ;No RMS errors on TOPS10
> ;End IF10
%IF20,<
%RMECK: SKIPN FAB(D) ;RMS involved?
POPJ P, ;No, just return
PJRST RLSLNK ;Yes, go do it
> ;End %IF20
SUBTTL LNKXAB - Link XAB(D)
;++
; FUNCTIONAL DESCRIPTION:
;
; Called on completion of Key XAB processing to link FAB FB$XAB to the
; start of the Key chain XABs. If there is a CONFIG XAB, link its NXT
; field instead.
;
; CALLING SEQUENCE:
;
; PUSHJ P,LNKXAB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
; XAB(D) - Address of XAB
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB F$XAB - Set to start of key chain if file is local
; CONFIG X$NXT - Set to start of key chain if file is remote
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T3.
;
;--
;[5000] New
%IF20,<
LNKXAB: MOVE T1,FAB(D) ;Get FAB's address
MOVE T3,XAB(D) ;Get key chain start
$FETCH T2,XAB,<(T1)> ;Get FAB's link field
JUMPN T2,LNKCFG ;Non-zero if a CONFIG
$STORE T3,XAB,<(T1)> ;store start in FAB FB$XAB
POPJ P, ;Return
LNKCFG: $STORE T3,NXT,<(T2)> ;link start to CONFIG X$NXT
POPJ P, ;Return
> ; End %IF20
SUBTTL %CHKBD - Check KEY= bound validity
;++
; FUNCTIONAL DESCRIPTION:
;
; Checks that a LB or UB KEY= value is valid. LB/UB values
; must be .GE. zero and must not be more than 17 bits.
; (Actually the maximum RMS record size for indexed
; records on TOPS20 results in LB/UB ceilings considerably less than
; 17 bits; this routine checks only that a well-formed XAB chain can
; be handed to RMS).
;
; CALLING SEQUENCE:
;
; PUSHJ P,%CHKBD
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; T2 - Value to be checked
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; T2 - Orginal value returned
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T2.
;
;--
;[5000] New
%IF20,<
%CHKBD: JUMPLE T2,%POPJ ;.LE. zero
TLNN T2,-1 ;Overflow on left?
TRNE T2,(1B0) ;or on right?
POPJ P, ;Yes, error return
JRST %POPJ1 ;OK return
> ; End %IF20
SUBTTL %RMCKF - Check for conflicting RMS OPEN keywords
;++
; FUNCTIONAL DESCRIPTION:
;
; Called from FOROPN CKCONF to check for conflicting OPEN RMS
; keywords. If a conflict is found, an ICA message is issued via
; a call to OPCNF.
;
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMCKF
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ACC(D) - ACCESS=
; ORGAN(D) - ORGANIZATION=
; O.KEY - KEY= in OPEN
; RECTP(D) - RECORDTYPE=
; RSIZE(D) - RECL=
; SHARE(D) - SHARED
; RO(D) - READONLY
; STAT(D) - STATUS=
;
; ORKYTB - Table by ORGANIZATION of legal/illegal
; KEY= values
; ORACTB - Table by ORGANIZATION of illegal
; /ACCESS codes
; ORRTTB - Table by ORGANIZATION of illegal
; /RECORDTYPE codes
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; If both /SHARED and /READONLY are specified, SHARE(D) and RO(D)
; are cleared.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
;
;--
;[5000] New
IFNRMS,< ;TOPS-10 and KS build
%RMCKF: JRST %POPJ1
> ;End IFNRMS
%IF20,<
%RMCKF: SETZM IMPORG ;Clear local flag (implied ORG=)
LOAD T2,ACC(D) ;Get /ACCESS
LOAD T1,ORGAN(D) ;Get /ORGANIZATION
CAIN T1,OR.IDX ;If INDEXED
MOVX T2,AC.KEY ;then ACCESS is KEYED
MOVX T3,OR.IDX ;Assume keyed
CAIE T2,AC.KEY ;If ACCESS='KEYED'
SKIPE O.KEY ;or KEY= given
MOVEM T3,IMPORG ;Flag an implied ORG=INDEXED
SKIPN IMPORG ;If some ORG was given or implied
CAIE T1,OR.UNK
JRST ORKY ;Have to check further
;Here for non-RMS or RSF file
LOAD T1,SHARE(D) ;SHARED?
JUMPE T1,%POPJ1 ;No, all done
PUSHJ P,SHARO ;Check vs READONLY
PJRST %POPJ1 ;and return
;Check /ORGANIZATION vs /KEY (if given)
ORKY: SKIPE O.KEY ;KEY= given?
SKIPL ORKYTB(T1) ;Yes. Allowed with ORG given?
JRST ORAC ;Yes, OK
SETZ T2, ;/KEY has no value (sort of)
MOVEI T3,OK.ORG
MOVEI T4,OK.KEY
CALL OPCNF ;Report error
;Check /ORGANIZATION vs /ACCESS (if given)
ORAC: SKIPN T1,IMPORG ;Get implied ORG if any
LOAD T1,ORGAN(D) ;None, use actual
LOAD T2,ACC(D) ;Get /ACCESS
JUMPE T2,NEWKEY ;None, no check
MOVE T3,ORACTB(T1) ;Get ACCESS/ORG entry for this ORG
PUSHJ P,CKFSRH ;See if this ACCESS is allowed
JRST NEWKEY ;Yes, OK!
SKIPE O.KEY ;No. Did we use implied ORG?
JRST ORAC2 ;Yes, different error message
MOVEI T3,OK.ORG
MOVEI T4,OK.ACC
PUSHJ P,OPCNF
JRST NEWKEY
ORAC2: MOVE T1,T2 ;ACCESS in T1
SETZ T2, ;/KEY has no value
MOVEI T3,OK.ACC
MOVEI T4,OK.KEY
PUSHJ P,OPCNF
;Check for STATUS='NEW' and /KEY.
NEWKEY: LOAD T1,STAT(D) ;Get /STATUS
CAIN T1,ST.SCR ;If SCRATCH
MOVX T1,ST.NEW ;it's really NEW
CAIE T1,ST.NEW ;NEW?
JRST ORRT ;No, no further check
SKIPE O.KEY ;KEY= given?
JRST NEWFIX ;Yes, no conflict
SKIPN T1,IMPORG ;Get implied or actual ORG
LOAD T1,ORGAN(D)
CAIN T1,OR.IDX ;INDEXED?
PUSHJ P,[$DCALL KER] ;?KEY= required
;Check STATUS='NEW' and RECL=. New relative and indexed files
;default to RECORDTYPE='FIXED'.
;In this case, if no RECORDTYPE= has been specified, insist on a RECL=.
;STATUS='UNKNOWN', which may create a new file, is checked for missing
;required RECL= at OPEN time.
;We only come here if STATUS='NEW' or 'SCRATCH'.
NEWFIX: SKIPN T1,IMPORG ;Get implied or actual ORG
LOAD T1,ORGAN(D)
LOAD T2,RSIZE(D) ;Get /RECORDSIZE
JUMPN T2,ORRT ;Got one, no conflict
LOAD T2,RECTP(D) ;Get /RECORDTYPE
JUMPN T2,ORRT ;Got one, no conflict
;Here if STATUS='NEW' and no RECL= and no RECORDTYPE was given.
CAIE T1,OR.REL ;RELATIVE?
CAIN T1,OR.IDX ;or INDEXED?
PUSHJ P,[$DCALL DFR] ;?Default /RECORDT:FIXED requires /RECL
;Check /ORGANIZATION vs RECORDTYPE
ORRT: LOAD T2,RECTP(D) ;Get /RECORDTYPE
JUMPE T2,SHAC ;None
LOAD T1,RSIZE(D) ;Get /RECORDSIZE
JUMPN T1,ORRTA ;Got one, good
CAIN T2,RT.FIX ;FIXED?
PUSHJ P,[$DCALL FRR] ;Yes, requires a size
ORRTA: SKIPN T1,IMPORG ;Get implied or actual ORG
LOAD T1,ORGAN(D)
MOVE T3,ORRTTB(T1) ;Get ORG/RECT table entry for this ORG
PUSHJ P,CKFSRH ;See if legal
JRST SHAC ;OK!
SKIPE IMPORG ;Implied used?
JRST ORRT2 ;Yes, different error message
MOVEI T3,OK.ORG
MOVEI T4,OK.RTP
PUSHJ P,OPCNF
JRST SHAC
ORRT2: MOVEI T3,OK.ACC ;Assume /ACCESS conflict
LOAD T1,ACC(D) ;Get /ACCESS
SKIPN T1 ;If none,
MOVEI T3,OK.KEY ;must be KEY=
MOVEI T4,OK.RTP
PUSHJ P,OPCNF
;Check /SHARED and /ACCESS
SHAC: LOAD T1,SHARE(D) ;Get SHARED bit
JUMPE T1,%POPJ ;none given, all done
LOAD T2,ACC(D) ;Get /ACCESS
MOVE T3,T2 ;Copy it
JUMPE T2,SHARO ;None given
CAIN T2,AC.RIN ;If it's RANDIN
MOVX T2,AC.SIN ;treat like SEQIN for a moment
CAIE T2,AC.SIN ;Some read-onlyness?
JRST SHARO ;No
MOVE T2,T3 ;Retrieve the actual
;/SHARED was specified with an /ACCESS implying read-only.
SETZ T1, ;SHARE has no value
MOVEI T3,OK.SHR
MOVEI T4,OK.ACC
PUSHJ P,OPCNF ;Issue error
;All done
;Check /SHARED vs /READONLY. If both are given, clear both before
;issuing an error. We don't get here unless /SHARED was specified.
SHARO: LOAD T1,RO(D) ;Get /READONLY
JUMPE T1,%POPJ ;None, no conflict
;Here when both were given
SETZB T1,T2
STORE T1,RO(D) ;Clear both
STORE T1,SHARE(D)
MOVEI T3,OK.SHR
MOVEI T4,OK.RO
PJRST OPCNF
;Table for legal KEY= by organization (0 is legal, -1 illegal)
ORKYTB: 0 ;NONE
-1 ;SEQUENTIAL
-1 ;RELATIVE
0 ;INDEXED
SEGMENT DATA
IMPORG: BLOCK 1 ;Implied ORG=INDEXED
SEGMENT CODE
> ;End %IF20
SUBTTL CKFSRH - Search a conflict table
;++
; FUNCTIONAL DESCRIPTION:
;
; Searches a table whose AOBJN pointer is in AC3 for a match against
; the value in AC2.
;
; CALLING SEQUENCE:
;
; PUSHJ P,CKFSRH
; <Return here if no match found>
; <Return here if match found>
;
; INPUT PARAMETERS:
;
; T3 - AOBJN pointer to table
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T2-T4.
;
;--
;[5000] New
%IF20,<
CKFSRH: MOVE T4,(T3) ;Get table entry
CAIN T2,(T4) ;Match our value?
JRST %POPJ1 ;Yes, take +2 (error) return
AOBJN T3,CKFSRH ;Keep looking
POPJ P, ;No, match is good
DEFINE TAB (ARGS) <
.ARGN.==0
IRP ARGS,<.ARGN.=.ARGN.+1>
XWD -.ARGN.,[IRP ARGS,<ARGS>]
> ;End TAB
;Table for illegal ACCESS types by ORGANIZATION. A -1 allows any ACCESS
; code. If RMS ever supports direct access to fixed-length sequential
; files, delete AC.RIN and AC.RIO from SEQUENTIAL.
ORACTB: TAB <-1> ;NONE
TAB <AC.KEY,AC.RIN,AC.RIO> ;SEQUENTIAL
TAB <AC.KEY,AC.APP> ;RELATIVE
TAB <AC.APP> ;INDEXED
;Table for illegal RECORDTYPES by ORGANIZATION. A -1 allows any RECORDTYPE.
;Note that any is allowed for SEQUENTIAL, even though RECORDTYPE=STREAM
;is disallowed for TOPS20 RMS files. Since we don't know the operating
;system for a remote file yet, anything goes until the RMS OPEN, when
;a further check is made.
ORRTTB: TAB <-1> ;NONE
TAB <-1> ;SEQUENTIAL
TAB <RT.UND,RT.SCR,RT.SLF> ;RELATIVE
TAB <RT.UND,RT.SCR,RT.SLF> ;INDEXED
PURGE .ARGN.
> ;End %IF20
SUBTTL %RMDFA - Default RMS ACCESS
;++
; FUNCTIONAL DESCRIPTION:
;
; Performs post-OPEN-arg defaulting for /ACCESS to RMS files. If
; ORGANIZATION='INDEXED' has been specified or implied, sets /ACCESS
; to 'KEYED'.
;
; Called from FOROPN DFACC.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMDFA
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ACC(D) - ACCESS=
; ORGAN(D) - ORGANIZATION=
; O.KEY - KEY= arglist
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ACC(D) - ACCESS=
; ORGAN(D) - ORGANIZATION=
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
IF10,<
%RMDFA: POPJ P, ;No RMS on TOPS10
> ;End IF10
%IF20,<
%RMDFA: LOAD T2,ORGAN(D) ;Get /ORGANIZATION
CAIE T2,OR.SEQ ;If given as SEQUENTIAL
CAIN T2,OR.REL ;or RELATIVE,
POPJ P, ;nothing to do
MOVEI T1,AC.KEY ;Assume ACCESS='KEYED'
SKIPN O.KEY ;Was KEY= given?
CAIN T2,OR.IDX ;or ORG='INDEXED'?
STORE T1,ACC(D) ;Yes. Default to keyed-access
LOAD T2,ACC(D) ;Get access
CAIE T2,AC.KEY ;'KEYED'?
POPJ P,
;Here for ACCESS='KEYED'. Set ORGANIZATION='INDEXED'.
MOVEI T1,OR.IDX ;Yes, /ORGANIZATION is 'INDEXED'
STORE T1,ORGAN(D)
POPJ P, ;Return
> ;End %IF20
SUBTTL %RMOPN - Open an RMS-accessed file
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine opens files with INDX(D) device types of DI.RSF
; (remote stream) or DI.RMS (RMS). It allocates a FAB/CONFIG XAB
; if one does not already exist, sets FAB fields according to
; OPEN specifiers, allocates a RAB and sets its fields, $OPENs
; or $CREATEs the file, and $CONNECTs the RAB to the FAB.
;
; If a USEROPEN user routine has been specified, calls this routine
; instead of performing the $OPEN/$CREATE/$CONNECT.
;
; If cacheing is enabled, allocates a cache.
;
; Updates the DDB on a successful open.
;
; RSF files can cause the following to happen after a successful OPEN:
;
; o Bucket 0, the FDB page, is read in and EOFN calculated.
; o If random-access, a page table is setup.
; o If ACCESS='APPEND', the last page of the file is mapped.
;
; CALLING SEQUENCE:
;
; Called only from FOROPN DOOPEN via OPNTAB.
; Returns +1 on error to enter DIALOG
; Returns +2 on success.
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
; SAIDX(D) - STATUS/ACCESS index
; ORGAN(D) - ORGANIZATION
; ORGTAB - Table of RMS organization bits
; INDX(D) - Device index (file type)
; SPAN(D) - Non-zero if NOSPANBLOCKS
; SHAR(D) - SHARED
; RO(D) - READONLY
; MAXREC(D) - MAXREC=
; BUFCT(D) - BUFFERCOUNT (file window
; pages for RSF files; multi-
; buffercount for RMS files)
; UOPN(D) - Address of USEROPEN routine
; UBSIZ(D) - User-specified bytesize
; O.KEY - KEY= arg pointer
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; Updates the following DDB fields before a successful return:
;
; RSIZE(D) - Record size in bytes (formatted) or words
; BSIZ(D) - File bytesize
; IJFN(D) - -1
; WTAB(D) - -1 for RMS relative random-access files,
; a page table for random-access RSF files,
; else zero.
; EOFN(D) - Set to infinity
; IMGFLG(D) - Set for RSF files residing on VAX systems.
; DDB filespec fields - Updated with expanded filespec
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
; Invokes RMS.
; Will establish a network link on successful open of a remote file.
; May call user's USEROPEN routine if present.
; May allocate a cache.
; May set WTAB(D) and allocate a page table
; May cause temporary allocation of 1 page for FDB bucket for
; RSF files
; May cause BUFCT-pages mapped to EOF for RSF files opened
; ACCESS='APPEND'
;
;--
;[5000] New
IF10,<
%RMOPN: $SNH ;Should NOT get here on TOPS-10
> ;End IF10
%IF20,<
LWSIZ==9
PSIZ==1000 ;Words/page
FB$ALL==FB$GET!FB$PUT!FB$DEL!FB$UPD!FB$TRN ;Full access
%RMOPN: SKIPN T1,FAB(D) ;Already have a FAB?
PUSHJ P,RMFAB ;No, allocate one
MOVEM T1,FAB(D) ;Save its address
MOVE T1,[POINT 7,%TXTBF] ;Setup to get DDB filespec
PUSHJ P,%RMFNS ;Get it
MOVE T4,FAB(D) ;Get FAB address again
$STORE T1,FNA,<(T4)> ;Set filespec in FNA
;Initialize NAM block, also scratch argument blocks, and point FAB NAM
; to the NAM block.
PUSHJ P,ABINI ;Initialize some argument blocks
XMOVEI T1,NAMBLK ;Point to NAM blk
$STORE T1,NAM,<(T4)>
;Setup FAC field according to STATUS/ACCESS value.
SETFAC: LOAD T1,SAIDX(D) ;Get STATUS/ACCESS
MOVE T1,FACTAB(T1) ;Get corresponding RMS bits
LOAD T2,RO(D) ;Get READONLY bit
SKIPE T2 ;Set?
MOVX T1,FB$GET ;Yes, set read access only
$STORE T1,FAC,<(T4)> ;in FAC of FAB
;Setup ORG field from ORGANIZATION specified. If no ORGANIZATION was
; specified (RSF file or implicit VAX sequential file), ORGAN(D) is zero
; and we default to OR.SEQ.
SETORG: LOAD T1,ORGAN(D) ;Get ORGANIZATION
HLRZ T1,ORGTAB(T1) ;Get org bits
$STORE T1,ORG,<(T4)>
;If SHARED was specified, set the SHR field to full write sharing, else to
; FB$GET, the RMS default.
SETSHR: MOVX T2,FB$GET ;Assume no SHARE
LOAD T1,SHARE(D) ;Get SHARE bit
SKIPE T1 ;Any specified?
MOVX T2,FB$GET!FB$PUT!FB$DEL!FB$UPD ;Yes, allow lots
$STORE T2,SHR,<(T4)> ;Set in SHR
;Setup MRN field from the MAXREC keyword. If none given, MRN=0 and
; RMS does not check for maximum record number.
MOVE T2,MAXREC(D) ;[5016] Get MAXREC
$STORE T2,MRN,<(T4)> ;[5016] Store into MRS
;Set RAT to NOSPANBLOCKS or zero.
LOAD T1,INDX(D) ;Get file type
CAIE T1,DI.RMS ;RMS?
JRST SETTYP ;No, ignore NOSPANBLOCKS
SETZ T2, ;Assume none
LOAD T1,SPAN(D) ;Get "SPAN" bit
SKIPE T1 ;Set?
MOVX T2,FB$BLK ;Yes
$STORE T2,RAT,<(T4)> ;Store or clear
SETZ T2, ;Clear any TYP link
$STORE T2,TYP,<(T4)>
JRST SETRAB ;Go setup RAB
;For RSF files, point to the TYP block for block-mode I/O.
SETTYP: XMOVEI T2,TYPBLK ;Yes
$STORE T2,TYP,<(T4)> ;Set it, or clear it
;Here after FAB fields are all set. Allocate a RAB and set it up.
SETRAB: SKIPE T1,RAB(D) ;Get a fresh RAB
PUSHJ P,%FREBLK
PUSHJ P,RMRAB ;Declare a RAB
MOVEM T1,RAB(D) ;Save its address
MOVE T4,T1 ;Copy it
MOVE T1,FAB(D) ;Get FAB address
$STORE T1,FAB,<(T4)> ;Link RAB to it
;Here to set RAC (record access) field. For now, just set to RB$SEQ. RMS
; relative file direct READ/WRITEs will set RAC to RB$KEY, as will all indexed
; WRITEs. Indexed READs will set to either SEQ or KEY.
SETRAC: MOVX T2,RB$SEQ ;Default to sequential
$STORE T2,RAC,<(T4)>
;Here when FAB and RAB are all set. If there is a USEROPEN routine, call
; it to $OPEN and $CONNECT the file; otherwise we do.
PUSHJ P,FIXUP ;Do last minute fixup
POPJ P, ;Can't, enter DIALOG
;*NOTE: After FIXUP has been called for remote files, a network link
;is now established and open. Any $DCALL during OPEN processing from
;now on must ensure that the remote link is relinquished. This is
;accomplished by the +1 return out of %RMOPN caused by a $DCALL, which
;returns to DOOPEN and calls %RMECK to perform a dummy $CLOSE on
;the FAB.
PUSHJ P,APPCHK ;Set ROP for ACCESS=APPEND
SKIPN T1,UOPN(D) ;Anything to call?
JRST NOUOPN ;No
PUSHJ P,CALUOP ;Yes, call it
POPJ P, ;Failed, enter DIALOG
JRST RMORET ;Succeeded, go finish up
;Here with no USEROPEN. OPEN/CREATE the file by STATUS/ACCESS index.
; This resolves to 4 courses of action:
;
; 1) $OPEN the file; if this fails, $CREATE it.
; 2) $CREATE the file; if this fails, $OPEN it.
; 3) $OPEN the file; if this fails, abort.
; 4) $CREATE the file (with a new generation if necessary); if
; this fails, abort.
;
NOUOPN: LOAD T1,SAIDX(D) ;Get STATUS/ACCESS index
PUSHJ P,RMOTB(T1) ;Open the file
POPJ P, ;Can't, take error return
PUSHJ P,FABSTV ;Update STV
;Here when the OPEN has succeeded. Check return values, $CONNECT RAB to
; FAB if no USEROPEN, update the DDB, and return.
;Check returned ORG value against what user specified.
RMORET: LOAD T1,ORGAN(D) ;Get user's value
HLRZ T1,ORGTAB(T1) ;Get corresponding RMS bits
MOVE T4,FAB(D) ;Get FAB address
$FETCH T2,ORG,<(T4)> ;Get actual
CAMN T1,T2 ;Same?
JRST UPDDDB ;Yes
XMOVEI T1,[ASCIZ /ORGANIZATION/] ;No
$DCALL ATC ;?File's ORGANIZATION conflicts
; with OPEN statement or default
;Check return BSZ (byte-size). If user specified one, and it conflicts
; with the actual returned size (TOPS files only), complain. If the
; user specified a size and the file is non-TOPS, BYTESIZE must equal 8;
; if no size was specified for a non-TOPS file, set it to 8.
UPDDDB: MOVEI T1,^D8 ;Assume non-TOPS
PUSHJ P,NTTOPS ;Alien environment?
$FETCH T1,BSZ,<(T4)> ;No. Get RMS's size
LOAD T2,UBSIZ(D) ;Get user-specified size
JUMPE T2,RESBSZ ;None given, use returned
LOAD T3,INDX(D) ;Get file type
CAIN T3,DI.RSF ;RSF?
JRST UPDDB2 ;Yes, check later from FDB
CAIE T1,(T2) ;Same?
$ECALL BSC ;No. Give conflict warning
RESBSZ: STORE T1,BSIZ(D) ;Store returned size
PUSHJ P,CHKBSZ ;Update BPW, etc.
UPDDB2: PUSHJ P,CHKRET ;Check other returned RMS values
POPJ P, ;Some conflict, enter DIALOG
;Here to connect RAB to FAB if no USEROPEN.
CONRAB: SKIPE UOPN(D) ;Any USEROPEN
JRST SWTB ;Yes, already $CONNECT'd, presumably
PUSHJ P,CONN$ ;Do $CONNECT
JRST RMOER3 ;Error
SWTB: PUSHJ P,SETWTB ;Setup WTAB, WSIZE, RSF EOF
SETZM O.KEY ;Clear any KEY= pntr
JRST %POPJ1 ;Done with OPEN
RMOTB: JRST OPCRE ;UNKNOWN, READ
JRST CRERX ;UNKNOWN, WRITE
JRST CREOP ;UNKNOWN, READ, WRITE
JRST OPCRE ;UNKNOWN, APPEND
JRST OPERX ;OLD, READ
JRST OPERX ;OLD, WRITE
JRST OPERX ;OLD, READ, WRITE
JRST OPERX ;OLD, APPEND
JRST CRERN ;NEW, WRITE
JRST CRERX ;NEW, SCRATCH
FACTAB: FB$GET ;UNKNOWN, READ
FB$ALL ;UNKNOWN, WRITE
FB$ALL ;UNKNOWN, READ, WRITE
FB$ALL ;UNKNOWN, APPEND
FB$GET ;OLD, READ
FB$ALL ;OLD, WRITE
FB$ALL ;OLD, READ, WRITE
FB$ALL ;OLD, APPEND
FB$ALL ;NEW, WRITE
FB$ALL ;SCRATCH, WRITE
ORGTAB: FB$SEQ,,OR.UNK ;NONE
FB$SEQ,,OR.SEQ ;SEQUENTIAL
FB$REL,,OR.REL ;RELATIVE
FB$IDX,,OR.IDX ;INDEXED
;Table for mapping returned RMS record-format values to FOROTS recordtypes
; for RMS files. RH -1 means "this RMS value not supported by FOROTS for RMS
; files"--the only ones currently being STREAM and LSA records in RMS
; sequential files.
RTTAB: FB$STM,,-1 ;(RT.UNS) NONE
FB$STM,,-1 ;(RT.UND) UNDEFINED
FB$FIX,,RT.FIX ;(RT.FIX) FIXED
FB$VAR,,RT.DEL ;(RT.DEL) VARIABLE
FB$STM,,-1 ;(RT.SEG) SEGMENTED
FB$LSA,,-1 ;LINE-SEQUENCED
-1 ;Table end
;Special table for VAX RMS recordformats. Allows almost all RFMs for RMS
; files
VRTTAB: FB$STM,,RT.UND
FB$STM,,RT.UND
FB$FIX,,RT.FIX
FB$VAR,,RT.DEL
FB$STM,,RT.UND
FB$LSA,,-1
-1
;$OPEN the file. This failing, $CREATE it. That failing, abort.
OPCRE: PUSHJ P,OPEN$ ;Do $OPEN
JRST OPCREX ;Error
JRST %POPJ1 ;Return
;Here after a failing OPEN to $CREATE.
OPCREX: CAIE T2,ER$FNF ;Was error "File not found"?
JRST RMOER3 ;No, this is bad
PUSHJ P,DFRFMN ;Default RFM for new RMS files
POPJ P, ;Some conflict, enter DIALOG
MOVX T1,FB$ALL ;Reset to full access
MOVE T4,FAB(D) ;Get FAB address
$STORE T1,FAC,<(T4)> ;Store
PUSHJ P,CREA$ ;Do $CREATE
JRST RMOERR ;Error
JRST %POPJ1 ;OK
;$CREATE the file. This failing, $OPEN it. That failing, abort.
CREOP: LOAD T1,OSTYPE(D) ;Get OS type
CAIN T1,XA$VMS ;VMS?
JRST OPCRE ;Yes, must do it backwards
PUSHJ P,DFRFMN ;Default RFM for new RMS files
POPJ P, ;Some conflict, enter DIALOG
PUSHJ P,CREA$ ;Do $CREATE
JRST CREOPX ;Error
JRST %POPJ1
;Here when the $CREATE failed. If the error is ER$FEX (file already
; exists), we try to $OPEN it.
CREOPX: CAIE T2,ER$FEX ;Was error "File already exists"?
JRST RMOER3 ;No, this is bad
OPERX: PUSHJ P,OPEN$ ;Do $OPEN
JRST RMOERR ;Error
JRST %POPJ1 ;OK
;Here to $CREATE a new file. Set FAB(D) FOP to FB$SUP to supercede an
; existing file. If an explicit generation was given for STATUS='NEW',
; leave SUP off so the $CREATE will fail if the file exists.
CRERN: HRROI T1,GEN(D) ;STATUS='NEW'. Look at generation
MOVX T3,^D10
NIN% ;See if explicit gen given
ERJMP CRERX ;Assume none
JUMPLE T2,CRERX ;0 or neg means no explicit
SETZ T2, ;Gen given, setup to turn off SUP
TRNA ;Skip SUP
CRERX: MOVX T2,FB$SUP ;Get supercede bits
MOVE T4,FAB(D) ;Get FAB address
$STORE T2,FOP,<(T4)> ;Set SUP
PUSHJ P,DFRFMN ;Default RFM for new RMS files
POPJ P, ;Some conflict, enter DIALOG
PUSHJ P,CREA$ ;Do $CREATE
JRST RMOERR ;Error
$FETCH T1,FOP,<(T4)> ;Turn SUP off
TXZ T1,FB$SUP ;Thusly
$STORE T1,FOP,<(T4)> ;reset it
JRST %POPJ1 ;Success return
;Here on $OPEN/$CREATE errors.
RMOERR: CAIE T2,ER$REF ;Indexed Key XAB skew?
JRST RMOER3 ;No, something fatal
PUSHJ P,OPEN$ ;Do $OPEN
JRST RMOER3 ;Error
JRST %POPJ1 ;OK
RMOER3: SETZ T2, ;Setup to clear FOP
$STORE T2,FOP,<(T1)> ;Turn off any FOP bits
PUSHJ P,RMDUXB ;Deallocate any XAB chain
$DCALL OPN ;Complain
> ; End %IF20
SUBTTL FIXUP - Do last minute pre-$OPEN settings
;++
; FUNCTIONAL DESCRIPTION:
;
; This jacket routine calls last-minute fixup routines to set
; various FAB parameters and check for inconsistencies which
; can only be detected when the target operating system is known.
;
; CALLING SEQUENCE:
;
; PUSHJ P,FIXUP
; <Error return; go release any remote link>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[5000] New
%IF20,<
FIXUP: PUSHJ P,GETOST ;Determine OS type, last minute fixup
POPJ P, ;Can't, take error return
PUSHJ P,SETBSZ ;Set/default bytesize
POPJ P, ;Some conflict, take error return
PUSHJ P,SETRFM ;Set/default RECORDTYPE
POPJ P, ;Some conflict, take error return
PJRST %POPJ1 ;OK, take success return
> ; End %IF20
SUBTTL GETOST - Determine OS type
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine is called just prior to any $OPEN or $CREATE (including
; USEROPEN functions) to do a $PARSE with OFP (output file parse) set
; to determine the operating system for remote files. It is a no-op
; for local files. If the remote system is VAX, change INDX(D) to
; DI.RMS (since all VAX files are RMS files) and back out of any RSF
; setup (TYP block links, UDF RFM, etc.) which may already have been
; done on the assumption that the file is RSF.
;
; CALLING SEQUENCE:
;
; PUSHJ P,GETOST
; <Return here for error>
; <Return here on success>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; NODNAM(D) - Node name
; INDX(D) - Device index
; FAB(D) - Address of FAB
; FORM(D) - FORM=
; ORGAN(D) - ORGANIZATION
; CC(U) - CARRIAGECONTROL
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; INDX(D) - Reset to DI.RMS for VAX, DI.RSF is
; TOPS and RECORDTYPE=STREAM, STREAM_CR/LF
; FAB(D) FOP - Set to OFP before the $PARSE.
; ORG - Defaulted to SEQUENTIAL
; RAT - Set to FB$FTN for VAX CC=FORTRAN
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
;
;--
;[5000] New
%IF20,<
GETOST: SKIPN NODNAM(D) ;Is file remote?
JRST %POPJ1 ;No, just return
PUSHJ P,OFPARS ;Do an OFP $PARSE
JRST RMOERR ;Error
PUSHJ P,FETOST ;Get OS type in OSTYPE(D)
PUSHJ P,VALOST ;Do we support it?
JRST UNSOP ;No, abort
CAIE T2,XA$VMS ;Is it VMS?
JRST %POPJ1 ;No, all done
;Here for remote access to VMS. Reset the INDX(D) to DI.RMS, default
; organization to SEQ and check SHR defaulting
MOVEI T1,DI.RMS ;Yes. Get code for RMS filetype
STORE T1,INDX(D) ;It's now an RMS file
SETZ T1, ;Break any TYP link
$STORE T1,TYP,<(T4)>
LOAD T1,ORGAN(D) ;Get ORGANIZATION
JUMPN T1,VAXSHR ;Got one
MOVX T1,FB$SEQ ;If none, default to SEQ
$STORE T1,ORG,<(T4)> ;Set it
MOVEI T1,OR.SEQ ;also tell FOROTS
STORE T1,ORGAN(D)
;If the file is sequential and we want PUT access to it, change the
; default SHR from GET to NIL, since this is the way VAX defaults for
; these files.
VAXSHR: $FETCH T1,ORG,<(T4)> ;Get ORG value
CAIE T1,FB$SEQ ;SEQUENTIAL?
JRST %POPJ1 ;No, all done
$FETCH T2,FAC,<(T4)> ;Get FAC
MOVX T1,FB$NIL ;Assume PUT is on
TXNE T2,FB$PUT ;Was it?
$STORE T1,SHR,<(T4)> ;Yes, SHR=NIL
JRST %POPJ1 ;Done
UNSOP: MOVEI T1,NODNAM(D)
$DCALL URS ;?Unsupported remote system
> ; End %IF20
SUBTTL OFPARS - Do an OFP $PARSE
;++
; FUNCTIONAL DESCRIPTION:
;
; OFP $PARSE to exchange configuration messages.
;
; CALLING SEQUENCE:
;
; PUSHJ P,OFPARS
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
; FOP OFP set, cleared on success
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T2,T4.
;
;--
;[5000] New
%IF20,<
OFPARS: MOVE T4,FAB(D) ;Yes. Get FAB address
$FETCH T2,FOP,<(T4)> ;Turn on OFP bit
TXO T2,FB$OFP
$STORE T2,FOP,<(T4)> ; in FOP
PUSHJ P,PARS$ ;Do $PARSE
JFCL ;Ignore errors for a moment
$FETCH T2,FOP,<(T4)> ;Turn off OFP for later OPEN
TXZ T2,FB$OFP
$STORE T2,FOP,<(T4)> ;Reset it
PUSHJ P,RLFJFN ;If RMS gave us a JFN, toss it
LOAD T2,STS(D) ;Get $PARSE status
CAIGE T2,ER$MIN ;Error?
JRST %POPJ1 ;OK return
POPJ P, ;Error return
> ;End %IF20
SUBTTL RLFJFN - Toss an RMS-returned JFN
;++
; FUNCTIONAL DESCRIPTION:
;
; If the FAB's JFN field is non-zero after an RMS $PARSE or
; other service call, toss the JFN and zero the field
;
; CALLING SEQUENCE:
;
; PUSHJ P,RLFJFN
; <Return here>
;
; INPUT PARAMETERS:
;
; T4 - Address of FAB
;
; IMPLICIT INPUTS:
;
; FAB(D) JFN - FAB returned JFN field
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB(D) JFN - Zeroed
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5000] New
%IF20,<
RLFJFN: $FETCH T1,JFN,<(T4)> ;Get JFN,
JUMPE T1,%POPJ ;if any
RLJFN% ;Release it
ERJMP .+1 ;We tried
SETZ T1,
$STORE T1,JFN,<(T4)> ;Clear the field
POPJ P, ;Return
> ;End %IF20
SUBTTL VALOST - Validate a remote operating system
;++
; FUNCTIONAL DESCRIPTION:
;
; Called with the returned OS type code from the CONFIG XAB in T2.
; Returns +1 if the remote system is not supported for Fortran I/O,
; else +2.
;
; CALLING SEQUENCE:
;
; PUSHJ P,VALOST
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; T2 - OS code from CONFIG XAB
;
; IMPLICIT INPUTS:
;
; OSTAB - Table of supported remote systems
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T3.
;
;--
;[5000] New
%IF20,<
VALOST: MOVEI T1,OSTAB ;Point at table of supported OS's.
VALOOP: MOVE T3,(T1) ;Get an entry
JUMPE T3,%POPJ ;End of table and no match
CAME T2,T3 ;Found it?
AOJA T1,VALOOP ;No, keep looking
JRST %POPJ1 ;Yes, return +1
;Table of remote operating systems supported by Fortran
OSTAB: XA$T20 ;TOPS20
XA$VMS ;VAX
0 ;Table end
> ; End %IF20
SUBTTL SETBSZ - Set/default Bytesize
;++
; FUNCTIONAL DESCRIPTION:
;
; If a BYTESIZE= was specified, set the FAB to it and calculate bytes/
; word. If none, default TOPS files by MODE and set non-TOPS files
; to 8. Produce an error for non-TOPS files with BYTESIZE not
; equal to 8. Produce an error for TOPS indexed files with KEY=
; datatype of CHARACTER if BYTESIZE is not equal to 7.
;
; CALLING SEQUENCE:
;
; PUSHJ P,SETBSZ
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
; UBSIZ(D) - BYTESIZE=
; MODE(D) - MODE=
; STGFLG(D) - Non-zero if KEY= contains datatype
; CHARACTER
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB(D) BSZ - Bytesize
; BSIZ(D) - File bytesize
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4
;
;--
;[5000] New
%IF20,<
SETBSZ: LOAD T1,UBSIZ(D) ;Did user specify a size?
STORE T1,BSIZ(D) ;(set it in any case)
JUMPN T1,CHKBPW ;Yes, check for non-TOPS size
PUSHJ P,NTTOPS ;No. TOPS file?
JRST TOPBSZ ;Yes, default by MODE
MOVEI T1,^D8 ;Non-TOPS. Default to 8
STORE T1,BSIZ(D)
JRST SETBPW ; and go set it up
TOPBSZ: LOAD T1,MODE(D) ;Set by mode
LOAD T2,INDX(D) ;If RMS file
CAIN T2,DI.RMS
MOVX T1,MD.ASC ;It's really ascii
MOVE T2,BSTAB(T1) ;Get local byte size by mode
STORE T2,BSIZ(D) ;Save
JRST SETBPW ;Go set it up
CHKBPW: PUSHJ P,NTTOPS ;Non-TOPS file?
JRST STGCHK ;TOPS, check for STG datatype
LOAD T1,BSIZ(D) ;Non-TOPS, better be 8
CAIE T1,^D8
$DCALL BME ;?Bytesize must be eight
SETBPW: PUSHJ P,CHKBSZ ;Go setup BPW, etc
LOAD T2,BSIZ(D) ;Get size again
MOVE T4,FAB(D) ;Get FAB address again
$STORE T2,BSZ,<(T4)> ;Store it for RMS
JRST %POPJ1 ;Take success return
STGCHK: SKIPN STGFLG(D) ;XABs have STG datatype?
JRST SETBPW ;No, OK
LOAD T1,BSIZ(D) ;Yes, bytesize must be 7
CAIE T1,7
$DCALL KDB ;"?Key datatype conflicts with BSZ"
JRST SETBPW
> ; End %IF20
SUBTTL SETRFM - Set/default RECORDTYPE/RFM
;++
; FUNCTIONAL DESCRIPTION:
;
; Setup RFM for all RSF files and for RMS files for which a user
; RECORDTYPE= value exists. Set MRS appropriately for file-type.
;
; RSF files always set RFM to UDF (and FAC to BRO) for block-mode
; I/O.
;
; MRS is set to either the user's RECL or, if no RECL, to a
; slightly bogus value of one. MRS must be non-zero
; for RSF files, since if zero RMS will ignore the specified
; bytesize and create a 7-bit file,
;
; RMS files are equally tortuous, in order to conform to the
; VMS RECORDTYPE defaulting scheme. MRS is set according to the
; user's RECL: if the file contains fixed-length records, RECL
; specifies the size of each record; if variable, it specifies
; the maximum record length; if absent, RMS does not check for
; maximum record length. If a RECORDTYPE= exists, we set RFM
; to it now; if it is absent, this routine leaves RFM untouched
; and the RFM is set just before the actual OPEN depending on
; whether the file exists or not. If it exists, the file's
; permanent RFM is used; if a new file, we then default as follows
; (mostly VAX compatibly):
;
; ORGANIZATION=RELATIVE or INDEXED: RFM=FIXED
; All other RMS files: RFM=VARIABLE
;
; Note that RMS-20 does not support random-access to fixed-length
; sequential files.
;
; This routine checks that a specified RECORDTYPE is legal for
; the file type in question.
; CALLING SEQUENCE:
;
; PUSHJ P,SETRFM
; <Error return>
; <Sucess return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
; INDX(D) - Device index
; RECTP(D) - RECORDTYPE
; ORGAN(D) - ORGANIZATION
; RSIZ(D) - RECORDSIZE
; FORM(D) - FORM=
; RTTAB - Table of supported TOPS RMS recordtypes
; VRTTAB - Table of supported VMS RMS recordtypes
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB(D) RFM - Set to FB$UDF for all RSF files.
; FAC - Set to BRO for RSF
; MRS - Set to maximum recordsize in bytes
; MBF - Set to user's BUFFERCOUNT for RMS files
; MRSIZE(D) - Set to user's MRS
; FRSIZB(D) - Set to user's MRS
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
;
;--
;[5000] New
%IF20,<
SETRFM: MOVE T4,FAB(D) ;Get FAB address
LOAD T1,INDX(D) ;Get file type
CAIE T1,DI.RSF ;RSF?
JRST RMSRFM ;No, set RMS RFM
LOAD T1,RECTP(D) ;Get user's RECTP
JUMPE T1,RSFUDF ;None
CAIE T1,RT.UND ;If given, must be stream
JRST UNSRFM ;It isn't, go complain
;Here for RSF files
RSFUDF: MOVX T1,FB$UDF ;Set to UDF
$STORE T1,RFM,<(T4)>
$FETCH T1,FAC,<(T4)> ;Set BRO in the FAC
TXO T1,FB$BRO
$STORE T1,FAC,<(T4)>
LOAD T1,RSIZE(D) ;Get RECORDSIZE=
JUMPN T1,SETMRS ;Got one
MOVEI T1,1 ;No, fake an MRS
$STORE T1,MRS,<(T4)>
JRST %POPJ1 ;And take success return
RMSRFM: LOAD T1,RECTP(D) ;Get RECORDTYPE
JUMPE T1,SETMRS ;None, set MRS
MOVEI T2,RTTAB ;Point at TOPS table
MOVE T3,OSTYPE(D) ;But check if VMS system
CAIN T3,XA$VMS ;VMS?
MOVEI T2,VRTTAB ;Yes, use non-restrictive table
ADDI T2,(T1) ;Point at correct entry
HRRE T3,(T2) ;Get value
JUMPL T3,UNSRFM ;Not supported
HLRZ T2,(T2) ;OK, get RMS equivalent
$STORE T2,RFM,<(T4)> ;Set RFM
PUSHJ P,RMSCC ;Go check CC for RMS files
SETMRS: LOAD T1,RSIZE(D) ;Get RECORDSIZE
LOAD T2,FORM(D) ;Get FORM=
CAIE T2,FM.FORM ;FORMATTED?
IMUL T1,BPW(D) ;No, convert to bytes
$STORE T1,MRS,<(T4)> ;Set as MRS
JRST %POPJ1 ;Take success return
> ; End %IF20
SUBTTL RMSCC - Check CARRIAGECONTROL for RMS files
;++
; FUNCTIONAL DESCRIPTION:
;
; Called only for RMS files. Checks/defaults CC as follows:
;
; If CC=TRANSLATED, reset it to FORTRAN. TRANSLATED makes no sense
; for RMS files, and VMS can't stand embedded carriagecontrol from
; a TOPS.
;
; Since VMS will convert CC=FORTRAN for RECORDTYPE=STREAM files
; to "implied carriage control" from a remote system, reset
; to VARIABLE if non-TOPS.
;
; If CC=FORTRAN (the default for non-STREAM RMS files), set the
; RAT FTN bit if the remote system is non-TOPS. For VMS and others,
; FTN CC is a record attribute, not a file attribute. RAT FB$FTN
; should never be set for a TOPS RMS file, since the RMSFAL will
; then do its best to convert the RMS file into a STREAM file.
;
;
; CALLING SEQUENCE:
;
; PUSHJ P,RMSCC
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; CC(U) - CARRIAGECONTROL
; FAB(D) - Address of FAB
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; CC(U) - Reset to FORTRAN if TRANSLATED
; FAB(D) RAT - Set to FB$FTN is system is non-
; TOPS and CC=FORTRAN
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5000] New
%IF20,<
RMSCC: LOAD T1,CC(U) ;Get CARRIAGECONTROL
CAIN T1,CC.TRN ;TRANSLATED?
MOVX T1,CC.FOR ;Yes, reset to CC=FORTRAN
STORE T1,CC(U)
CAIN T1,CC.FOR ;If not CC=FORTRAN
PUSHJ P,NTTOPS ; or system is TOPS
POPJ P, ; then all done
;System is remote non-TOPS and CC=FORTRAN. The attribute will not be
;honored by most remote systems, so change the RECORDTYPE to VARIABLE.
MOVE T4,FAB(D) ;Get FAB address
$FETCH T1,RAT,<(T4)> ;Get RAT bits
TXO T1,FB$FTN ;Turn on FTN
$STORE T1,RAT,<(T4)> ;Put back
LOAD T1,RECTP(D) ;Get RECORDTYPE
CAIN T1,RT.UNS ;None given, or
MOVX T1,RT.UND ;STREAM?
CAIE T1,RT.UND
POPJ P, ;No
MOVX T2,FB$VAR ;Yes, switch to VARIABLE
$STORE T2,RFM,<(T4)> ; for both RMS
MOVX T2,RT.DEL
STORE T2,RECTP(D) ; and FOROTS
POPJ P,
> ;End %IF20
SUBTTL DFRFMN - Default RMS RFM for new files
;++
; FUNCTIONAL DESCRIPTION:
;
; A no-op for RSF files and for RMS files for which a RECORDTYPE
; has been specified. This routine defaults the RFM just before
; a $CREATE to FIXED for relative or indexed files and for direct-
; access sequential files, and to VARIABLE for all other RMS files.
;
; For STATUS='UNKNOWN' indexed files, check whether a KEY= has
; been specified when $CREATEing a new file.
;
; CALLING SEQUENCE:
;
; PUSHJ P,DFRFMN
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - FAB address
; INDX(D) - File type
; RECTP(D) - RECORDTYPE=
; ORGAN(D) - ORGANIZATION=
; ACC(D) - ACCESS=
; RSIZE(D) - RECORDSIZE=
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB(D) RFM - Default RFM
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[5000] New
%IF20,<
DFRFMN: LOAD T1,INDX(D) ;Get file type
CAIE T1,DI.RMS ;RMS file?
JRST %POPJ1 ;No, a no-op
LOAD T1,ORGAN(D) ;Get ORGANIZATION
LOAD T2,RSIZE(D) ;Get RECL
JUMPN T2,DFRFM1 ;Got one
CAIE T1,OR.REL ;RELATIVE?
CAIN T1,OR.IDX ;or INDEXED?
$DCALL RIR ;Yes, must have RECL=
DFRFM1: CAIE T1,OR.IDX ;INDEXED?
JRST DFRFM2 ;No
LOAD T1,SAIDX(D) ;Get STATUS/ACCESS index
CAIN T1,SA.URW ;UNKNOWN R/W (random)?
JRST DFRFM2 ;Yes, don't require XABs
SKIPN XAB(D) ;KEY= given for new file?
JRST NPKERR ;No, give ER$NPK
DFRFM2: LOAD T2,RECTP(D) ;Yes, get RECORDTYPE
JUMPN T2,%POPJ1 ;Got one, RFM already set
;Here to figure out appropriate RFM default based on file and access
CAIE T1,OR.REL ;RELATIVE?
CAIN T1,OR.IDX ;or INDEXED?
JRST FIXRFM ;Yes, default to FIXED
;The following check is unnecessary until RMS implements direct-access
; to fixed-length sequential files.
LOAD T1,ACC(D) ;It's SEQUENTIAL, get access
CAIE T1,AC.RIO ;DIRECT?
CAIN T1,AC.RIN
JRST FIXRFM ;Yes, default is FIXED
SKIPA T2,[FB$VAR]
FIXRFM: MOVX T2,FB$FIX
MOVE T4,FAB(D) ;Get FAB address
$STORE T2,RFM,<(T4)> ;Set in FAB
LOAD T1,RSIZE(D) ;Get RECL
JUMPN T1,%POPJ1 ;Got one
CAIN T2,FB$FIX ;Did we default to FIXED?
$DCALL DFR ;?Default /RECT:FIXED requires /RECL
JRST %POPJ1 ;Return
NPKERR: MOVE T1,FAB(D)
MOVX T2,ER$NPK ;We fake an NPK error
SETZ T3,
PUSHJ P,MAKSTS
JRST RMOER3 ;Go fail
> ; End %IF20
SUBTTL APPCHK - Set ROP for ACCESS='APPEND'
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine sets ROP to EOF for RMS files for which ACCESS=
; 'APPEND'. It is a no-op for RSF files, as block-mode does not
; provide for EOF positioning on an OPEN. Append RSF files have their
; last page mapped in after the OPEN.
;
; Also sets MBF (multibuffercount) from UBUFCT(D), the user's
; BUFFERCOUNT, else defaults to RMS's MBF.
;
; CALLING SEQUENCE:
;
; PUSHJ P,APPCHK
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; INDX(D) - Device type
; ACC(D) - ACCESS=
; RAB(D) - Address of RAB
; UBUFCT(D) - User's BUFFERCOUNT
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ACC(D) - Set to AC.SOU if ACCESS='APPEND'
; RAB(D) ROP - Set to RB$EOF for append-access RMS
; files
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T4.
;
;--
;[5000] New
%IF20,<
APPCHK: LOAD T1,INDX(D) ;Get file type
CAIN T1,DI.RSF ;RSF?
POPJ P, ;Yes, just return
MOVE T4,RAB(D) ;Get RAB address
LOAD T1,UBUFCT(D) ;Get user's BUFFERCOUNT
$STORE T1,MBF,<(T4)>
LOAD T1,ACC(D) ;Get ACCESS
CAIE T1,AC.APP ;'APPEND'?
POPJ P, ;No, don't reset anything
MOVEI T1,AC.SOU ;Yes, set SEQUENTIAL
STORE T1,ACC(D)
PUSHJ P,EOFON ;Turn on EOF
POPJ P,
> ; End %IF20
SUBTTL CHKRET - Check post-OPEN values and update DDB
;++
; FUNCTIONAL DESCRIPTION:
;
; This jacket routine calls routines to check that RMS-returned
; file attributes match those specified in the user's OPEN statement.
;
;
; CALLING SEQUENCE:
;
; PUSHJ P,CHKRET
; <Error return; DIALOG will be entered>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[5000] New
%IF20,<
CHKRET: PUSHJ P,RETRCT ;Update returned RFM/RECTP value
POPJ P, ;Conflict, error return
PUSHJ P,RETMRS ;Check returned MRS value
POPJ P, ;Conflict, error return
PUSHJ P,SETIMF ;Set IMGFLG by file type
PUSHJ P,SETCSH ;Setup a cache for RMS sequentials
JRST %POPJ1 ;Success return
> ; End %IF20
SUBTTL RETRCT - Update RECTP(D) from returned RFM
;++
; FUNCTIONAL DESCRIPTION:
;
; Setup RECTP from FAB RFM for RMS files only. The return RFM for RSF
; files must be one of FB$STM, FB$UDF, or FB$LSA; any other value
; probably means the file is actually an RMS file.
;
; Table RTTAB maps returned RFM values into RECTP(D) values for non-
; VMS RMS files; -1 RH means this returned RFM value is not supported
; by FOROTS for RMS files. VMS RMS files (i.e. all VMS files) use
; a non-restrictive VRTTAB table, since VMS Sequential files can have
; recordtype STM. (Non-sequential STM types are trapped before
; the OPEN).
;
; CALLING SEQUENCE:
;
; PUSHJ P,RETRCT
; <Error return; DIALOG>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; INDX(D) - Device index
; FAB(D) RFM - Returned record format value
; OSTYPE(D) - OS type
; RECTP(D) - RECORDTYPE
; RTTAB - RFM-to-RECTP table for non-VMS RMS files
; VRTTAB - " " " VMS files
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RECTP(D) - DDB RECORDTYPE value
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
;
;--
;[5000] New
%IF20,<
RETRCT: MOVE T4,FAB(D) ;Get FAB address
LOAD T2,INDX(D) ;Get file type
$FETCH T1,RFM,<(T4)> ;Get RMS return value
CAIE T2,DI.RMS ;RMS?
JRST RSFRFM ;No, check RSF RFM
MOVEI T2,RTTAB ;Point at normal table
MOVE T3,OSTYPE(D) ;But check if VMS system
CAIN T3,XA$VMS ;VMS?
MOVEI T2,VRTTAB ;Yes, use non-restrictive table
PUSHJ P,RTMAP ;Try to match it
JRST UNSRFM ;Not found or unsupported
LOAD T2,RECTP(D) ;Get user's RECORDTYPE=
JUMPE T2,RSTRCT ;None, use returned
CAMN T3,T2 ;Does user agree with RMS?
JRST RSTRCT ;Yes, go store
XMOVEI T1,[ASCIZ /RECORDTYPE/]
$DCALL ATC ;?File's RECORDTYPE conflicts with
; OPEN statement or default
RSTRCT: STORE T3,RECTP(D) ;Store
JRST %POPJ1 ; and take success return
;Here for recordtypes returned for RSF files.
RSFRFM: CAIE T1,FB$UDF ;RMS-UDF?
CAIN T1,FB$STM ;or STREAM?
JRST %POPJ1 ;Yes, OK
CAIN T1,FB$LSA ;or LSA?
JRST %POPJ1 ;Yes, OK
CAIE T1,FB$VAR ;VARIABLE?
CAIN T1,FB$FIX ;or FIXED?
$DCALL RMS
UNSRFM: LOAD T1,RECTP(D) ;Get user's RECORDTYPE
CAIN T1,RT.UNS ;If none given, it's STREAM
MOVX T1,RT.UND
MOVEI T2,SWRECT ;Get address of switch table
PUSHJ P,FNDSWT ;Get switch string
MOVEM T1,%ARGNM
$DCALL URT ;?Recordtype x not supported for
; this file type
> ; End %IF20
SUBTTL RTMAP - Map an RFM to a RECORDTYPE
;++
; FUNCTIONAL DESCRIPTION:
;
; Converts an RFM value to a corresponding RECORDTYPE value. The
; address of a table is passed as an argument. The table determines
; whether a particular RFM value is supported for not.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RTMAP
; <Return here if RFM not matched, or RFM is unsupported>
; <Return here if matched; RECORDTYPE value in T3>
;
; INPUT PARAMETERS:
;
; T1 - RFM value to match
; T2 - Address of RFM/RECORDTYPE table
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; T3 - RECORDTYPE value which matches the RFM. If no
; match, or unsupported RFM, T3 is indeterminate.
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[5000] New
%IF20,<
RTMAP: HLRE T3,(T2) ;Get an RMS value
JUMPL T3,%POPJ ;End of table and no match
CAIE T1,(T3) ;Match?
AOJA T2,RTMAP ;No, keep looking
HRRE T3,(T2) ;Yes, get FOROTS value
JUMPL T3,%POPJ ;Unsupported RMS value
JRST %POPJ1 ;Found and supported
> ;End %IF20
SUBTTL RETMRS - Check returned MRS value
;++
; FUNCTIONAL DESCRIPTION:
;
; Set RSIZE(D) to the returned MRS value (recordsize
; in bytes or words) if the user's size agrees with RMS. If
; the user specified no size, use MRS.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RETMRS
; <Error return; DIALOG>
; <Succes return>
;
; INPUT PARAMETERS:U;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) MRS - Returned MRS value
; RFM - Returned RFM
; INDX(D) - Device type
; FORM(D) - FORM=
; BPW(D) - Bytes/word
; RSIZE(D) - RECL=
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RSIZE(D) - Set to MRS if returned and user size
; was specified and RFM=FIXED.
; MRSIZE(D) - Set to MRS for I/O buffer size
; FRSIZB(D) - Set to user's MRS
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
;
;--
;[5000] New
%IF20,<
RETMRS: LOAD T1,INDX(D) ;Get file type
CAIN T1,DI.RSF ;RSF?
JRST %POPJ1 ;Yes, don't bother checking it
MOVE T4,FAB(D) ;Get FAB address
$FETCH T1,MRS,<(T4)> ;Get max rec size
STORE T1,MRSIZE(D) ;Save as MRS buffer size
$FETCH T2,RFM,<(T4)> ;Get RMS recordformat
CAIE T2,FB$VAR ;Set buffersize if fixed
STORE T1,FRSIZB(D)
LOAD T3,ORGAN(D) ;or if INDEXED
CAIN T3,OR.IDX
STORE T1,FRSIZB(D)
JUMPE T1,MRSCMP ;None, see if user specified one
;T1 has MRS
CAIE T2,FB$FIX ;RECORDTYPE FIXED?
CAIN T3,OR.REL ;or ORGANIZATION RELATIVE?
TRNA ;Yes, recalculate RSIZE
JRST %POPJ1 ;No, MRS is just a maximum
LOAD T2,FORM(D) ;Get FORM
CAIN T2,FM.FORM ;FORMATTED?
JRST MRSCMP ;Yes, already in bytes
ADD T1,BPW(D) ;Round up to words
SUBI T1,1
IDIV T1,BPW(D) ;Get words
MRSCMP: LOAD T2,RSIZE(D) ;Get user's RECORDSIZE
JUMPE T2,UPDMRS ;None, use returned
CAMN T1,T2 ;Same?
JRST UPDMRS ;Yes
XMOVEI T1,[ASCIZ /RECORDSIZE/]
$DCALL ATC ;File attribute conflict error
UPDMRS: MOVEM T1,RSIZE(D) ;Set the MRS
JRST %POPJ1 ; and return success
> ; End %IF20
SUBTTL SETIMF - Set IMGFLG(D) by file type
;++
; FUNCTIONAL DESCRIPTION:
;
; Set IMGFLG(D) for all RMS files to prevent processing of LSCWs.
; Also set for RSF files for which MODE='IMAGE'.
;
; CALLING SEQUENCE:
;
; PUSHJ P,SETIMF
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; INDX(D) - Device index
; MODE(D) - MODE
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; IMGFLG(D) - Set for RMS files and image-mode RSF.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5000] New
%IF20,<
SETIMF: LOAD T1,INDX(D)
CAIE T1,DI.RMS ;RMS file?
JRST IMFRSF ;No
SETOM IMGFLG(D) ;Yes, set flag
POPJ P, ;and return
IMFRSF: SETZM IMGFLG(D) ;Clear flag
LOAD T1,MODE(D) ;Get Fortran data mode
CAIN T1,MD.IMG ;Image?
SETOM IMGFLG(D) ;Yes. Set flag
POPJ P,
> ; End %IF20
SUBTTL SETCSH - Setup a cache for RMS sequential access files
;++
; FUNCTIONAL DESCRIPTION:
;
; For RMS sequential files, if CACHSZ .NEQ. 0, allocate a cache.
;
; CALLING SEQUENCE:
;
; PUSHJ P,SETCSH
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; INDX(D) - Device index
; ORGAN(D) - Organization
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; CACHE(D) - Address of cache (CASHSZ words)
; CACHPT(D) - Pointer into cache initialized
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
SETCSH: LOAD T1,INDX(D) ;Get file type
CAIE T1,DI.RMS ;If RSF,
POPJ P, ;nothing to do
MOVEI T1,CACHSZ ;Get CACHSZ in words
JUMPE T1,%POPJ ;None, we're done
LOAD T2,ORGAN(D) ;Get organization
CAIE T2,OR.SEQ ;Cache only RMS sequential
POPJ P,
PUSHJ P,%GTBLK ;Allocate a cache
$ACALL MFU ;Can't
MOVEM T1,CACHE(D) ;Save cache address
MOVEM T1,CACHPT(D) ;Initialize pointer
POPJ P, ;Return
> ; End %IF20
SUBTTL SETWTB - Setup WTAB
;++
; FUNCTIONAL DESCRIPTION:
;
; Sets WTAB to minus one for random-access RMS relative files.
; Sets WTAB to a page table for random-access RSF files.
; Sets WTAB to zero for other RMS and RSF files.
;
; Sets WSIZ for all files, WADR and BUFADR for sequential files.
;
;
; CALLING SEQUENCE:
;
; PUSHJ P,SETWTB
; <Return here; errors go to ABORT>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ACC(D) - ACCESS
; INDX(D) - Device index
; ORGAN(D) - ORGANIZATION
; BUFCT(D) - BUFFERCOUNT
; BPW(D) - Bytes-per-word
; WPTR(D) - Page address of buffer pages
; EOFN(D) - EOF byte number
;
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; WTAB(D) - -1 for RMS-relative direct access files
; Page table pointer for random-access RSF
; files
; WPTR(D) - Core page address of buffer pages
; WSIZ(D) - Window size in bytes
; WADR(D) - Address of window
; BUFADR(D) - Synonym for WADR.
; EOFN(D) - Set to infinity for RMS files, to
; EOF byte # for RSF files.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
; Reads in the FDB "page" for all RSF file.
; Allocates a page table for random-access RSF files.
;
;
;--
;[5000] New
%IF20,<
SETWTB: SETZM WTAB(D) ;Clear WTAB
LOAD T1,ACC(D) ;Get ACCESS
CAIE T1,AC.RIO ;ACCESS='DIRECT'?
CAIN T1,AC.RIN
SETOM WTAB(D) ;Yes, flag WTAB
LOAD T1,INDX(D) ;Get file type
CAIN T1,DI.RSF ;RSF?
JRST SETRSF ;Yes, setup for RSF input
HRLOI T1,377777 ;RMS EOFN's are infinite
MOVEM T1,EOFN(D)
POPJ P,
SETRSF: PUSHJ P,RSGFDB ;Setup RSF's EOF, FDB, etc.
LOAD T1,BUFCT(D) ;Get Buffercount
PUSHJ P,%GTPGS ;Get buffer pages
$ACALL MFU ;Can't, memory full
MOVEM T1,WPTR(D) ;Save page address
SKIPGE WTAB(D) ;ACCESS='DIRECT'?
PJRST RANALC ;Yes, setup WTAB with page table
MOVE T1,WPTR(D) ;Get page address
LSH T1,LWSIZ ;Get core address
HRRZM T1,WADR(D) ;Save address
HRRZM T1,BUFADR(D) ;here too
LOAD T1,BUFCT(D) ;Get buffercount again
LSH T1,LWSIZ ;Get # words
IMUL T1,BPW(D) ;Get # bytes in it
MOVEM T1,WSIZ(D) ;Save window size
LOAD T1,ACC(D) ;Get access type
CAIE T1,AC.APP ;Append?
POPJ P, ;No, all done
MOVEI T1,AC.SOU ;Yes, set SEQUENTIAL
STORE T1,ACC(D)
MOVE T2,EOFN(D) ;Get # bytes in file
MOVEM T2,BYTN(D) ;Save as byte number also
PUSHJ P,RMAPW ;Map in EOF page
PJRST SETPTR ;Setup pointers, return
> ; End %IF20
SUBTTL RSGFDB - Get FDB, set EOFN for RSF files
;++
; FUNCTIONAL DESCRIPTION:
;
; Obtains FDB data for an RSF file, storing in FDB for updating
; EOFN(D).
;
; CALLING SEQUENCE:
;
; PUSHJ P,RSGFDB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FDB - FDB block
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Reads an FDB page over the network (!).
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
RSGFDB: PUSHJ P,RSRFDB ;Get the FDB page
$ACALL OPN ;Can't, abort
MOVSI T1,(T1) ;Get source to BLT for EOFSET
MOVEI T2,FDB ;Get destination
HRRI T1,(T2)
ADDI T2,.FBSIZ
BLT T1,(T2) ;BLT upto .FBSIZ
PUSHJ P,FTMPPG ;Free the FDB page
PJRST %RSEOF ;Go set EOFN, etc.
> ; End %IF20
SUBTTL RSRFDB - Get FDB page for an RSF file
;++
; FUNCTIONAL DESCRIPTION:
;
; Reads "bucket 0" from an RSF file, returning a page containing the
; file's FDB.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RSRFDB
; <Error return, page deallocated>
; <Success return, page address in T1>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T1 - Address of FDB data
;
; IMPLICIT OUTPUTS:
;
; RAB(D) USZ - Set to words/page
; UBF - Set to address of core page
; BKT - Set to "bucket 0" for file
; RAC - Set to RB$BLK for block mode
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4.
; Calls %GTBLK for one page of memory.
;
;--
;[5000] New
%IF20,<
RSRFDB: MOVEI T1,PSIZ ;Get one page for FDB bucket
PUSHJ P,%GTBLK ;Get it, zeroed
$ACALL MFU ;Can't
MOVEM T1,T2 ;Copy for GETBKT
SETZ T1, ;Read bucket 0
PUSHJ P,GETBKT ;$READ it
PJRST FTMPPG ;Can't, deallocate and return+1
$FETCH T1,UBF,<(T4)> ;Get page address
MOVEM T1,T3 ;Copy
ADDI T1,.FBLEN ;Setup to clear rest of page
SETZM (T1)
HRL T2,T1
HRRI T2,1(T1) ;start,,start+1
BLT T2,PSIZ-1(T3)
MOVE T1,T3 ;Return start address
JRST %POPJ1 ;Take success return
> ; End %IF20
SUBTTL FTMPPG - Free a temporary page
;++
; FUNCTIONAL DESCRIPTION:
;
; Calls %FREBLK to return the page to which the "bucket 0" FDB
; has been written.
;
; CALLING SEQUENCE:
;
; PUSHJ P,FTMPPG
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) UBF - Address of page
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4.
;
;--
;[5000] New
%IF20,<
FTMPPG: MOVE T4,RAB(D) ;Get RAB address
$FETCH T1,UBF,<(T4)> ;Get page core address
PUSHJ P,%FREBLK ;Free the page
POPJ P,
> ; End %IF20
SUBTTL RSWFDB - Write FDB page for an RSF file
;++
; FUNCTIONAL DESCRIPTION:
;
; Writes "bucket 0" or FDB page for an RSF file. The address of the
; page to write is in T1.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RSWFDB
; <Error return; page is deallocated>
; <Success return>
;
; INPUT PARAMETERS:
;
; T1 - Address of page to write
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) UBF - Set to address of page to write
; RSZ - Set to page size in bytes
; BKT - Set to "bucket 0"
; RAC - Set to RB$BLK
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4.
;
;--
;[5000] New
%IF20,<
RSWFDB: MOVE T4,RAB(D) ;Get RAB address
MOVEM T1,T2 ;Copy our buffer address
SETZ T1, ;BKT 0 for FDB
PUSHJ P,PUTBKT ;$WRITE it
PJRST FTMPPG ;Can't, deallocate, error ret
JRST %POPJ1 ;Success
> ; End %IF20
SUBTTL CALUOP - Call a user USEROPEN routine
;++
; FUNCTIONAL DESCRIPTION:
;
; Called with the address of the USEROPEN routine in UOPN(D). Calls
; the USEROPEN routine:
;
; XMOVEI 16,arglist
; PUSHJ 17,useropen
;
; Passes an argument list of the following form:
;
; -3,,0
; IFIW TP%INT,,address of unit
; IFIW TP%LBL,,address of FAB
; IFIW TP%LBL,,address of RAB
;
; The user's routine returns AC0 non-zero on failure, zero on
; success.
;
; CALLING SEQUENCE:
;
; PUSHJ P,CALUOP
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; T1 - Contents of UOPN(D)
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
UOUNT==0 ;Unit arg offset
UOFAB==1 ;FAB address offset
UORAB==2 ;RAB address offset
UOARNM==3 ;Number of USEROPEN args
CALUOP: XMOVEI T1,@T1 ;Get address to call
SKIPN (T1) ;destination valid?
$ACALL MEU ;?Missing EXTERNAL
MOVEM T1,USRADR ;Save it
MOVE T1,FAB(D)
PUSHJ P,RETSUC ;Assume success
MOVE T1,RAB(D)
PUSHJ P,RETSUC
PUSH P,L ;Save L
XMOVEI L,UOPARG ;Point to arglist
HRLI T1,(IFIW TP%INT,) ;Setup unit #
HRRI T1,%CUNIT
MOVEM T1,UOUNT(L) ;Save as unit argument
HRLI T1,(IFIW TP%LBL,) ;Setup FAB address
HRR T1,FAB(D)
MOVEM T1,UOFAB(L) ;Save as FAB arg
HRLI T1,(IFIW TP%LBL,) ;Setup RAB address
HRR T1,RAB(D)
MOVEM T1,UORAB(L) ;Save as RAB arg
PUSHJ P,@USRADR ;Call USEROPEN
POP P,L ;Restore L
JUMPE T0,%POPJ1 ;User says it succeeded
;Since the user says the routine failed, we will believe him/her. The 2
; pathological cases are:
;
; 1) AC0 .EQ.0 but the routine actually failed to $OPEN and $CONNECT.
; This will result in unpredictable failures on subsequent I/O.
; 2) AC0 .NEQ.0 but the routine actually succeeded. This will result
; in an unpredictable FOROTS "error".
PUSHJ P,RABSTV ;Update RAB status first
CAIGE T2,ER$MIN ;Error in RAB?
PUSHJ P,FABSTV ;No, must be in FAB
$DCALL UOF ;USEROPEN failed
;Argument list passed to USEROPEN routine
SEGMENT DATA
-UOARNM,,0
UOPARG: BLOCK UOARNM
USRADR: BLOCK 1 ;Address of USEROPEN routine
SEGMENT CODE
> ; End %IF20
SUBTTL NTTOPS - Determine if remote operating-system is TOPS
;++
; FUNCTIONAL DESCRIPTION:
;
; Checks the OSTYPE(D) to determine whether the remote system is
; TOPS.
;
; CALLING SEQUENCE:
;
; PUSHJ P,NTTOPS
; <Return here if TOPS> ;TOPS is an error condition!
; <Return here if not TOPS>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; NODNAM(D) - Node name
; OSTYPE(D) - OS code from CONFIG XAB
;
; OUTPUT PARAMETERS:
;
; T2 - OSTYPE(D)
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T2.
;
;--
;[5000] New
%IF20,<
NTTOPS: SKIPN NODNAM(D) ;Remote file?
POPJ P, ;No, must be TOPS
MOVE T2,OSTYPE(D) ;Get OS code
CAIE T2,XA$T20 ;TOPS20?
CAIN T2,XA$T10 ;or TOPS10?
POPJ P, ;Yes, return+1
JRST %POPJ1 ;No, return+2
> ; End %IF20
SUBTTL %RMLKP - Lookup an RMS file
;++
; FUNCTIONAL DESCRIPTION:
;
; Does a $PARSE/$SEARCH lookup on the DDB file to determine whether
; the file exists, using a scratch FAB and %TXTBF to receive the FNA
; string; or, if entry RMLKD is called, uses the FAB pointed to
; by FAB(D).
;
; Calls %RMFNS to pull together a filespec string from its DDB
; fields.
;
; For remote files:
; If the lookup succeeds, the expanded filespec string, including
; attributes, if any, is stored in EXFBUF so a later %GTFNS call
; will not have to re-lookup the file.
;
; For all files:
; IJFN is set to -1 if the lookup succeeds.
;
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMLKP
; <Return here if file not found>
; <Return here if file exists>
;
; INPUT PARAMETERS:
;
; None
;
;
; IMPLICIT INPUTS:
;
; NODNAM(D) - Node name
; DDB filespec fields
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; %TXTBF - Recieves DDB filespec string
; EXFBUF - Resultant expanded filespec, or 0
; if lookup failed
; IJFN(D) - Set to -1 if lookup succeeds
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Invokes RMS.
; Uses T1,T2,T4.
;
;--
;[5001] New
IF10,<
%RMLKP: $SNH ;Should NOT get here on TOPS-10
> ;End IF10
%IF20,<
%RMLKP: XMOVEI T4,SCRFAB ;Enter here to use SCRFAB
MOVEM T4,LKPFAB ;Save as local FAB address
SETOM RLSFLG ;Flag "release link" on exit
JRST RMLKC ;and join common code
RMLKD: MOVE T4,FAB(D) ;Enter here for FAB(D)
MOVEM T4,LKPFAB ;We'll use this FAB
SETZM RLSFLG ;Flag "don't release link" on exit
RMLKC: PUSHJ P,ABINI ;Re-init NAM,SCRFAB, TYP
MOVE T1,[POINT 7,EXFBUF] ;Destination for FNA string
MOVEM T1,DESPTR ;Save also for resultant string
PUSHJ P,%RMFNS ;Get DDB filespec string
MOVE T4,LKPFAB
$STORE T1,FNA,<(T4)> ;Save address
XMOVEI T1,NAMBLK ;Get NAMBLK's address
$STORE T1,NAM,<(T4)> ;Link to FAB
$PARSE @LKPFAB,LKPERR ;Lookup the file
$SEARCH @LKPFAB,LKPERR ;Get resultant filespec
MOVE T1,LKPFAB ;Get FAB's address
PUSHJ P,FABST2 ;Update FAB STV
SETOM IJFN(D) ;Flags files exists
MOVE T4,LKPFAB ;Get FAB address
SKIPE RLSFLG ;Release link?
PUSHJ P,RLSLNX ;Yes
PUSHJ P,DRJOFF ;Turn DRJ off
PUSHJ P,RLFJFN ;Toss any RMS-returned JFN
;Save the resultant expanded filespec, with attributes.
SETZM CVFLAG ;Don't ^V anything
PUSHJ P,RETRSA ;
JRST %POPJ1 ;OK, return +2
LKPERR: CAIE T2,ER$FLK ;File locked for some reason?
JRST LKPFNF ;No, not found or ambiguous
;Here for a "File is locked" $SEARCH failure. This is sufficient evidence
;that the file exists, so we clear the error and return to $SEARCH+1.
;Note that even though it failed, $SEARCH has updated the NAM block.
SKIPE T1,FAB(D) ;If a real FAB,
PUSHJ P,RETSUC ; clear the error
$RETURN ;Return from LKPERR error call
LKPFNF: POP P,%RMPDP ;Save error return
SETZM IJFN(D) ;File doesn't exist
SETZM EXFBUF ;No resultant string
SETZM EXFATT ;and no attributes
PUSHJ P,FABST2 ;Update FAB STV
;Flag an ambiguous state if we never got conclusive evidence...
CAIE T2,ER$FNF ;File not found?
SETOM UNKXST ;No, can't determine existence
SKIPE RLSFLG ;Release link?
PJRST RLSLNX ;Yes, return +1
PUSHJ P,DRJOFF ;Turn DRJ OFF!
POPJ P,
SEGMENT DATA
LKPFAB: BLOCK 1 ;Address of lookup FAB
RLSFLG: BLOCK 1 ;Non-zero if link to be released
SEGMENT CODE
> ; End %IF20
SUBTTL RETRSA - Store resultant filespec
;++
; FUNCTIONAL DESCRIPTION:
;
; Saves the resultant filespec string from the NAM block after
; a $PARSE/$SEARCH sequence. The string is stored where DESPTR
; points. Attributes, if any, are included. EXFATT will contain
; a byte pointer to the beginning of the attributes portion.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RETRSA
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; DESPTR - Byte pointer to destination
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; Filespec is written to destination.
; EXFATT is updated with a byte pointer to the attributes string,
; which may be zero.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5001] New
%IF20,<
RETRSA: MOVE T1,DESPTR ;Get pointer
MOVEM T1,FNSPNT ;Point FNSCLR at it
PUSHJ P,FNSCLR ;Clear it first
MOVE T1,DESPTR
PUSHJ P,CVTFNS ;Convert string
MOVNI T2,1 ;Back up over the null
IBP T2,T1
MOVEM T2,FNSPNT ;Store
MOVEM T2,EXFATT ;Save attributes pntr, too
PJRST GUSPWA ;Add attributes and return
> ;End %IF20
SUBTTL DRJON - Set DRJ for remote files
;++
; FUNCTIONAL DESCRIPTION:
;
; Sets the DRJ bit for remote files so a $CLOSE will not release
; the network link, or the JFN.
;
; CALLING SEQUENCE:
;
; PUSHJ P,DRJON
; <Return here>
;
; INPUT PARAMETERS:
;
; T4 - Address of FAB
;
; IMPLICIT INPUTS:
;
; NODNAM(D) - Nodename
; FAB(D) - FAB address
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB(D) FOP - FB$DRJ set if remote
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5002] New
%IF20,<
DRJON: $FETCH T1,FOP,<(T4)> ;Get FOP bits
TXO T1,FB$DRJ ;Set DRJ
$STORE T1,FOP,<(T4)> ;Bits back
POPJ P, ;Return
> ;End %IF20
SUBTTL DRJOFF - Turn off DRJ
;++
; FUNCTIONAL DESCRIPTION:
;
; Turn off DRJ in the FAB
;
; CALLING SEQUENCE:
;
; PUSHJ P,DRJOFF
; <Return here>
;
; INPUT PARAMETERS:
;
; T4 - Address of FAB
;
; IMPLICIT INPUTS:
;
; NODNAM(D) - Nodename
; FAB(D) FOP - FB$DRJ
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB(D) FOP - DRJ turned off
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5002] New
%IF20,<
DRJOFF: $FETCH T1,FOP,<(T4)> ;Get FOP bits
TXZ T1,FB$DRJ ;Turn off DRJ
$STORE T1,FOP,<(T4)> ;Reset FOP
POPJ P,
> ;End %IF20
SUBTTL LOCON - Turn on Locate Mode
;++
; FUNCTIONAL DESCRIPTION:
;
; Sets the Locate Mode bit in the RAB
;
; CALLING SEQUENCE:
;
; PUSHJ P,LOCON
; <Return here>
;
; INPUT PARAMETERS:
;
; T4 - Address of RAB
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) ROP - RB$LOC
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5004] New
%IF20,<
LOCON: $FETCH T1,ROP,<(T4)> ;Get ROP bits
TXO T1,RB$LOC ;Turn Locate on
$STORE T1,ROP,<(T4)> ;Reset
POPJ P,
> ;End %IF20
SUBTTL LOCOFF - Turn off Locate Mode
;++
; FUNCTIONAL DESCRIPTION:
;
; Turns off the Locate Mode bit in the FAB
;
; CALLING SEQUENCE:
;
; PUSHJ P,LOCOFF
; <Return here>
;
; INPUT PARAMETERS:
;
; T4 - Address of RAB
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) ROP - RB$LOC off
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5004] New
%IF20,<
LOCOFF: $FETCH T1,ROP,<(T4)> ;Get ROP bits
TXZ T1,RB$LOC ;Turn off Locate
$STORE T1,ROP,<(T4)>
POPJ P,
> ;End %IF20
SUBTTL EOFON - Turn on RB$EOF in RAB(D)
;++
; FUNCTIONAL DESCRIPTION:
;
; Sets EOF option bit in the RAB.
;
; CALLING SEQUENCE:
;
; PUSHJ P,EOFON
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) ROP - RB$EOF
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T4.
;
;--
;[5000] New
%IF20,<
EOFON: MOVE T4,RAB(D) ;Get RAB address
$FETCH T1,ROP,<(T4)> ;Get existing ROP bits
TXO T1,RB$EOF ;Turn on EOF
$STORE T1,ROP,<(T4)> ;Set
POPJ P,
> ;End %IF20
SUBTTL EOFOFF - Turn off RB$EOF in RAB(D)
;++
; FUNCTIONAL DESCRIPTION:
;
; Clears EOF bit in ROP of RAB(D).
;
; CALLING SEQUENCE:
;
; PUSHJ P,EOFOFF
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) ROP - RB$EOF cleared
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T4.
;
;--
;[5000] New
%IF20,<
EOFOFF: $FETCH T1,ROP,<(T4)> ;Turn off EOF
TXZ T1,RB$EOF
$STORE T1,ROP,<(T4)>
POPJ P,
> ;End %IF20
SUBTTL %RMFNS - Return DDB filespec
;++
; FUNCTIONAL DESCRIPTION:
;
; Returns the DDB filespec as a string in the buffer pointed to by
; T1.
;
; The filestring is of the form:
;
; {node::}dev:<dir>file.typ.gen{;Attributes:}
;
; On return T1 contains the address of the string.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMFNS
; <Return here>
;
; INPUT PARAMETERS:
;
; T1 - Byte pointer to destination buffer where
; filespec is to be written
;
; IMPLICIT INPUTS:
;
; DDB filespec fields
;
; OUTPUT PARAMETERS:
;
; T1 - Address of destination buffer
;
; IMPLICIT OUTPUTS:
;
; Writes the filespec to the destination buffer
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5000] New
%IF20,<
%RMFNS: MOVEM T1,SAVPTR ;Save destination pointer
MOVEM T1,FNSPNT ; also for FNOJFN
PUSHJ P,FNOJFN ;Output up to generation
MOVE T1,GEN(D) ;Get generation
CAME T1,[ASCIZ/0/] ;Is it zero?
JRST GUSER ;No
MOVE T1,%GNPNT ;Yes, don't output a generation
MOVEM T1,FNSPNT ;Back up pointer
GUSER: PUSHJ P,GUSPWA ;Get USERID, PASSWORD, ACCOUNT,PROT
HRRZ T1,SAVPTR ;Restore original address
POPJ P, ;Return
SEGMENT DATA
SAVPTR: BLOCK 1 ;Pointer storage
DESPTR: BLOCK 1
SEGMENT CODE
> ; End %IF20
SUBTTL GUSPWA - Assemble file attributes
;++
; FUNCTIONAL DESCRIPTION:
;
; Writes USERID, PASSWORD, ACCOUNT, and PROTECTION attributes from
; the DDB to the destination string.
;
; CALLING SEQUENCE:
;
; PUSHJ P,GUSPWA
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FNSPNT - Byte pointer to destination where string is
; to be written
; USERID(D) - DDB USERID field
; PASWRD(D) - PASSWORD
; ACCNT(D) - ACCOUNT
; PROT(D) - PROTECTION
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FNSPNT - Pointer is updated
;
; Writes DDB fields to the destination.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
GUSPWA: SKIPN USERID(D) ;Any USERID?
JRST GPASS ;No, check password
MOVEI T1,[ASCIZ/;USER:/] ;Prefix
PUSHJ P,ASCFNS ;Output it
XMOVEI T1,USERID(D) ;Data
PUSHJ P,ASCFNS ;Output it
GPASS: SKIPN PASWRD(D) ;Any PASSWORD?
JRST GACC ;No, check account
MOVEI T1,[ASCIZ/;PASS:/] ;Prefix
PUSHJ P,ASCFNS ;Output it
XMOVEI T1,PASWRD(D) ;Data
PUSHJ P,ASCFNS ;Output it
GACC: SKIPN ACCNT(D) ;Any ACCOUNT?
JRST GPRO ;No, check protection
MOVEI T1,[ASCIZ/;A:/] ;Prefix
PUSHJ P,ASCFNS ;Output it
XMOVEI T1,ACCNT(D) ;Data
PUSHJ P,ASCFNS ;Output it
GPRO: SKIPN PROT(D) ;Any PROTECTION?
JRST RMFNZ ;No, finish up
MOVEI T1,[ASCIZ/;P:/] ;Prefix
PUSHJ P,ASCFNS ;Output it
XMOVEI T1,PROT(D) ;Data
PUSHJ P,ASCFNS
RMFNZ: SETZ T2,
IDPB T2,FNSPNT ;End with null
POPJ P, ;Return
> ; End %IF20
SUBTTL %RMEFN - Return filespec for error messages
;++
; FUNCTIONAL DESCRIPTION:
;
; Called from FOROPN ERFTAB to return a filespec for use in
; error messages--i.e. don't promiscuously return Decnet access
; attributes as part of the filespec.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMEFN
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FNSPNT - Byte pntr to where filespec is to be written
; NODNAM(D) - Node name
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FNSPNT - Byte pntr updated
; SAVPTR - Original FNSPNT saved
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T3.
;
;--
;[5000] New
%IF20,<
%RMEFN: MOVE T1,FNSPNT ;Get and save destination
MOVEM T1,SAVPTR
PUSHJ P,FNOJFN ;Output up to generation
SKIPE NODNAM(D) ;Remote file?
POPJ P, ;Yes, now have full expanded spec
MOVE T2,SAVPTR ;Local file, treat like non-RMS disk
MOVX T1,GJ%SHT+GJ%OFG+GJ%FLG ;Get parse-only JFN
GTJFN%
ERJMP FNOJFN ;Couldn't, at least output DDB fields
MOVE T2,T1 ;Copy JFN
MOVE T1,SAVPTR ;Restore pointer
SETZ T3, ;No defaults
JFNS% ;Get disk-like spec
JSHALT
MOVEM T1,FNSPNT ;Update pointer
MOVE T1,T2 ;Now release the JFN
RLJFN%
JSHALT ;Shouldn't fail
POPJ P, ;Return
> ; End %IF20
SUBTTL %RMGXF - Return expanded filestring
;++
; FUNCTIONAL DESCRIPTION:
;
; Returns an expanded TOPS20-style filestring in the buffer
; pointed to by global FNSPNT. Called from FOROPN %GTFNS
; with destination buffer cleared and pointer in FNSPNT.
;
; The destination buffer must not be either the RSA or ESA
; buffers pointed to by the NAM block.
;
; The filespec is obtained in one of two ways, depending on the
; setting of IJFN(D) and the status (open/not open) of the file:
;
; IJFN(D) is -1: If the file is not open, but a previous call
; to %RMLKP has returned a resultant string, use
; that. If the file is open already, just return
; the DDB filespec.
;
; IJFN(D) is 0: A deferred-open file. Just return the DDB filespec.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMGXF
; <Return here>
;
; INPUT PARAMETERS:
;
; FNSPNT - Byte pointer to buffer where expanded filespec
; is to be written
;
; IMPLICIT INPUTS:
;
; IJFN(D) - -1 if the file is currently open or a successful
; %RMLKP lookup call has established that it exists.
; FLAGS(D) - Flags
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; DESPTR - Saved destination pointer
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
IF10,<
%RMGXF: $SNH ;Should NOT get here on TOPS-10
> ;End IF10
%IF20,<
%RMGXF: MOVE T1,FNSPNT ;Get destination pointer
SKIPN T2,IJFN(D) ;Any JFN status?
JRST %RMFNS ;No, just get DDB string
CAME T2,[-1] ;If not 0, must be -1!
$SNH ;Bad
MOVE T2,FLAGS(D) ;Get flags
TXNE T2,D%IN+D%OUT ;Is file actually open?
JRST %RMFNS ;Yes, just return DDB string
;Here when the file is not open, or IJFN says we don't know whether the
;file exists or not. If a previous call to %RMLKP has succeeded, IJFN
;will be -1 and EXFBUF will contain the resultant expanded filespec. If
;EXFBUF for some reason hasn't been updated, we have to do a full lookup!
MOVEM T1,DESPTR ;Save destination pointer
SETZM CVFLAG ;Don't ^V anything
SKIPE EXFBUF ;Do we have a resultant spec?
PJRST RETRSA ;Yes, return it
PUSHJ P,%RMLKP ;No. Must do a lookup/expansion
$SNH ;?File not found
PJRST RETRSA ;OK, return string
> ; End %IF20
SUBTTL %RMRFS - Return filespec to DDB variables
;++
; FUNCTIONAL DESCRIPTION:
;
; Returns filespec fields to the DDB. Obtains a parse-only JFN
; on the filespec string pointed to by RSA of the NAMBLK, then
; calls %DOJFNS to update the DDB. The parse-only JFN is discarded
; on return.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMRFS
; <Return here>
;
; INPUT PARAMETERS:
;
; NAMBLK - NAM filespec pointers
; N$RSA - Pointer to expanded filespec
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; NODNAM(D) - Nodename
; DEV(D) - Device
; DIR(D) - Directory
; FILNAM(D) - Name
; EXT(D) - Extension
; GEN(D) - Generation
; PASWRD(D) - Password
; ACCNT(D) - Account
; USERID(D) - Userid
; IJFN(D) - Set, then set to -1 on return to
; indicate DDB contains expanded RMS filespec.
;
; FNSPNT - Destination byte pointer
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
%RMRFS: MOVE T1,[POINT 7,%TXTBF] ;Setup destination pntr
MOVEM T1,DESPTR ;Save
SETOM CVFLAG ;Turn on ^V'ing
PUSHJ P,RETRSA ;Copy string
MOVE T2,DESPTR ;Get string pointer
MOVX T1,GJ%SHT+GJ%OFG+GJ%FLG ;Get parse-only JFN
GTJFN%
JSHALT ;Should not fail
MOVEM T1,IJFN(D) ;Setup for JFNS call
PUSHJ P,%DOJFNS ;Update DDB
PUSHJ P,RELJFN ;Release JFN
SETOM IJFN(D) ;Flag file exists
POPJ P, ;Return
> ; End %IF20
SUBTTL %RMISW/%RSISW - Switch an RMS/RSF file from output to input
;++
; FUNCTIONAL DESCRIPTION:
;
; Called only for sequential RMS and RSF files. Switches to input
; by setting ICNT(D) to zero, so subsequent READ will return EOF.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMISW ;Called only from FOROPN ISWTAB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ICNT(D) - Current free byte count, cleared.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; For RSF files, writes the current window.
; Uses T1.
;
;--
;[5003] New
%IF20,<
%RSISW: PUSHJ P,%OCLR ;Clear unused bytes in last word
PUSHJ P,RSFOCP ;Output current output window
%RMISW: SETZM ICNT(D) ;Tell IN. we're at EOF!
POPJ P,
> ; End %IF20
SUBTTL %RMOSW - Switch an RMS file to output
;++
; FUNCTIONAL DESCRIPTION:
;
; Switch an RMS file from input to output, truncating
; if necessary. The routine determines whether we are already at
; EOF (thus allowing a bypass of the truncate operation) by performing
; a preliminary $FIND on the next record. If this gets an EOF, and
; the file is already open for write access, we can leave. If we
; don't have write access, or are not at EOF, close the file, reopen
; it for exclusive access, position to the RFA from the $FIND, and
; truncate.
;
; A switch to output is not cheap for a remote file!
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMOSW ;Called from FOROPN OSWTCH
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ORGAN(D) - ORGANIZATION
; RAB(D) - RAB address
; FAB(D) - FAB address
; RFA - RFA from last read/write
; FLAGS(D) - DDB flags
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) RAC - RB$RFA for $TRUNCATE
; FAB(D) FOP - FB$DRJ
; SHR - FB$NIL
; FAC - FB$GET!FB$PUT!FB$TRN
; FLAGS(D) - D%WRT if not already set
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T4.
; May close, reopen, and truncate the file.
;
;--
;[5004] New
%IF20,<
%RMOSW: SETZM EOFFLG ;Clear extremely local "at EOF" flag
SETZM IDXREL ;Clear "IDX/relative file" flag
SETZM ICNT(D) ;Clear input pointers, we need
SETZM IPTR(D) ; an output buffer
LOAD T1,ORGAN(D) ;See if the filetype allows truncating
CAIE T1,OR.REL ;If relative,
CAIN T1,OR.IDX ;or indexed
SETOM IDXREL ;Flag it
SKIPN IDXREL ;Indexed or Relative file?
JRST OSWSEQ ;No, go truncate, maybe
MOVE T1,FLAGS(D) ;IDX/REL. Get DDB flags
TXNE T1,D%WRT ;Already have WRITE access?
POPJ P, ;Yes, nothing to do
JRST OSWCLS ;No, have to close/open
OSWSEQ: MOVE T4,RAB(D) ;Get RAB address
MOVX T1,RB$SEQ ;Set for sequential access
$STORE T1,RAC,<(T4)>
PUSHJ P,FIND$ ;Do $FIND
JFCL ;Ignore error for a moment
PUSHJ P,RABSTV
$FETCH T1,RFA,<(T4)> ;Get the RFA
MOVEM T1,OSWRFA ;Save
CAIGE T2,ER$MIN ;Error?
JRST OSWCLS ;No, go close file
CAIE T2,ER$EOF ;Yes. Was it EOF?
JRST OSWERR ;No, something bad
;We were already at EOF. If we already have WRITE access to the file, there's
; nothing left to do.
SETOM EOFFLG ;Flag "at EOF".
MOVE T1,RAB(D)
PUSHJ P,RETSUC ;Clear error
MOVE T1,FLAGS(D) ;Get DDB flags
TXNE T1,D%WRT ;WRITE access?
POPJ P, ;Yes, all done
OSWCLS: MOVX T1,D%WRT ;We have WRITE access now
IORM T1,FLAGS(D)
MOVE T4,RAB(D)
PUSHJ P,DRJON ;Keep link
PUSHJ P,CLOS$ ;Do $CLOSE
JRST OSWERR ;Error
PUSHJ P,DRJOFF ;Turn DRJ off!
MOVX T1,FB$NIL ;Get exclusive access to file
SKIPE IDXREL ;unless IDX/relative file
$FETCH T1,SHR,<(T4)> ;Don't change share access
$STORE T1,SHR,<(T4)>
MOVX T1,FB$ALL ;Get write access
$STORE T1,FAC,<(T4)>
SETZ T1,
$STORE T1,FOP,<(T4)> ;Clear FOP bits
MOVE T4,FAB(D) ;Get FAB address again
MOVE T1,[POINT 7,%TXTBF] ;Setup to get DDB filespec
PUSHJ P,%RMFNS ;Get it
$STORE T1,FNA,<(T4)> ;Set filespec in FNA
PUSHJ P,OPEN$ ;Do $OPEN
JRST OSWERR ;Error
MOVE T4,RAB(D) ;Get RAB address
SKIPN IDXREL ;If indexed or relative
SKIPN EOFFLG ;or we were not at EOF, normal connect
JRST RMOSCN
PUSHJ P,EOFON ;Turn on EOF
RMOSCN: SETZ T1, ;Clear RAC
$STORE T1,RAC,<(T4)>
$STORE T1,KBF,<(T4)> ;Any key buffer
$STORE T1,KSZ,<(T4)> ;and size
PUSHJ P,CONN$ ;Do $CONNECT
JRST OSWERR ;Error
PUSHJ P,EOFOFF ;Turn off EOF
;Here for the full $TRUNCATE, unless already at EOF.
MOVX T1,RB$RFA ;Get RFA access
$STORE T1,RAC,<(T4)>
SKIPN IDXREL ;Relative?
SKIPE EOFFLG ;At EOF?
JRST RMOSRT ;Yes, don't truncate
MOVE T1,OSWRFA ;Get our RFA
$STORE T1,RFA,<(T4)>
PUSHJ P,FIND$ ;Do $FIND
JRST OSWERR ;Error
PUSHJ P,TRUN$ ;Do $TRUNCATE
JRST OSWERR ;Error
MOVX T1,D%MOD ;Set file-is-modified
IORM T1,FLAGS(D)
RMOSRT: SKIPN IDXREL ;IDX/REL?
POPJ P, ;No, all done
SKIPN T1,RFA(D) ;Any last record to reposition to?
POPJ P, ;No, done
$STORE T1,RFA,<(T4)> ;Yes, set RFA
PUSHJ P,FIND$ ;Re-position to it
TRNA
POPJ P,
;Here for fatal %RMOSW errors.
OSWERR: PUSHJ P,EOFOFF ;Turn off EOF
PUSHJ P,DRJOFF ;and DRJ
$ACALL IOE ;Bad error
SEGMENT DATA
OSWRFA: BLOCK 1 ;RFA for $TRUNCATE
IDXREL: BLOCK 1 ;Indexed/Relative file flag
SEGMENT CODE
> ; End %IF20
SUBTTL %RSOSW - Switch an RSF file to output
;++
; FUNCTIONAL DESCRIPTION:
;
; Called from OSWTCH via DSKOSW via CLSOUT. Switches an RSF file from
; input to output. EOFN(D) has been setup previously to point at
; the highest file byte number so far read from the file. File
; truncation occurs at EOFN.
;
; A switch to output is not cheap for remote files!
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RSOSW ;Called from FOROPN CLSOUT
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; EOFN(D) - New highest file byte #
; BPW(D) - Bytes/word
; FLAGS(D) - DDB flags
; FAB(D) - FAB address
; RAB(D) - RAB address
; IPTR(D) - Input pointer
; WSIZ(D) - Window size
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB(D) FAC - Reset to write access
; SHR - To NIL for truncation
; RAB(D) BKT - To desired page number
; BYTN(D) - To next-window-byte
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4.
;
;--
;[5004] New
IF10,<
%RSOSW: $SNH ;Should NOT get here on TOPS-10
> ;End IF10
%IF20,<
%RSOSW: MOVE T3,EOFN(D) ;Get highest file byte
MOVE T1,BPW(D) ;Get bytes/word
LSH T1,LWSIZ ;Get bytes/page
ADDI T3,-1(T1) ;and pages written
IDIVI T3,(T1) ;rounded
;T3 has file page # of EOF byte.
;Try to read the next file page to see if we are already at EOF
ADDI T3,1 ;Bump page #
MOVEM T3,SAVPAG ;Save
MOVEM T3,T1 ;Copy
SETZM EOFFLG ;Clear "At EOF" flag
PUSHJ P,LOCBKT ;Locate page
TRNA ;Error, investigate
JRST ROSCLS ;No error, go close file
CAIE T2,ER$EOF ;Was it EOF?
CAIN T2,ER$RNF ;or page not found?
TRNA ;Yes, OK
JRST ROSWER ;No, something bad
;Already at EOF. If we already have WRITE access to the file, there's
;nothing left to do!
SETOM EOFFLG ;Flag we are at EOF
MOVE T1,RAB(D)
PUSHJ P,RETSUC ;EOF! Clear error
MOVE T1,FLAGS(D) ;Get DDB flags
TXNE T1,D%WRT ;WRITE access?
PJRST %SOCNT ;All done! Set output count
;Here when not at EOF, or need write access. A full OPEN/CLOSE/TRUNCATE
; is required.
ROSCLS: MOVX T1,D%WRT ;We have WRITE access now
IORM T1,FLAGS(D)
MOVE T4,FAB(D) ;Get FAB address
PUSHJ P,DRJON ;Set DRJ, keep net link
PUSHJ P,CLOS$ ;Do $CLOSE
JRST ROSWER ;Error
PUSHJ P,DRJOFF ;Turn DRJ OFF!
MOVX T1,FB$ALL ;Get full write access
$STORE T1,FAC,<(T4)>
MOVX T1,FB$NIL ;Exclusive
$STORE T1,SHR,<(T4)>
MOVE T1,[POINT 7,%TXTBF] ;Setup to get DDB filespec
PUSHJ P,%RMFNS ;Get it
$STORE T1,FNA,<(T4)> ;Set filespec in FNA
PUSHJ P,OPEN$ ;Do $OPEN
JRST ROSWER ;Error
PUSHJ P,CONN$ ;Do $CONNECT
JRST ROSWER ;Error
;Here for $TRUNCATE. The BKT we just read is the page after our EOF byte.
; Truncate from that page to the end...unless we were already at EOF.
SKIPE EOFFLG ;At EOF?
PJRST %SOCNT ;Yes, no need for $TRUNCATE
MOVE T1,SAVPAG ;Get page # back
$STORE T1,BKT,<(T4)> ;Set it
PUSHJ P,TRUN$ ;Do $TRUNCATE
JRST ROSWER ;Error
MOVX T1,D%MOD ;Set file-is-modified
IORM T1,FLAGS(D)
;File is shorter, b'gad. Remap our file window
HRRZ T1,IPTR(D) ;Get address of data
JUMPE T1,%POPJ ;If no data, leave
MOVN T1,WSIZ(D) ;Set to map new window
ADDM T1,BYTN(D)
PUSHJ P,RMAPW ;Map the pages
MOVE T1,WSIZ(D) ;Set next window byte number
ADDM T1,BYTN(D)
PJRST %SOCNT ;Go update count, return
;Here on fatal errors
ROSWER: PUSHJ P,DRJOFF ;Turn DRJ OFF!
$ACALL IOE
SEGMENT DATA
SAVPAG: BLOCK 1 ;Save file page #
EOFFLG: BLOCK 1 ;"At EOF" flag
SEGMENT CODE
> ;End %IF20
SUBTTL GETBKT - $READ a remote page
;++
; FUNCTIONAL DESCRIPTION:
;
; $READs a bucket (page) whose page number is in T1 to the buffer
; whose address is in T2. Updates RAB STS/STV.
;
; CALLING SEQUENCE:
;
; PUSHJ P,GETBKT
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; T1 - File page number to read
; T2 - Destination address for page
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; Returns STS value in T2.
; Returns address of RAB in T4.
;
; IMPLICIT OUTPUTS:
;
; RAB(D) BKT - Set to page #
; UBF - Set to destination address
; USZ - Set to page size (words)
; RAC - Set to BLK
; RFA - Cleared
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4
;
;--
;[5004] New
%IF20,<
GETBKT: MOVE T4,RAB(D) ;Get RAB address
$STORE T1,BKT,<(T4)> ;Set page number to read
$STORE T2,UBF,<(T4)> ;Set destination
MOVEI T1,PSIZ ;Set size to one page
$STORE T1,USZ,<(T4)>
$FETCH T1,RAC,<(T4)> ;Turn on BLK mode
TXO T1,RB$BLK
$STORE T1,RAC,<(T4)>
SETZ T1, ;Clear RFA
$STORE T1,RFA,<(T4)>
PUSHJ P,READ$ ;Do $READ
PJRST LOCOFF ;Turn off Locate Mode if on, error ret
PUSHJ P,LOCOFF ;Turn off Locate Mode
JRST %POPJ1
> ;End %IF20
SUBTTL LOCBKT - GETBKT in Locate mode
;++
; FUNCTIONAL DESCRIPTION:
;
; Calls GETBKT with Locate Mode set. A temporary destination
; buffer (required by RMS, but unused!) is allocated and
; deallocated.
;
; CALLING SEQUENCE:
;
; PUSHJ P,LOCBKT
; <Error return; buffer deallocated>
; <Success return; buffer deallocated>
;
; INPUT PARAMETERS:
;
; T1 - BKT (page) to locate
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; Returns STS value in T2.
; Returns address of RAB in T4.
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[5004] New
%IF20,<
LOCBKT: MOVEM T1,SAVBKT ;Save target bucket #
MOVEI T1,PSIZ ;Get temp buffer
PUSHJ P,%GTBLK
$ACALL MFU ;Can't
MOVEM T1,T2 ;Copy for GETBKT
MOVE T4,RAB(D) ;Get RAB address
PUSHJ P,LOCON ;Turn on Locate Mode
MOVE T1,SAVBKT ;Get BKT #, T2 has destination adr
PUSHJ P,GETBKT ;$READ it
JFCL ;Ignore error for a moment
PUSH P,T2 ;Save STS code
PUSHJ P,FTMPPG ;Deallocate temp buffer
POP P,T2 ;Retrieve T2
CAIL T2,ER$MIN ;Error?
POPJ P, ;Yes, take error return
PJRST %POPJ1 ;Take success return
SEGMENT DATA
SAVBKT: BLOCK 1 ;Save BKT #
SEGMENT CODE
> ;End %IF20
SUBTTL PUTBKT - $WRITE a file page
;++
; FUNCTIONAL DESCRIPTION:
;
; $WRITEs the bucket (page) whose number is in T1, and whose core
; address is in T2. Updates RAB STS/STV.
;
; CALLING SEQUENCE:
;
; PUSHJ P,PUTBKT
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; T1 - File page # to write
; T2 - Core buffer address
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) BKT - Page #
; RBF - Buffer address
; RSZ - Buffer size in bytes
; RFA - Cleared
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4.
;
;--
;[5004] New
%IF20,<
PUTBKT: MOVE T4,RAB(D) ;Get RAB address
$STORE T1,BKT,<(T4)> ;Set BKT #
$STORE T2,RBF,<(T4)> ;Set buffer address
MOVEI T1,PSIZ ;Get page size in words
IMUL T1,BPW(D) ;Convert to bytes
$STORE T1,RSZ,<(T4)> ;Store in RAB
SETZ T1,
$STORE T1,RFA,<(T4)> ;No RFA
$FETCH T1,RAC,<(T4)> ;Get current access bits
TXO T1,RB$BLK ;Turn on block mode
$STORE T1,RAC,<(T4)>
PUSHJ P,WRIT$ ;Do $WRITE
POPJ P, ;Error
JRST %POPJ1 ;Success
> ;End %IF20
SUBTTL %RMCSY - Maybe OPEN on a CLOSE/EXIT
;++
; FUNCTIONAL DESCRIPTION:
;
; Called from FOROPN CLSITY processing for deferred-open files
; which have not yet been opened. This routine performs a lookup
; on the file. If it exists, it returns +2; if not, +1 for a full
; OPEN. %RMCSY is called instead of %RMLKP so we can avoid
; requesting and relinquishing a network link.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMCSY
; <Return here if file does not exist>
; <Return here if the file exists>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB(D) - Address of allocated FAB
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; May invoke RMS.
; May initialize a FAB
; Uses T1,T4.
;
;--
;[5002] New
%IF20,<
%RMCSY: SKIPN T1,FAB(D) ;Already have a FAB?
PUSHJ P,RMFAB ;No, allocate one
MOVEM T1,FAB(D) ;Save its address
MOVEM T1,T4 ;Copy it
PUSHJ P,RMLKD ;Lookup the file, keep net link
PJRST FETOST ;Not there, return for full OPEN
PUSHJ P,DRJOFF
PUSHJ P,RLSLNK ;There, release link
JRST %POPJ1 ;Return +2
> ;End %IF20
SUBTTL FETOST - Fetch the OS type into OSTYPE(D)
;++
; FUNCTIONAL DESCRIPTION:
;
; Called after a $PARSE has updated the CONFIG XAB with the remote
; OS type. Stores the OS code in OSTYPE(D)
;
; CALLING SEQUENCE:
;
; PUSHJ P,FETOST
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; XA$OST from the CONFIG XAB
;
; OUTPUT PARAMETERS:
;
; T2 - OS type code
;
; IMPLICIT OUTPUTS:
;
; OSTYPE(D)
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; T2,T4.
;
;--
;[5000] New
%IF20,<
FETOST: MOVE T4,FAB(D) ;Get FAB
$FETCH T2,XAB,<(T4)> ;Get XAB link
JUMPE T2,%POPJ ;None, return
$FETCH T2,OST,<(T2)> ;Get OS type
STORE T2,OSTYPE(D) ;Save
POPJ P,
> ;End %IF20
SUBTTL %RMCLS - Close an RMS-opened file
;++
; FUNCTIONAL DESCRIPTION:
;
; Closes RMS and RSF files. For RSF files, writes modified pages
; before closing the file.
;
; CALLING SEQUENCE:
;
; Called only from FOROPN CLSITA via CLSTAB
; Returns +1 on a successful CLOSE, otherwise enters dialog mode.
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
; INDX(D) - Device type
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; OJFN/IJFN - Cleared on success
; I/O flags - D%IN+D%OUT+D%WRT+D%MOD cleared on success
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4.
; On $CLOSE errors, deallocates any XAB chain.
;
;--
;[5002] New
IF10,<
%RMCLS: $SNH ;Should NOT get here on TOPS-10
> ;End IF10
%IF20,<
%RMCLS: MOVE T4,FAB(D) ;Get FAB address
PUSHJ P,DRJOFF ;Make sure DRJ is OFF!
$FETCH T1,IFI,<(T4)> ;Is file open now?
JUMPE T1,%POPJ ;No, don't close it
LOAD T1,INDX(D) ;Get file type
CAIN T1,DI.RSF ;RSF?
PUSHJ P,RMCPG ;Yes, write modified buffers
MOVE T1,[POINT 7,%TXTBF]
PUSHJ P,%RMFNS ;Get address of filespec
MOVE T4,FAB(D)
$STORE T1,FNA,<(T4)> ;Set in FAB
PUSHJ P,CLOS$ ;Do $CLOSE
JRST RMCLER ;Error
SETZM IJFN(D) ;Clear the JFN
SETZM OJFN(D)
MOVX T1,D%IN+D%OUT+D%WRT+D%MOD ;Turn off the I/O bits
ANDCAM T1,FLAGS(D)
POPJ P, ;Return
;Here on $CLOSE errors.
RMCLER: PUSHJ P,RMDUXB ;Deallocate any XAB chain
LOAD T2,STS(D) ;Get error status
CAIE T2,ER$DCF
CAIN T2,ER$DPE ;Ignore protocol errors, the file
POPJ P, ; is really closed
$ACALL CLS ;?Close failed
> ; End %IF20
SUBTTL RMCPG - Write modified RSF pages
;++
; FUNCTIONAL DESCRIPTION:
;
; Called when closing RSF files to write modified pages for
; random-access files, or the last buffer for sequential file,
; free the buffer for sequential files, and deallocate the page
; table and the page flag table. Deallocation is accomplished
; through calls to %FREPGS and %FREBLK.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RMCPG
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; WPTR(D) - Address of file pages
; WTAB(D) - Address of in-core page table
; WADR(D) - Offset into WTAB for random-access files
; BUFCT(D) - Number of pages
; PFTAB(D) - Page flag table
; FLAGS(D) - DDB flags
; CC(U) - CARRIAGECONTROL
; BSIZ(D) - Bytesize
; EOFN(D) - EOF byte #
; BPW(D) - Bytes/word
; DMODE(D) - Data mode
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; WPTR,WADR - Cleared
; FDB file page - FB%FOR set if file is CC=FORTRAN
; FB%BSZ set to BSIZ(D)
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4,P1.
;
;--
;[5002] New
%IF20,<
RMCPG: SKIPN WPTR(D) ;Anything to write?
POPJ P, ;No
SKIPN WTAB(D) ;Sequential-access?
JRST CLSSEQ ;Yes, free buffer
SETZM WADR(D) ;Random, point to table start
LOAD P1,BUFCT(D) ;Get # pages
RMPLP: PUSHJ P,RMWPG ;Write if modified
AOS WADR(D) ;Point to next page
SOJG P1,RMPLP ;Do all pages
JRST FREBFS ;Deallocate tables, etc.
;Here for a sequential close to write last buffers.
CLSSEQ: MOVE T1,FLAGS(D) ;Sequential. Get flags
TXNN T1,D%OUT ;Last I/O output?
JRST FREBFS ;No, go free up memory
PUSHJ P,%OCLR ;Yes, clear unused chars of last word
PUSHJ P,RSFOCP ;Output last buffer
;Here for both sequential and random close to deallocate pages, tables, etc.,
; and to update the FDB if necessary.
FREBFS: MOVE T1,WPTR(D) ;Get page pointer
LOAD T2,BUFCT(D) ; and number of pages
PUSHJ P,%FREPGS ;Free them
SETZM WPTR(D) ;Clear window addresses
SETZM WADR(D)
SKIPE T1,WTAB(D) ;If there is a page table
PUSHJ P,%FREBLK ;Free that
SKIPE T1,PFTAB(D) ;And any flag table
PUSHJ P,%FREBLK
MOVE T1,FLAGS(D) ;Get flags
TXNN T1,D%MOD ;Was file modified?
POPJ P, ;No, we're done
;File was modified, so get the FDB page and update it.
PUSHJ P,RSRFDB ;Get FDB page for file
$ACALL CLS ;?Can't: Close failed
MOVEM T1,FDBADR ;Save address
MOVEM T1,T4
LOAD T1,CC(U) ;Get CARRIAGECONTROL
CAIE T1,CC.FOR ;CC=FORTRAN?
JRST FBBSZ ;No, don't set bit
;T4 has the base address of the FDB block in dynamic memory
MOVE T1,.FBCTL(T4) ;Get .FBCTL word of FDB
TXO T1,FB%FOR ;Set Fortran bit
MOVEM T1,.FBCTL(T4) ;Restore to FDB
FBBSZ: MOVE T1,.FBBYV(T4) ;Get .FBBYV word of FDB
MOVX T2,FB%BSZ ;Get field mask
TDZ T1,T2 ;Clear byte size field
LOAD T2,BSIZ(D) ;Get byte size we've been using
LSH T2,^D24 ;Shift into position
TDO T1,T2 ;Set size
MOVX T2,FB%MOD ;Get field mask
TDZ T1,T2 ;Clear data mode field
LOAD T2,DMODE(D) ;Get data mode
MOVSI T2,(T2) ;Shift into position
TDO T1,T2 ;Set it
MOVEM T1,.FBBYV(T4) ;Return to FDB
MOVE T1,EOFN(D) ;Get file size in bytes
LOAD T2,BSIZ(D) ;Get bytesize
CAIE T2,^D36 ;36 bits?
JRST FBSIZ ;No, use EOFN as is
ADD T1,BPW(D) ;Yes, round up
SUBI T1,1
IDIV T1,BPW(D) ;Get words
FBSIZ: MOVE T2,.FBSIZ(T4) ;Get file size word
SETZ T2, ;Clear it
TDO T2,T1
MOVEM T2,.FBSIZ(T4)
MOVE T1,FDBADR ;Get FDB address
PUSHJ P,RSWFDB ;Write the FDB page
$ACALL CLS ;?Can't: Close failed
PJRST FTMPPG ;Free the page, and return
SEGMENT DATA
FDBADR: BLOCK 1 ;Address of page containing FDB
SEGMENT CODE
> ; End %IF20
SUBTTL RMWPG - Write modified random-access pages
;++
; FUNCTIONAL DESCRIPTION:
;
; Writes one page from the page table if modified.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RMWPG
; <Return here>
;
; INPUT PARAMETERS:
;
; P1 - File page number to check/write
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
; WADR(D) - Offset into WTAB of least used page
; WPTR(D) - Core page address of file pages
; WTAB(D) - Address of in-core page table
; PFTAB(D) - Address of page flag table (-1=modified)
; BPW(D) - Bytes/word
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) BKT - Set to file page # +1
; UBF - Set to address of in-core page
; RSZ - Set to bytes/in-core page
; RAC - Set to RB$BLK for block-mode
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4.
;
;--
;[5003] New
%IF20,<
RMWPG: MOVE T1,WADR(D) ;Get page table offset
ADD T1,PFTAB(D) ;Point to the page flag table
SKIPL (T1) ;Modified?
POPJ P, ;No, just return
SETZM (T1) ;Flag unmodified
MOVE T1,WADR(D) ;Get page table offset to this page
ADD T1,WTAB(D) ;Point into table
MOVE T1,(T1) ;Get page number
ADDI T1,1 ;+1 for bucket
MOVE T2,WADR(D) ;Get offset again for process page
ADD T2,WPTR(D) ;Get process page number
LSH T2,LWSIZ ;Make into address
PUSHJ P,PUTBKT ;$WRITE it
$ACALL IOE ;Can't
POPJ P, ;OK, return
> ; End %IF20
SUBTTL %RMREN - Rename a remote file via RMS
;++
; FUNCTIONAL DESCRIPTION:
;
; Renames a file via RMS and returns the expanded filespec
; from the rename DDB to the old DDB. $RENAME requires 2 FABs,
; which are allocated and deallocated.
;
; If the file is local, this routine transfers control to FOROPN's
; DSKREN for a standard rename operation, bypassing RMS. This is
; necessary (not simply more efficient) because RMS-accessed files
; never perform a GTJFN% and thus locally will never properly interpret
; logical names in the filespec.
;
; If a local filespec is being renamed to a remote spec, produce
; an ER$RTN (Two different nodes) error. The reverse (remote to
; local spec) is permitted, since the rename JFNBLK defaults node
; and access data to those specified in the original filespec.
;
; CALLING SEQUENCE:
;
; Called only from FOROPN CHKREN via RENTAB.
; Returns +2 on success, else $DCALLs to DIALOG.
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; NODNAM(D) - Node name
; GEN(D) - Generation number. If zero, a -1 is used
; in the rename spec to produce the next
; higher generation
; %RNAMD - Rename DDB
; %OLDDB - Old DDB
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; Old DDBs filespec fields are updated with the expanded rename
; filespec.
;
; FAB1/FAB2 - Address of rename FABs
; STS(D) - Set to ER$RTN if a local spec is being
; renamed to a remote spec.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
; Allocates 2 temporary FABs, which are deallocated.
;
;--
;[5002] New
%IF20,<
%RMREN: MOVE T1,%OLDDB ;See if either DDB had a node
MOVE T2,%RNAMD
SKIPE NODNAM(T1) ;Is file remote?
JRST RMRENR ;Yes
SKIPN NODNAM(T2) ;This one, too?
JRST DSKREN ;No, do it the simple way
MOVEI T3,ER$RTN ;?Two different remote nodes
STORE T3,STS(T1) ;Put error where FORERR will find it
STORE T3,STS(T2)
$DCALL RNM
RMRENR: PUSHJ P,RMFAB ;Get a FAB for old filespec
MOVEM T1,FAB1 ;Save
MOVE T1,[POINT 7,%TXTBF] ;Get filespec string
PUSHJ P,%RMFNS
MOVE T4,FAB1
$STORE T1,FNA,<(T4)> ;Store filespec address
MOVE D,%RNAMD ;Point at %RNAMD
PUSHJ P,RMFAB ;Get FAB for rename filespec
MOVEM T1,FAB2 ;Save
MOVEM T1,T4 ;Copy
PUSHJ P,ABINI ;Initialize some arg blocks
XMOVEI T1,NAMBLK ;Point at NAMBLK
$STORE T1,NAM,<(T4)>
MOVE T1,GEN(D) ;Get generation
MOVEM T1,SAVGEN ;Save it
SKIPE T1 ;0?
CAMN T1,[ASCIZ/0/] ;or 0?
MOVE T1,[ASCIZ/-1/] ;Yes, set to -1
MOVEM T1,GEN(D)
MOVE T1,[POINT 7,TXTBF2] ;Get new filespec address
PUSHJ P,%RMFNS
MOVE T4,FAB2
$STORE T1,FNA,<(T4)> ;Store filespec address
MOVE T1,SAVGEN ;Restore generation
MOVEM T1,GEN(D)
$RENAME @FAB1,ERCRET,@FAB2
;If success, return the expanded RENAME filespec to the old DDB and return.
;If failure, report error. In any case deallocate the temp FABs and update
;STS/STV
MOVE T1,FAB1 ;Get FAB with status codes
MOVE D,%RNAMD ;Put them in rename DDB
PUSHJ P,FABST2 ;Update STS/STV
MOVE D,%OLDDB ;And also in the %OLDDB
PUSHJ P,FABST2
PUSHJ P,DEAFAB ;Deallocate temporary FABs
LOAD T2,STS(D) ;Get status
CAIL T2,ER$MIN ;Error?
$DCALL RNM ;Yes, report, take error return
PUSHJ P,%RMRFS ;No. Return filespec to DDB
JRST %POPJ1 ;Return +2 for success
DEAFAB: SKIPE T1,FAB1 ;Deallocate temp FABs
PUSHJ P,%FREBLK
SKIPE T1,FAB2
PUSHJ P,%FREBLK
SETZM FAB1 ;Say they're gone
SETZM FAB2
POPJ P,
SEGMENT DATA
FAB1: BLOCK 1 ;Address of original FAB
FAB2: BLOCK 1 ;Address of rename FAB
SAVGEN: BLOCK 1 ;Saved GEN(D)
SEGMENT CODE
> ; End %IF20
SUBTTL %RMDSP - Dispose of a file via RMS
;++
; FUNCTIONAL DESCRIPTION:
;
; Disposes of an RMS-opened file during CLOSE processing. For
; non-queued functions, SAVE and KEEP are no-ops; EXPUNGE is
; the equivalent of DELETE. Queued functions PUNCH and PLOT
; are errors; PRINT/LIST and SUBMIT for RMS files are legal
; only for VAX systems.
;
; CALLING SEQUENCE:
;
; Called only from FOROPN CLSITA via DPTAB. Returns +2 on
; success, +1 to enter DIALOG.
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; CLSDDB - DDB to use during DISPOSE
; %OLDDB - Original DDB (has OSTYPE)
; ODISP(D) - Orthogonal DISPOSE value
; OSTAT(D) - Orthogonal STATUS value
; INDX(D) - Device index
; STS(D) - RMS status code
; OSTYPE(D) - Operating system type
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; DISP(D) - Zeroed on error to force a recalculation
; of the dispose index after DIALOG.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4,D.
; May allocate and deallocate a FAB.
;
;--
;[5002] New
%IF20,<
%RMDSP: MOVE T2,CLSDDB ;Get CLOSE DDB
LOAD T1,ODISP(T2) ;Get orthogonal DISPOSE vale
JUMPN T1,RMQUE ;Non-zero means queued
;Here when the DISPOSE request is not a queued function (DELETE,
; EXPUNGE,SAVE)
LOAD T1,OSTAT(T2) ;Get orthogonal STATUS value
PUSHJ P,RMNSTA(T1) ;Go do it
POPJ P, ;Can't, error return
JRST %POPJ1 ;Did it
RMNSTA: JRST %POPJ1 ;UNKNOWN (same as SAVE)
JRST %POPJ1 ;SAVE
JRST RMERA ;DELETE
JRST RMEXP ;EXPUNGE (same as DELETE)
RMEXP:
RMERA: PUSHJ P,RMFAB ;Get a new FAB
MOVEM T1,FAB1 ;Save its address
MOVE T1,[POINT 7,%TXTBF]
PUSHJ P,%RMFNS ;Get filespec string (fom old D)
MOVE T4,FAB1 ;Get FAB address
$STORE T1,FNA,<(T4)> ;Store string address
$ERASE <(T4)>,ERCRET
MOVE T1,T4 ;Point at this FAB
PUSHJ P,FABST2 ;Update STS/STV in FAB(old D)
PUSHJ P,DEAFAB ;Deallocate temp FAB
LOAD T2,STS(D) ;Get status
CAIL T2,ER$MIN ;Error?
$DCALL DEL ;Yes, report error
JRST %POPJ1 ;No. Success return
;Here for queue function requests. T1 contains the DISPOSE value from ODISP
RMQUE: MOVEM T1,SODISP ;Save T1
MOVE T2,CLSDDB ;Get DDB
LOAD T1,INDX(T2) ;Get device type
CAIE T1,DI.RMS ;RMS file
JRST RMQUED ;No. Go do what we can
;PRINT or SUBMIT for remote RMS files is meaningful only if the remote
; system is a VAX (which can handle queued RMS files).
MOVE T2,%OLDDB ;Get old DDB
MOVE T2,OSTYPE(T2) ;Get OS type
CAIE T2,XA$VMS ;VMS system?
JRST UDOERR ;No, can't print/submit
RMQUED: MOVE T1,SODISP ;Get saved dispose value
PUSHJ P,RMQTB(T1) ;Go do it
POPJ P, ;Can't, error return
JRST %POPJ1 ;Did it
RMQTB: JRST %POPJ1 ;NOTHING
JRST RMPRIN ;PRINT
JRST UDOERR ;PUNCH:?Unsupported dispose option
JRST RMSUB ;SUBMIT
JRST UDOERR ;PLOT:?Unsupported dispose option
RMSUB: MOVX T1,FB$SCF ;Get SUBMIT bit
MOVEM T1,SODISP ;Save
JRST RMQDEL ;Go do it
RMPRIN: MOVX T1,FB$SPL ;Get PRINT bit
MOVEM T1,SODISP
RMQDEL: MOVE T2,SODISP ;Get whichever
LOAD T1,OSTAT(D) ;Get orthogonal STATUS value
CAIE T1,OS.DEL ;If DELETE
CAIN T1,OS.EXP ;or EXPUNGE
TXO T2,FB$DLT ;turn on DELETE bit
MOVEM T2,SODISP
PUSHJ P,RMFAB ;Get a FAB
MOVEM T1,FAB1 ;Save its address
MOVE T1,[POINT 7,%TXTBF]
PUSHJ P,%RMFNS ;Get filespec string
MOVE T4,FAB1 ;Get FAB address
$STORE T1,FNA,<(T4)>
MOVE T1,SODISP ;Get correct bits
$STORE T1,FOP,<(T4)> ;Set
$OPEN <(T4)> ;OPEN the file again, ignoring errors,
; since a $CLOSE will clean up the
; network link, if any.
$CLOSE <(T4)>,ERCRET ;CLOSE with DISPOSE option
MOVE T1,T4 ;Point at status FAB
PUSHJ P,FABST2 ;Update STS/STV in FAB(old D)
PUSHJ P,DEAFAB ;Deallocate temp FAB
LOAD T2,STS(D) ;Get status
CAIL T2,ER$MIN ;Was there an error
POPJ P, ;Yes
JRST %POPJ1 ;Did it
UDOERR: MOVE T1,SODISP ;Get DISPOSE value
MOVE T1,DSPNAM(T1) ;Get string address
$DCALL UDO
DSPNAM: 0 ;NOTHING
[ASCIZ \PRINT/LIST\]
[ASCIZ \PUNCH\]
[ASCIZ \SUBMIT\]
[ASCIZ \PLOT\]
SEGMENT DATA
SODISP: BLOCK 1 ;Save DISPOSE value
SEGMENT CODE
> ; End %IF20
SUBTTL %IRMS - Read next RMS record
;***************************************************************************
;* *
;* ENTRIES CALLED FROM FORIO *
;* *
;***************************************************************************
;++
; FUNCTIONAL DESCRIPTION:
;
; Reads an RMS record and sets up I/O pointers to it. Called for
; all RMS files (RSF files call %RMSIN/%RMRDW).
;
; CALLING SEQUENCE:
;
; PUSHJ P,%IRMS
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ORGAN(D) - File organization code
; RAB(D) - RAB address
; IRBUF(D) - Input record buffer pntr
; IRBLN(D) - Buffer length (bytes)
; RECTP(D) - RECORDTYPE=
; FORM(D) - FORM=
; BPW(D) - Bytes/word
; WTAB(D) - Random-access
; A.KVL - Keyed read value
; A.KRL - Keyed read relational value
; A.KID - Keyed read index id
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RFA(D) - Current record's RFA
; RAB(D) UBF - Buffer address
; USZ - Buffer size (words)
; RAC - Record access mode (SEQ, KEY)
; KBF - Set to REC=
; KSZ - Set to key size for indexed
; FLAGS(D) - Set if EOF
; BUFADR(D) - Reset if buffer expanded
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T0,T1,T3,T4.
;
;--
;[5003] New
%IF20,<
%IRMS: PUSHJ P,GETINB ;Get input buffer if needed
LOAD T1,ORGAN(D) ;Get ORGANIZATION
MOVE T4,RAB(D) ;Setup RAB address
PUSHJ P,ISORGT(T1) ;Do setup by organization
PUSHJ P,IRGET ;Do record input
SKIPE T1,KBFADR ;Temp KBF buffer?
PUSHJ P,%FREBLK ;Yes, toss it
SETZM KBFADR
PJRST RMSWPT ;Setup for I/O from window
IRGET: PUSHJ P,GET$ ;Do $GET
JRST IRMERR ;Error
$FETCH T1,RSZ,<(T4)>
MOVEM T1,IRLEN(D) ;Save # bytes actually read
MOVEM T1,IRCNT(D)
ADD T1,BPW(D) ;Round up to words
SUBI T1,1
IDIV T1,BPW(D)
MOVEM T1,RECLEN ;Store as local record length
$FETCH T1,RFA,<(T4)> ;Get returned RFA
STORE T1,RFA(D) ;Save
MOVE T1,CREC(D) ;Get record number for CACHIT
PJRST CACHIT ;Go cache, maybe, and return
;Here on $GET errors. If the error is ER$EOF, flag D%END and zero IRCNT.
; If the error is ER$RNF (record not found), we have tried to read a deleted
; record or a record not yet written. If ORG=REL and access is random, return
; RNR ("?record not written") error.
;
; If the error is ER$RTB (record too big), expand the
; record buffer, set access to RFA, re-$GET the record and return.
; All other errors abort.
IRMERR: CAIN T2,ER$EOF ;EOF?
JRST IRMEOF ;Yes, handle it
CAIN T2,ER$RNF ;Record not found?
JRST IRMRNF ;Yes, check it out
CAIN T2,ER$RTB ;Record too big?
JRST IRMRTB ;Yes.
;Here on fatal $GET errors.
PUSHJ P,IRMSTS ;Go update STS/STV
$ACALL IOE
IRMEOF: MOVX T0,D%END
IORM T0,FLAGS(D) ;Set EOF seen
SETZM IRCNT(D) ;We read zero characters
PUSHJ P,RABSTV
POPJ P,
IRMRNF: LOAD T1,ORGAN(D) ;Get ORG=
CAIN T1,OR.REL ;Relative?
SKIPGE WTAB(D) ;or random-access?
JRST RETRNR ;Yes, "Record not written"
MOVE T1,RAB(D) ;No
PUSHJ P,RETSUC ;Clear "error"
SETZM IRLEN(D) ;Return a null record
SETZM IRCNT(D)
POPJ P,
RETRNR: PUSHJ P,IRMSTS ;Go update STS/STV
LOAD T1,ORGAN(D) ;Get ORGANIZATION
CAIN T1,OR.IDX ;INDEXED?
$ACALL IOE ;Yes, "?Record not found"
$ACALL RNR ;Issue error
;?Record too big for buffer. STV contains the actual size of the
;record, so use that as minimum expansion size.
IRMRTB: $FETCH T3,STV,<(T1)>
PUSHJ P,EXPIRB ;Expand the buffer
PUSHJ P,IRBWIN ;Disguise it as a window
PUSHJ P,UBFUSZ ;Setup UBF,USZ
MOVX T1,RB$RFA
$STORE T1,RAC,<(T4)> ;Set RFA access
MOVE T1,RAB(D)
PUSHJ P,RETSUC
JRST IRGET ;And go try again
;Here for fatal errors. Update STS/STV, deallocate KBF if present
IRMSTS: PUSHJ P,RABSTV
SKIPE T1,KBFADR
PUSHJ P,%FREBLK
SETZM KBFADR
POPJ P,
;Here for ORGANIZATION=SEQUENTIAL
ISSEQ: MOVEI T1,[ASCIZ /SEQUENTIAL/]
SKIPE A.KVL ;Trying keyed read for OR.SEQ?
$ACALL KRI ;?Keyed read illegal
MOVX T1,RB$SEQ ;No. Assume sequential access
;NOTE: the following 2 lines can be uncommented whenever RMS decides
; to fix random $GETs to fixed-length sequential files...
; SKIPE WTAB(D) ;Random?
; MOVX T1,RB$KEY ;Yes, set it
$STORE T1,RAC,<(T4)> ;Set it in RAB
XMOVEI T1,@A.REC ;Get REC= (or 0 for seq-access)
$STORE T1,KBF,<(T4)>
POPJ P,
;Here for ORGANIZATION=RELATIVE. For random-access set RAC=KEY, where KBF
; points to the record number from a REC=. For sequential access set RAC=SEQ;
; the VAX-compatible RMS behavior now will be to silently skip sequential
; requests to read a deleted or empty record and return the next existing
; record (or EOF). This also means that RELATIVE files cannot be BACKSPACEd,
; since the actual file current record # is unavailable to FOROTS.
ISREL: MOVEI T1,[ASCIZ /RELATIVE/]
SKIPE A.KVL ;Trying keyed read for OR.REL?
$ACALL KRI ;?Keyed read illegal
MOVX T1,RB$KEY ;No. Assume random-access
SKIPN WTAB(D) ;Random?
MOVX T1,RB$SEQ ;No, sequential
$STORE T1,RAC,<(T4)> ;Set it in RAB
XMOVEI T1,@A.REC ;Get REC= (or 0 for seq-access)
$STORE T1,KBF,<(T4)>
JUMPE T1,%POPJ ;If seq access, done
MOVE T1,(T1) ;For random, update current rec
MOVEM T1,CREC(D)
POPJ P,
;Here for ORGANIZATION=INDEXED.
; If user's KEYxx keyed read data exists in A.KVL, we setup for a keyed
; read: RAC=KEY; KBF=A.KVL; KRF=keyid (index number); KSZ=A.KVL size in
; bytes for CHARACTER, else zero; ROP=Key relational data. If A.KVL is zero,
; this is a sequential read: RAC=SEQ, KBF/KSZ/ROP=0.
ISIDX: SKIPE A.KVL ;Keyed read?
JRST ISKIDX ;Yes
MOVX T1,RB$SEQ ;No, sequential
$STORE T1,RAC,<(T4)> ;RAC=SEQ
SETZ T1, ;Clear any KSZ/KBF pntrs
$STORE T1,KBF,<(T4)>
$STORE T1,KSZ,<(T4)>
POPJ P,
;Here for keyed read
ISKIDX: MOVX T1,RB$KEY ;RAC=KEY
$STORE T1,RAC,<(T4)>
SKIPN T1,A.KID ;KEYID specified?
JRST ISKKVL ;No, use last READ's, or primary
MOVE T1,@T1 ;Yes, get key-of-reference
$STORE T1,KRF,<(T4)> ;Store
ISKKVL: MOVE T1,A.KVL ;Get key data pntr
XMOVEI T1,@T1 ;Get address of KVL data
LDB T2,[POINTR (A.KVL,ARGTYP)] ;Get type data type
MOVEI T3,4 ;Assume 4 for INTEGER length
CAIE T2,TP%CHR ;CHARACTER?
JRST ISKSTO ;Integer, got the address
DMOVE T0,@A.KVL ;Yes, get descriptor and length
ADD T1,BPW(D) ;In words, plus spare byte(s)
IDIV T1,BPW(D)
PUSHJ P,%GTBLK ;Get tmp key buffer
$ACALL MFU ;Can't
MOVEM T1,KBFADR ;Save address
SUBI T1,1 ;Correct it
HXL T1,BYTPT(D) ;Make byte pntr to buffer
DMOVE T2,@A.KVL ;Get pntr/count back
PUSHJ P,MOVSTR ;Move data to destination
MOVE T4,RAB(D) ;Get RAB address
MOVE T1,KBFADR ;Get KBF address
DMOVE T2,@A.KVL ;Get length back
ISKSTO: $STORE T1,KBF,<(T4)> ;Set KBF
$STORE T3,KSZ,<(T4)> ;Set length
;Here to set key relational (KGE/KGT) value. A.KVL is cleared here,
;so a subsequent %IRMS call in the same READ statement will get the
;next sequential record in the current index.
ISKROP: $FETCH T1,ROP,<(T4)> ;First turn off existing relationals
TXZ T1,RB$KGE!RB$KGT
MOVE T2,@A.KRL ;Get user's new value
TDO T1,KRLTAB(T2) ;Set RMS bits
$STORE T1,ROP,<(T4)>
SETZM A.KVL
POPJ P,
SEGMENT DATA
KBFADR: BLOCK 1 ;Address of KBF data
SEGMENT CODE
KRLTAB: 0 ;(0) KEY=
0 ;(1) KEYEQ=
RB$KGE ;(2) KEYGE=
RB$KGT ;(3) KEYGT=
ISORGT: JRST ISSEQ ;NONE
JRST ISSEQ ;SEQUENTIAL
JRST ISREL ;RELATIVE
JRST ISIDX ;INDEXED
> ; End %IF20
SUBTTL GETINB - Get input buffer, setup RAB
;++
; FUNCTIONAL DESCRIPTION:
;
; Gets an input buffer if not already allocated, sets up window
; pointers to it, and sets up RAB UBF and USZ.
;
; CALLING SEQUENCE:
;
; PUSHJ P,GETINB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
; BUFADR(D) - Address of buffer
; IRBLN(D) - Buffer length (bytes)
; IRBUF(D) - Non-zero if already a buffer
; BPW(D) - Bytes/word
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) UBF - Buffer address
; USZ - Length in words
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T4
;
;--
;[5003] New
%IF20,<
GETINB: SKIPN IRBUF(D) ;Have buffer already?
PUSHJ P,GETIRB ;No, get one
PUSHJ P,IRBWIN ;Make it look like a wondow
UBFUSZ: MOVE T4,RAB(D) ;Get RAB address
MOVE T1,BUFADR(D) ;Get buffer address
$STORE T1,UBF,<(T4)> ;Store
MOVE T1,IRBLN(D) ;Get buffer size in bytes
ADD T1,BPW(D) ;Round up to words
SUBI T1,1
IDIV T1,BPW(D) ;Get it in words
$STORE T1,USZ,<(T4)> ;Store
POPJ P,
> ;End %IF20
SUBTTL IRBWIN - Make a buffer look like a window
;++
; FUNCTIONAL DESCRIPTION:
;
; Sets up pointers to a record buffer returned by GETIRB so it
; looks like a window.
;
; CALLING SEQUENCE:
;
; None
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; IRBUF(D) - Buffer pointer
; IRBLN(D) - Buffer size
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; WADR(D) - Updated with IRBUF-1
; BUFADR(D) - " " "
; WPTR(D) - Buffer page number
; WSIZ(D) - Size in bytes
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5003] New
%IF20,<
IRBWIN: MOVE T1,IRBUF(D) ;Get pntr-1 to it
MOVEI T1,1(1) ;Correct it
HRRZM T1,WADR(D) ;Save address
HRRZM T1,BUFADR(D) ;Here too
LSH T1,-LWSIZ ;Make it a page number
MOVEM T1,WPTR(D) ;Save
MOVE T1,IRBLN(D) ;Get buffer size
MOVEM T1,WSIZ(D) ;Save as window size in bytes
POPJ P,
> ; End %IF20
SUBTTL %UORMS - Setup output buffer for unformatted WRITE
;++
; FUNCTIONAL DESCRIPTION:
;
; Called for unformatted RMS writes to setup an output record
; buffer and make it look like a "window." If the buffer already
; exists, checks whether it should be expanded for variable-length
; output.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%UORMS
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ORBUF(D) - Address of record buffer, if any.
; RECTP(D) - RECORDTYPE=
; FORM(D) - FORM=
; BPW(D) - Bytes/word
; BYTPT(D) - Byte pointer
; BUFADR(D) - Buffer address
; RSIZE(D) - User-specified RECL
; ORBLN(D) - Buffer size in bytes
; ORBUF(D) - Buffer pointer
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; PAGNUM - Cleared
; BYTUSD - Bytes used in expanded buffer
; EOFN(D) - Infinity
; ORBUF(D) - BP to beginning of record buffer
; ORBEG(D) - " " " " " "
; ORBLN(D) - Buffer length, bytes
; WADR(D) - Set to buffer address
; BUFADR(D) - Set to buffer address
; WPTR(D) - Page number of buffer
; WSIZ(D) - Window size in bytes
; ICNT(D) - Record byte count
; IPTR(D) - Current record pntr
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[5004] New
%IF20,<
%UORMS: SKIPE ORBUF(D) ;Any buffer yet?
JRST CHKEXP ;Yes, maybe expand it
PUSHJ P,GETORB ;No. Get a buffer
SETZB T1,T2
DMOVEM T1,PAGNUM ;No used byte count for new buffer
GOTORB: PUSHJ P,ORBWIN ;Make it look like a "window"
;Clear new buffer
MOVE T3,ORBLN(D) ;Get length
ADD T3,BPW(D) ;Round up to words
SUBI T3,1
IDIV T3,BPW(D) ;Get # words
MOVE T1,BUFADR(D) ;Get start address to clear
SETZM (T1)
CAIN T3,1 ;One-word buffer?
JRST UORRET ;Yes
MOVSI T2,(T1)
HRRI T2,1(T1) ;start,,start+1
ADDI T1,(T3) ;Make the BLT limit+1
BLT T2,-1(T1)
UORRET: HRLOI T1,377777 ;Reset RMS's EOFN to infinite
MOVEM T1,EOFN(D)
POPJ P,
CHKEXP: SKIPE ORLEN(D) ;Any record length yet?
SKIPE RSIZE(D) ;Yes. Fixed recordsize specified?
JRST GOTORB ;Yes, no need to expand, or new buffer
HRRZ T1,IPTR(D) ;Any data?
JUMPE T1,GOTORB ;No, don't expand
MOVE T1,ICNT(D) ;Get words in window
IDIV T1,BPW(D)
JUMPG T1,GOTORB ;Room left
;Here to expand the "window"
HRRZ T1,ORBUF(D) ;Get old buffer address
ADDI T1,1 ;Corrected
MOVE T2,ORBLN(D) ;Get old length in bytes
MOVEM T2,BYTUSD ;Save as bytes used
MOVEM T3,ORLEN(D) ;Set current length
IDIV T2,BPW(D) ;in words
MOVEM T2,T3 ;Copy
LSH T3,1 ;Double it for new length
PUSHJ P,%MVBLK ;Move to bigger buffer
$ACALL RTL ;Can't
SUBI T1,1 ;Point to previous word
HXL T1,BYTPT(D) ;Make byte pntr to beg of new
MOVEM T1,ORBUF(D) ;Store new address
MOVEM T1,ORBEG(D)
IMUL T3,BPW(D) ;Get new length in bytes
MOVEM T3,ORBLN(D) ;Store
PUSHJ P,ORBWIN
JRST UORRET
ORBWIN: MOVE T1,ORBUF(D) ;Get pntr-1 to it
MOVEI T1,1(1) ;Correct it
HRRZM T1,WADR(D) ;Save address
HRRZM T1,BUFADR(D) ;Here too
LSH T1,-LWSIZ ;Make it a page number
MOVEM T1,WPTR(D) ;Save
MOVE T2,ORBLN(D) ;Get buffer size
MOVEM T2,WSIZ(D) ;Save as window size in bytes
SUB T2,BYTUSD ;Get bytes available
MOVEM T2,ORLEN(D) ;Set record length
MOVE T3,ORBUF(D) ;Get pntr again
MOVE T1,BYTUSD ;Get bytes used within "page"
ADJBP T1,T3 ;Update pntr
DMOVEM T1,IPTR(D) ;Save pntr/count
POPJ P,
> ; End %IF20
SUBTTL %ORMS - Write a record with RMS
;++
; FUNCTIONAL DESCRIPTION:
;
; Writes an RMS record.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%ORMS
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
; ORG - ORGANIZATION
; RAB(D) - Address of RAB
; ORGAN(D) - ORGANIZATION
; ORBEG(D) - BP to beginning of record buffer
; ORLEN(D) - Formatted actual record length
; ORSIZ(D) - Unformatted buffer length
; RECTP(D) - RECORDTYPE
; ORBLN(D) - Record buffer length, bytes
; A.REC - Address of record number
; CREC(D) - Current record #
; FLAGS(D) - DDB flags
; RFA(D) - RFA
; WTAB(D) - Non-zero if random-access
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) RAC - Record access (FB$SEQ, FB$KEY)
; RBF - Record buffer address
; RSZ - Record size, bytes
; KBF - Address of key data
; RFA(D) - RFA from successful output
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T0-T2,T4.
;
;--
;[5004] New
%IF20,<
%ORMS: MOVE T4,RAB(D) ;Get RAB address
MOVE T1,ORBEG(D) ;Get buffer address
MOVEI T1,1(T1) ;Adjust it
$STORE T1,RBF,<(T4)> ;Store
;If records are fixed-length, set RSZ to the buffer size, else set to
; the actual record-length in bytes (formatted), or the unformatted buffer
; size in bytes. Indexed files always set to MRSIZE.
SKIPN T1,ORLEN(D) ;Assume not fixed, use formt'ed len
MOVE T1,ORSIZ(D) ;or unformatted buffer length
LOAD T2,RECTP(D) ;Get RECORDTYPE
CAIN T2,RT.FIX ;FIXED?
MOVE T1,ORBLN(D) ;Yes, use fixed buffer length
LOAD T2,ORGAN(D) ;Get ORGANIZATION
CAIN T2,OR.IDX ;INDEXED?
MOVE T1,MRSIZE(D) ;Yes, use MRS
$STORE T1,RSZ,<(T4)> ;Store as RSZ
XMOVEI T1,@A.REC ;Get address of recnum (or 0)
SKIPN T1 ;If none, use CREC
XMOVEI T1,CREC(D)
$STORE T1,KBF,<(T4)>
LOAD T1,ORGAN(D) ;Get organization
MOVE T2,OSORGT(T1) ;Set RAC by org
$STORE T2,RAC,<(T4)>
MOVE T0,FLAGS(D) ;Get flags
TXNE T0,D%RWI ;Is this a REWRITE?
JRST DOUPD ;Yes, do an $UPDATE instead
;Ugly workaround for relative files. Do a pre-$PUT $FIND on the
;record to see if we will get ER$REX on the $PUT, which must be
;avoided for remote files since it may hang the CONTINUE(abort)
;sequence.
CAIN T1,OR.REL ;ORG=REL?
JRST REXFND ;Yes, do pre-$FIND
DOPUT: PUSHJ P,PUT$ ;Do $PUT
$ACALL IOE
ORMOK: $FETCH T1,RFA,<(T4)> ;Get the RFA
MOVEM T1,RFA(D) ;Save it
MOVE T1,CREC(D) ;Get record number for CACHIT
PUSHJ P,CACHIT ;Cache if necessary
PUSHJ P,ORINI ;Re-init the buffer
SKIPN WTAB(D) ;Random access?
POPJ P, ;No, all done
LOAD T1,ORGAN(D) ;Get ORGANIZATION
CAIN T1,OR.REL ;RELATIVE?
SKIPN A.FMT ;Yes. Formatted output?
POPJ P, ;No, we're done
;Special case for formatted random relative output. Since slash format
;or indefinte repeat may cause more than one record to be written per
;IOLST. call, we must forget about the user-specified record # in A.REC
;and instead use CREC the next time around (ugh), since otherwise
;the same record will get written again with the new data.
SKIPN T1,A.REC ;Get address of recnum
XMOVEI T1,CREC(D) ;or CREC if none
MOVE T1,@T1 ;Get the number
MOVEM T1,CREC(D) ;Set it as current
SETZM A.REC ;Clear A.REC pntr
POPJ P,
;Here for REWRITE (update an indexed/relative file record), or for
;random-access relative files that tried to $PUT a record to an
;already-existing record cell. Indexed records, and fixed-length
;relative records, cannot change record size on an $UPDATE
;(fixed-length records will have been truncated/padded by FOROTS).
;Variable records for which an MRS RECL has been specified
;will get an error if their updated length exceeds MRS.
;
;Indexed $UPDATEs may get errors if the primary key changes or a key
;value is duplicated where these are not allowed in the XAB chain.
DOUPD: MOVX T0,D%RWI ;Turn off REWRITE flag
ANDCAM T0,FLAGS(D)
PUSHJ P,UPDA$ ;Do $UPDATE
$ACALL IOE
JRST ORMOK ;Update RFA/STV, return
;Here to check if the $PUT will ER$REX for relative files.
;Sequential-access relative files fail with ER$REX;
;random-access relative files do an $UPDATE.
REXMM==50133 ;[5023] MAC/MICcode for REX STV
REXFND: PUSHJ P,FIND$ ;[5023] Find the target record
JRST DOPUT ;[5023] Presumably not there (good)
SKIPE WTAB(D) ;[5023] Random access?
JRST RELUPD ;[5023] Yes, do an $UPDATE
MOVX T2,ER$REX ;[5023] No. Make ER$REX error
SETZ T3, ;[5023] Assume local
SKIPE NODNAM(D) ;[5023] If remote
MOVEI T3,REXMM ;[5023] also return STV
PUSHJ P,MAKSTS ;[5023] Fake REX
$ACALL IOE
RELUPD: MOVE T1,ORBEG(D) ;[5023] Get buffer address
MOVEI T1,1(T1) ;[5023] Adjust it
$STORE T1,RBF,<(T4)> ;[5023] Store
JRST DOUPD ;go do $UPDATE
OSORGT: RB$SEQ ;NONE
RB$SEQ ;SEQUENTIAL
RB$KEY ;RELATIVE
RB$KEY ;INDEXED
> ;End %IF20
SUBTTL %RMFND - FIND a direct-access relative record
;++
; FUNCTIONAL DESCRIPTION:
;
; Called from FIND processing in FORIO for files with INDX(D) DI.RMS.
; This routine checks that the file is an RMS relative file opened
; for direct access. If not, it aborts. If so, it establishes
; the current record as specified in the user's REC=. No data is
; transferred. An attempt to find a non-existent or deleted
; record will (VAX compatibly) produce an error.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMFND
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ORGAN(D) - ORGANIZATION
; WTAB(D) - -1 if random-access
; RAB(D) - RAB address
; A.REC - User's REC=
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RFA(D) - Set to new current record
; RAB(D) RAC - RB$KEY
; RAB(D) RBF - Address of record number
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T4.
;
;--
;[5004]
IF10,<
%RMFND: $SNH ;Should NOT get here from TOPS-10
> ;End IF10
%IF20,<
%RMFND: LOAD T1,ORGAN(D) ;Get ORGANIZATION
SKIPE WTAB(D) ;Access must be direct
CAIE T1,OR.REL ;ORG must be RELATIVE
$ACALL CDR ;Can't do direct I/O to seq file
MOVE T4,RAB(D) ;Get RAB address
XMOVEI T1,@A.REC ;Get REC=
$STORE T1,KBF,<(T4)> ;Tell RMS about it
MOVX T1,RB$KEY ;Setup for keyed access
$STORE T1,RAC,<(T4)>
PUSHJ P,FIND$ ;Do $FIND
$ACALL IOE ;Error
$FETCH T1,RFA,<(T4)> ;Get RFA
MOVEM T1,RFA(D) ;Update
PJRST %SETAV ;Return
> ;End %IF20
SUBTTL %RMCRW - Check if a REWRITE is legal
;++
; FUNCTIONAL DESCRIPTION:
;
; Checks that the execution of a REWRITE statement is legal for
; the specified unit/file. The file must be an RMS indexed or
; relative file not opened READONLY.
;
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMCRW
; <Return here; errors to %ABORT>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; INDX(D) - File type
; ORGAN(D) - ORGANIZATION
; RO(D) - READONLY
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; If the requested REWRITE is illegal, enters error handler.
; Uses T1.
;
;--
;[5004] New
%IF20,<
%RMCRW: LOAD T1,ORGAN(D) ;Screen by ORGANIZATION
SKIPE T1 ;If none (non-RMS),
CAIN T1,OR.SEQ ;or SEQUENTIAL,
$ACALL SIF ;then illegal statement
SKIPE A.REC ;Illegal if record number given
$ACALL CDR ;Report random I/O to seq file
LOAD T1,RO(D) ;Get READONLY-ness
JUMPN T1,ILLOUT ;READONLY, complain
POPJ P, ;No, ok
> ;End %IF20
SUBTTL %RMREW - Rewind an RMS file
;++
; FUNCTIONAL DESCRIPTION:
;
; Rewinds a sequentially-accessed RMS file. An error is issued
; if the file is open for direct access.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMREW
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ORGAN(D) - ORGANIZATION
; WTAB(D) - Non-zero if access direct
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5004] New
%IF20,<
%RMREW: LOAD T2,ORGAN(D) ;Get ORGANIZATION
CAIE T2,OR.IDX ;Complain if INDEXED, or
SKIPE WTAB(D) ;random-access
$ACALL SIF ;?Statement illegal
MOVX T1,D%END ;Get Flags
ANDCAB T1,FLAGS(D) ;Set no EOF
PUSHJ P,%SETIN ;Get file open for input
PUSHJ P,REWI$ ;Rewind file
$ACALL IOE ;Error
SETZM CREC(D) ;Clear RECORD NUMBER
SETZM IPTR(D) ;Pretend no I/O done
SETZM ICNT(D) ;No bytes in buffer
SETZM BYTN(D) ;Set current byte number to 0
POPJ P, ;Return
> ; End %IF20
SUBTTL %RMBSR - BACKSPACE RMS sequential file
;++
; FUNCTIONAL DESCRIPTION:
;
; Backspace an RMS sequential file. If RFA cacheing is enabled,
; the cache is searched for the target RFA which matches the target
; record number. If not found, or cacheing has been disabled
; (FORPRM parameter CASHSZ is zero), the file is rewound and n-1
; records are read ($FIND) to position to the target record.
;
; BACKSPACE is legal only for RMS sequential files not opened
; ACCESS='APPEND'
;.
; CALLING SEQUENCE:
;
; PUSHJ P,%RMBSR
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ORGAN(D) - ORGANIZATION
; RAB(D) - Address of RAB
; ROP - RB$EOF
; CREC(D) - Current record #
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; CREC(D) - Decremented
; RAB(D) RAC - RB$KEY
; RFA(D) - Updated during REWIND
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T4.
; May rewind file and read n-1 records.
;
;--
;[5013] New
%IF20,<
%RMBSR: LOAD T1,ORGAN(D) ;Get ORGANIZATION
JRST BAKTAB(T1) ;Screen by organization
;Ensure that only ORG=SEQ RMS files can be BACKSPACEd.
BAKTAB: $SNH ;UNKNOWN (should not get here!)
JRST BAKSEQ ;SEQUENTIAL
$ACALL SIF ;RELATIVE (illegal)
$ACALL SIF ;INDEXED (illegal)
BAKSEQ: MOVE T4,RAB(D) ;Get RAB address
$FETCH T1,ROP,<(T4)> ;Get ROP bits
TXNE T1,RB$EOF ;/APPEND?
$ACALL SIF ;Yes, can't backspace
PUSHJ P,%SETIN ;Switch to input
SKIPG CREC(D) ;At beginning of file?
POPJ P, ;Yes, can't backspace more
SOS T1,CREC(D) ;Decrement CREC
MOVE T0,FLAGS(D) ;Get DDB flags
TXNE T0,D%END ;At EOF?
JRST %BAKEF ;Yes, just clear D%END
;Here for a cache search to see if the requested record number's RFA
; is cached. If so, $FIND it and return. If not, rewind and read n-1.
JUMPG T1,BSRGET ;If not at rec#1, must backspace
;Here if at first record. Must REWIND so next read gets same record.
PUSHJ P,REWI$ ;Do rewind
$ACALL IOE ;Error
POPJ P, ;Done
BSRGET: MOVEM T1,TRGREC ;Save target rec#
;Get an input buffer if needed
PUSHJ P,GETINB
;Search the cache for the RFA corresponding to our target record #. If
; cacheing has been disabled, must rewind and read n-1.
PUSHJ P,CSHFND ;Search the cache
JRST GOTRFA ;Found it
;Here when not cached, or no cache. Do a rewind.
PUSHJ P,REWI$ ;Rewind file
$ACALL IOE
SETZM LOCREC ;Clear local counter
MOVX T1,RB$SEQ ;Set sequential access
$STORE T1,RAC,<(T4)>
;Read n-1 records to position the file to the target record.
BSRLP: PUSHJ P,FIND$ ;$FIND a record
$ACALL IOE
$FETCH T1,RFA,<(T4)> ;Get RFA
STORE T1,RFA(D) ;Save for CACHIT
AOS T1,LOCREC ;Bump counter
PUSHJ P,CACHIT ;Update cache
SOSLE TRGREC ;Reached target # yet?
JRST BSRLP ;No, keep going
JRST BSRCRP ;Yes, establish as current record
;Here when we have the target RFA from the cache
GOTRFA: $STORE T1,RFA,<(T4)> ;Store target RFA
BSRCRP: MOVX T1,RB$RFA ;Set RFA access
$STORE T1,RAC,<(T4)>
PUSHJ P,GET$ ;Establish as current
$ACALL IOE
MOVX T1,RB$SEQ ;Reset to SEQ
$STORE T1,RAC,<(T4)>
POPJ P,
SEGMENT DATA
TRGREC: BLOCK 1 ;Target record number
LOCREC: BLOCK 1 ;Local record counter
SEGMENT CODE
> ;End %IF20
SUBTTL CSHFND - Search the cache for a record number
;++
; FUNCTIONAL DESCRIPTION:
;
; Searches the record/RFA cache for the requested record number and
; returns the matching RFA if found.
;
; CALLING SEQUENCE:
;
; PUSHJ P,CSHFND
; <Return here if rec# found>
; <Return here if not found>
;
; INPUT PARAMETERS:
;
; TRGREC - Target record number
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; T1 - RFA if found
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[5013] New
%IF20,<
CSHFND: SKIPN T2,CACHE(D) ;Cacheing enabled?
JRST %POPJ1 ;No, return +2
MOVEI T3,CACHSZ
ADD T3,T2 ;Get cache_end+1
CSHLP: CAML T2,T3 ;Beyond limit?
JRST %POPJ1 ;Yes, not found
MOVE T0,(T2) ;Get a record# from cache
JUMPE T0,%POPJ1 ;If entry is null, entry not found
CAMN T0,TRGREC ;Our target #?
JRST CSHGOT ;Yes
ADDI T2,2 ;No, bump pointer to next entry
JRST CSHLP ;Keep going
CSHGOT: MOVE T1,1(T2) ;Get associated RFA
POPJ P, ;Return
> ;End %IF20
SUBTTL %RMASV - Handle RMS ASSOCIATEVARIABLE
;++
; FUNCTIONAL DESCRIPTION:
;
; Updates the ASSOCIATEVARIABLE for RMS files. It is ignored for
; RMS files unless ORGANIZATION='RELATIVE' or ACCESS='DIRECT'.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMASV
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ORGAN(D) - ORGANIZATION
; ACC(D) - ACCESS
; CREC(D) - Current record
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; AVAR(D) - ASSOCIATEVARIABLE
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; T1,T2.
;
;--
;[5003] New
IF10,< ;No-op on TOPS10
%RMASV: POPJ P,
> ;End IF10
%IF20,<
%RMASV: LOAD T1,ORGAN(D) ;Get ORGANIZATION=
CAIE T1,OR.REL ;RELATIVE?
POPJ P, ;No, ignore assocvar
LOAD T1,ACC(D) ;Get ACCESS=
CAIE T1,AC.RIO ;ACCESS='DIRECT'?
CAIN T1,AC.RIN
TRNA ;Yes, set the AV
POPJ P, ;No, ignore AV
MOVE T2,AVAR(D) ;Get ASSOCVAR
MOVE T1,CREC(D) ;Get CREC
ADDI T1,1 ;Increment
MOVEM T1,(T2) ;Store
POPJ P,
> ; End %IF20
SUBTTL %RMCDL - Check if DELETE is legal
;++
; FUNCTIONAL DESCRIPTION:
;
; Checks whether a DELETE statement is legal for the requested
; file type. The file must be an RMS relative or indexed file
; for which a DDB has been established.
;
; If a DELETE statement is the first I/O statement for a deferred-
; open unit, a new file will be created for output, and the DELETE
; will fail with a "?No current record" error.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMCDL
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; %CUNIT - Current unit #
; DDBAD(U) - DDB address
; %DDBTAB(U) - UDBs
; RO(D) - READONLY
; ORGAN(D) - ORGANIZATION
; A.REC - Record number
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; %UDBAD - Flagged as I/O in progress
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
; $ACALLs if DELETE is illegal for file.
;
;--
;[5013] New
%IF20,<
%RMCDL: MOVE T1,%CUNIT ;Get unit number
SKIPN U,%DDBTA(T1) ;Get UDB addr
$ACALL SIF ;None. No implicit OPEN/DELETE
MOVEM U,%UDBAD ;We have started an I/O statement
MOVE D,DDBAD(U) ;Get DDB addr
LOAD T1,RO(D) ;Get READONLY-ness
JUMPN T1,ILLOUT ;Can't if readonly
LOAD T1,ORGAN(D) ;Get ORGANIZATION
JRST DELTAB(T1) ;Screen by organization
DELTAB: $ACALL SIF ;UNKNOWN (non-RMS)
$ACALL SIF ;SEQUENTIAL (illegal)
JRST RELDEL ;RELATIVE
JRST IDXDEL ;INDEXED
;Here for RELATIVE deletes. If direct-access, a REC= is required. If
;seq access, a REC= is forbidden.
RELDEL: SKIPN WTAB(D) ;Random I/O?
JRST RELDSQ ;No, must not have REC=.
SKIPN A.REC ;Yes. Must have REC=
$ACALL CDS
POPJ P,
RELDSQ: SKIPE A.REC ;Must not have REC=
$ACALL CDR
POPJ P,
;Here for INDEXED deletes. REC= forbidden.
IDXDEL: SKIPE A.REC ;Make sure there's no record #
$ACALL IRN
POPJ P,
> ;End %IF20
SUBTTL %RMDEL - DELETE an RMS record
;++
; FUNCTIONAL DESCRIPTION:
;
; DELETEs a record from an RMS relative or indexed file. If no REC=
; has been specified, this is a current-record delete: the last record
; successfully located by a READ or FIND is deleted (relative and indexed
; files). If a REC= is supplied (relative files only), the specified
; record is deleted.
;
; After a direct access delete, the ASSOCIATEVARIABLE is set to the
; next record.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMDEL
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
; A.REC - Record number
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) RAC - RB$KEY for direct delete
; KBF - Record number
; CREC(D) - Record number
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T4.
;
;--
;[5013] New
%IF20,<
%RMDEL: MOVE T4,RAB(D) ;Get RAB address
SETZ T1, ;Clear RAC
$STORE T1,RAC,<(T4)>
XMOVEI T1,@A.REC ;Get REC= (or 0)
$STORE T1,KBF,<(T4)>
JUMPE T1,DELREC ;If no REC, delete current rec
SKIPG T1,@T1 ;Direct delete. Legal record number?
$ACALL IRN ;No
MOVEM T1,CREC(D) ;Store as current record
MOVX T1,RB$KEY ;Set keyed access for REC= delete
$STORE T1,RAC,<(T4)>
PUSHJ P,FIND$ ;Do $FIND to establish current rec
$ACALL IOE ;Error
DELREC: PUSHJ P,DELE$ ;Do the delete
$ACALL IOE ;Error
PJRST %SETAV ;Done
> ;End %IF20
SUBTTL %RMCUL - Check if UNLOCK is legal
;++
; FUNCTIONAL DESCRIPTION:
;
; Checks whether an UNLOCK statement is legal for the requested
; file type. The file must be an RMS relative or indexed file
; for which a DDB has been established.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMCUL
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; %CUNIT - Current unit #
; DDBAD(U) - DDB address
; %DDBTAB(U) - UDBs
; ORGAN(D) - ORGANIZATION
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; %UDBAD - Flagged as I/O in progress
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
; $ACALLs if UNLOCK is illegal for file.
;
;--
;[5014] New
%IF20,<
%RMCUL: MOVE T1,%CUNIT ;Get unit number
SKIPN U,%DDBTA(T1) ;Get UDB addr
$ACALL SIF ;None. No implicit OPEN/DELETE
MOVEM U,%UDBAD ;We have started an I/O statement
MOVE D,DDBAD(U) ;Get DDB addr
LOAD T1,ORGAN(D) ;Get ORGANIZATION
JRST UNLTAB(T1)
UNLTAB: $ACALL SIF ;UNKNOWN (illegal)
$ACALL SIF ;SEQUENTIAL (illegal)
JRST %POPJ ;RELATIVE
JRST %POPJ ;INDEXED
> ; End %IF20
SUBTTL %RMUNL - UNLOCK an RMS record
;++
; FUNCTIONAL DESCRIPTION:
;
; UNLOCKS a record in an RMS file. The unlock statement uses
; the $FREE RMS service call. If a "no record is locked" error
; occurs it is ignored.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMUNL
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; %ERIOS - 2nd error number
; A.IOS - IOSTAT variable address
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2
;
;--
;[5014] New
%IF20,<
%RMUNL: PUSHJ P,FREE$ ;Call the $Free service to unlock rec
CAIN T2,ER$RNL ;Ignore "Record not locked" errors
SKIPA ;Good return
$ACALL IOE ;Error
MOVE T1,%ERIOS ;Get 2nd error number or zero
SKIPE T2,A.IOS ;Iostat variable to define?
MOVEM T1,@T2 ;Yes. Define IT
SETZM %UDBAD ;Now no I/O in progress
POPJ P, ;Return
> ;End %IF20
SUBTTL %RMEND - ENDFILE for RMS files
;++
; FUNCTIONAL DESCRIPTION:
;
; Perform ENDFILE processing for RMS sequential files: get the file
; open for output (thus truncating it), then get it open for input
; positioned at EOF. This statement is trapped as illegal for
; RMS relative and indexed files.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMEND
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ORGAN(D) - ORGANIZATION
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FLAGS(D) - D%END
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
; $ACALLs if ORGANIZATION=RELATIVE or INDEXED.
;
;--
;[5013] New
IF10,<
%RMEND: $SNH ;Should not get here on TOPS-10
> ;End IF10
%IF20,<
%RMEND: LOAD T2,ORGAN(D) ;Get file type
CAIE T2,OR.SEQ ;Must be sequential
$ACALL SIF
PUSHJ P,%SETOUT ;Set to output
PUSHJ P,%SETIN ;Then to input
MOVX T1,D%END ;at EOF
IORM T1,FLAGS(D)
POPJ P,
> ; End %IF20
SUBTTL %RMSIN - Read a sequential RSF page
;++
; FUNCTIONAL DESCRIPTION:
;
; Reads a page from a remote stream file accessed sequentially,
; and updates window pointers via FORIO routine SETPTR.
;
; Entry RMSMPW is called from %RMOPN to map in the last
; page of an RSF file opened ACCESS='APPEND'.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMSIN
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; BYTN(D) - Desired file byte #
; EOFN(D) - EOF byte #
; RAB(D) - Address of RAB
; BPW(D) - Bytes/word as a function of BYTESIZE and/or
; returned file bytesize
; WADR(D) - Address of process page to map to
; BUFCT(D) - Window page count
; WPTR(D) - Page number
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) BKT - Set to page # +1 of file to map
; RAC - Set to RB$BLK for block-mode I/O
; USZ - Set to PSIZ (^D512)
; UBF - Set to WADR(D)
; ICNT(D) - Set to count of free bytes in buffer
; FLAGS(D) - D%END set if EOF
; PAGNUM - Double word containing the page #, bytes used
; in page
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4.
;
;--
;[5003] New
%IF20,<
%RMSIN: MOVE T2,BYTN(D) ;Get target byte number
CAMGE T2,EOFN(D) ;At or past EOF?
JRST RMSMPW ;No
MOVX T1,D%END ;Yes. Get EOF
IORM T1,FLAGS(D) ;Set it
POPJ P, ;Return
RMSMPW: PUSHJ P,RMAPW ;Map some pages in
PUSHJ P,SETPTR ;Setup pointer/count
MOVE T2,BYTN(D) ;Get byte # of next window
CAMG T2,EOFN(D) ;Past EOF?
POPJ P, ;No, all done
SUB T2,EOFN(D) ;Get the difference
MOVNI T2,(T2) ;Make negative
ADDM T2,ICNT(D) ;Decrement count
POPJ P,
;Here to read an n-page window.
RMAPW: MOVE T4,RAB(D) ;Get RAB address
MOVE T2,BYTN(D) ;Get target byte #
MOVE T1,BPW(D) ;Calculate page #, get bytes/word
LSH T1,LWSIZ ;# bytes/page
IDIV T2,T1 ;Get file page #
DMOVEM T2,PAGNUM ;Save for SETPTR
ADDI T2,1 ;Bump page # for RMS
MOVEM T2,T1 ;Copy
;Loop to read in n pages
LOAD T3,BUFCT(D) ;Get buffer count
MOVNI T3,(T3) ;Negative
MOVSI T3,(T3) ;In left half
HRR T3,WPTR(D) ;Get page # of bottom page
RMSINL: MOVEI T2,(T3) ;Get core addr
LSH T2,LWSIZ
PUSHJ P,GETBKT ;$READ it
JRST SINERR ;Error
$FETCH T1,BKT,<(T4)> ;Increment file page to get
ADDI T1,1
AOBJN T3,RMSINL ;Back for more
POPJ P, ;Done
SINERR: MOVE T1,RAB(D) ;Get RAB address in T1
CAIE T2,ER$EOF ;EOF error?
CAIN T2,ER$RNF ;or non-existent page?
PJRST RETSUC ;Yes, not really an error, return
$ACALL IOE ;No, something bad
> ; End %IF20
SUBTTL %RMRDW - Read a random RSF page
;++
; FUNCTIONAL DESCRIPTION:
;
; Maps in a page from a randomly-accessed RSF file, writing any
; modified pages first.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMRDW
; <Return here>
;
; INPUT PARAMETERS:
;
; P1 - File page # to map
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
; WADR(D) - Offset into WTAB of least used page
; WPTR(D) - Core page address of file pages
; WTAB(D) - Page table
;
; OUTPUT PARAMETERS:
;
; T1 - Page table pointer
;
; IMPLICIT OUTPUTS:
;
; RAB(D) UBF - Set to destination page address
; BKT - Set to file page # +1
; USZ - Set to page length
; RAC - Set to RB$BLK for block-mode I/O
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4.
;
;--
;[5003] New
%IF20,<
%RMRDW: PUSHJ P,RMWPG ;Write any pages which are modified
MOVE T4,RAB(D) ;Get RAB address
MOVE T2,WADR(D) ;Get page table offset
ADD T2,WPTR(D) ;Get core page number
LSH T2,LWSIZ ;Convert to address
SETZM (T2) ;Clear destination page
MOVSI T1,(T2)
HRRI T1,1(T2) ;start,,start+1
BLT T1,PSIZ-1(T2) ;Clear page
MOVEI T1,1(P1) ;Get file page # +1
PUSHJ P,GETBKT ;$READ it
JRST RDWERR ;Some error, investigate
RDWRET: MOVE T1,WADR(D) ;OK. Get page table offset again
ADD T1,WTAB(D) ;Point into page table
MOVEM P1,(T1) ;Store new file page number
POPJ P,
RDWERR: CAIE T2,ER$EOF ;Non-existent page?
CAIN T2,ER$RNF
TRNA ;Yes, not really an error
$ACALL IOE ;No, some other error
MOVE T1,RAB(D)
PUSHJ P,RETSUC ;Clear the "error"
JRST RDWRET
> ; End %IF20
SUBTTL RMSWPT - Setup pointers to a file window
;++
; FUNCTIONAL DESCRIPTION:
;
; Calls SETPTR to update pointers to the window/buffer we
; just read.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RMSWPT
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; IRBEG(D) - Record buffer pointer
; BYTN(D) - Current byte number in file
; EOFN(D) - Number of bytes in file
; FLAGS(D) - DDB flags
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; IRPTR(D) - Receives IRBEG
; IPTR(D) - Receives IRBEG
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T2.
;
;--
;[5003] New
%IF20,<
RMSWPT: PUSHJ P,SETPTR ;Setup pointers to window
MOVE T1,IRBEG(D) ;Get record buffer ptr
MOVEM T1,IRPTR(D) ;Initialize it
MOVEM T1,IPTR(D)
SKIPE IRCNT(D) ;Any characters in record?
POPJ P, ;Yes, we're done
MOVE T0,FLAGS(D) ;Get flags
TXNE T0,D%END ;Zero chars; EOF also?
$ACALL EOF ;Yes
POPJ P,
> ; End %IF20
SUBTTL CACHIT - Cache record number and RFA
;++
; FUNCTIONAL DESCRIPTION:
;
; If CACHSZ is non-zero, a cache has been setup at OPEN time for
; sequential and sequentially-accessed RMS relative files. CACHE(D)
; points to the start the cache, CACHPT(D) to the next free cache
; entry.
;
; The cache is a block of CACHSZ words (CACHSR records * 2) of the
; form:
;
; !=====================================!
; CACHE(D) => ! Record number from CREC(D) !
; !-------------------------------------!
; ! RFA from $GET or $PUT !
; !-------------------------------------!
; ! !
;
; When CACHPT(D) points off the end of the cache, it is reset to
; the beginning.
;
;
; CALLING SEQUENCE:
;
; PUSHJ P,CACHIT
; <Return here>
;
; INPUT PARAMETERS:
;
; T1 - Record number to cache
;
; IMPLICIT INPUTS:
;
; RFA(D) - RFA from last $GET or $PUT
; CREC(D) - Current record number
; CACHE(D) - Address of cache
; CACHPT(D) - Free entry pointer
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; CACHPT(D) - Updated to point to next free
; cache location
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T3.
;
;--
;[5003] New
%IF20,<
CACHIT: SKIPN CACHE(D) ;Are we cacheing?
POPJ P, ;No
MOVE T2,CACHPT(D) ;Get address of free cache location
MOVEM T1,(T2) ;Save record # in cache
ADDI T2,1 ;Bump pointer
MOVE T1,RFA(D) ;Get RFA of record
MOVEM T1,(T2) ;Save in cache
ADDI T2,1 ;Bump pointer
MOVE T1,CACHE(D) ;Get cache start address
MOVEI T3,CACHSZ ;Get cache size
ADD T3,T1 ;Get last word+1
CAIL T2,(T3) ;At or beyond the end?
MOVE T2,T1 ;Yes, reset pntr to start
MOVEM T2,CACHPT(D) ;Save pointer
POPJ P, ;Return
> ; End %IF20
SUBTTL %RMSOU - Map or write an RSF buffer
;++
; FUNCTIONAL DESCRIPTION:
;
; Called from FORIO OSTAB for RSF files when ICNT(D) is zero
; to write out the current output window.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMSOU
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; BYTN(D) - Requested file byte number
; BPW(D) - Bytes/word
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; PAGNUM - Double word containing the page #, bytes used
; in page
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T3.
;
;--
;[5004] New
%IF20,<
%RMSOU: PUSHJ P,RSFOCP ;Output current window
SETZB T2,T3 ;Say we have a new window
DMOVEM T2,PAGNUM
PJRST SETPTR ;Setup new pointers
> ;End %IF20
SUBTTL RSFOCP - Output current RSF output window
;++
; FUNCTIONAL DESCRIPTION:
;
; Writes out the current window to the file, up to and including
; the window page containing the highest byte written so far to
; the file.
;
; Assuming a default 4 page window:
;
; WADR=Core address of IPTR=Byte pntr to last
; 1st window page byte written +1
; \/ \/
; =============================================================
; |/////////////:://////////////::/// :: |
; |/////////////:://////////////::/// :: |
; |/////////////:://////////////:://///// :: |
; =============================================================
; /\ /\
; WPTR=1st window page # EOFN=Highest file byte # written
;
;
; The calculation of how many window pages to write is as follows:
;
; 1) Using EOFN, calculate the highest file page number to write
;
; EOFN + ((bytes/page) - 1)
; LSTFPG = -------------------------
; (bytes/page)
;
; 2) Calculate the number of pages used in the window:
;
; (IPTR<rh> - WADR +1) + (PSIZ-1)
; WINPGS = ------------------------------
; PSIZ
;
; 3) The first file "bucket" to write is thus LSTFG-WINPGS+1.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RSFOCP
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; IPTR(D) - Byte pntr to last written byte in
; window
; WADR(D) - Core address of base window page
; WPTR(D) - Page number of base window page
; EOFN(D) - Highest byte written to file
; BPW(D) - Byes/word
; RAB(D) - Address of RAB
;
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RAB(D) BKT - Set to file page(s) to write
; RAC - RB$BLK for block mode I/O
; USZ - PSIZ
; RBF - Set to core page(s) to write
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
;
;--
;[5004] New
%IF20,<
RSFOCP: HRRZ T1,IPTR(D) ;Get address of data
JUMPE T1,%POPJ ;Leave if none
SUB T1,WADR(D) ;Get # words to write -1
AOJE T1,%POPJ ;If none to write, leave
;Determine how many pages we have written to the file
MOVE T3,EOFN(D) ;Get highest file byte
MOVE T1,BPW(D) ;Get bytes/word
LSH T1,LWSIZ ;Get bytes/page
ADDI T3,-1(T1) ;and pages written
IDIVI T3,(T1) ;rounded
;and the number of pages we have to write
HRRZ T1,IPTR(D) ;Get current point
SUB T1,WADR(D) ;Get total window words used-1
ADDI T1,1
ADDI T1,PSIZ-1 ;Convert to pages
IDIVI T1,PSIZ
MOVNM T1,WINPGS ;Save negative page count
;Now get the first file page "bucket" to set
SUBI T3,-1(T1) ;Bucket# = page#+1
MOVEM T3,T1 ;Copy
;Setup AOBJN pointer for -# pages to write,,first window page
HRLE T3,WINPGS ;Get neg count in left
HRR T3,WPTR(D) ;page # of bottom page in right
MOVE T4,RAB(D) ;Get RAB address
;Top of loop
RMSOUL: MOVEI T2,(T3) ;Get core addr
LSH T2,LWSIZ
$STORE T2,RBF,<(T4)> ;Store as buffer address
PUSHJ P,PUTBKT ;$WRITE it
$ACALL IOE ;Can't
;Bump bucket number
$FETCH T1,BKT,<(T4)> ;Increment file page to get
ADDI T1,1
AOBJN T3,RMSOUL ;Back for more
POPJ P,
SEGMENT DATA
WINPGS: BLOCK 1 ;Number of window pages to write
SEGMENT CODE
> ; End %IF20
SUBTTL %RMERR - Handle RMS service errors
;***************************************************************************
;* *
;* ENTRIES CALLED FROM FORERR *
;* *
;***************************************************************************
;++
; FUNCTIONAL DESCRIPTION:
;
; Called for RMS errors with $J in the error. Translates the STS
; status code into a string by searching a subset table of all
; RMS STS error codes/strings. If a match is found, the error
; message is constructed and pointed to by global %RMEPT. If
; no match is found, a string consisting of the STS and STV values
; alone is constructed. If the STS code indicates a $SNH (should
; not happen) internal FOROTS error, this routine never returns
; but converts the $DCALL/$ACALL error which called it into an
; OTS error ending at %HALT.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMERR
; <Return here>
;
; INPUT PARAMETERS:
;
; P2 - Error argument block pointer
;
; IMPLICIT INPUTS:
;
; STS(D) - RMS status code
; STV(D) - RMS status value
; STSTAB - Table of matchable error strings in the following
; format:
;
; [Address of error string],,<STS-ER$MIN>
;
; If the error is a $SNH, flag FL%SNH is set in the
; table entry, RH.
;
; %RMPDP - Address+1 of ERCAL call after the RMS $xxxx error
; (used for $SNHs only)
; %FSECT - FOROTS' section number
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ERRPTR - Error message pointer.
; DESPTR - Saved original pointer
; SAVPTR - Local save for STS string address
; %ERNM2 - Second error number (STS)
; %ERNM3 - Third error number (STV)
; INICHR - 1st error character (to @ for $SNH)
; %RMEPT - Pntr to RMS error message text
;
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2,T4.
;
;--
;[5007] New
%IF20,<
FL%SNH==400000 ;Table $SNH flag
%RMERR: LOAD T1,STV(D) ;Get and save 3rd error number:STV
MOVEM T1,%ERNM3
LOAD T1,STS(D) ;Get and save 2nd error number:STS
MOVEM T1,%ERNM2
SUBI T1,ER$MIN ;Strip error offset
MOVEM T1,T3 ;STS to match in AC3
MOVE T1,[POINT 7,TXTBF2] ;Destination for error string
EXCH T1,ERRPTR
MOVEM T1,DESPTR ;Save original error pntr
MOVEI T1,5*LERRBF-1 ;Set count
MOVEM T1,ERRCNT
SETZ T2,
RMERSL: SETZ T4, ;Clear local $SNH flag
MOVE T1,STSTAB(T2) ;Get table entry
JUMPE T1,NOSTS ;End of table with no match
HRRZ T1,T1 ;Get STS code alone
TXZE T1,FL%SNH ;$SNH error?
SETOM T4 ;Yes, flag it
CAIE T1,(T3) ;Same as our target STS?
AOJA T2,RMERSL ;No, keep looking
;Here with an STS-matched string from the table. If not a $SNH error
; also, return this string.
HLRZ T1,STSTAB(T2) ;Yes, get string address
MOVEM T1,SAVPTR ;Save
JUMPE T4,RTSTR ;If not also a $SNH, go return it
;Here with a $SNH-flagged error. If caused by a USEROPEN routine, it's not
; really a $SNH.
MOVE T1,%FLGS(P2) ;Get error flags
TXNE T1,I%UOF ;USEROPEN error?
JRST RTSTR ;Yes, not *our* $SNH
;Here with a $SNH. Modify the error string we will return.
MOVEI T1,[ASCIZ /Internal FOROTS error at /] ;source
PUSHJ P,ASCTYP ;Move string to buffer
MOVE T1,%RMPDP ;Get PDP of error.
SUBI T1,1 ;Get addr of call
SKIPN %FSECT ;Non-zero section?
MOVEI T1,(T1) ;No. Exclude flags
PUSHJ P,OCTTYP ;Type it in octal
SETZM %RMPDP ;Clear $SNH PDP
MOVEI T1,[ASCIZ /, /]
PUSHJ P,ASCTYP
RTSTR: MOVE T1,SAVPTR ;Get STS string address
PUSHJ P,ASCTYP ;Ouput it
MOVEI T1,[ASCIZ /, /]
PUSHJ P,ASCTYP
NOSTS: MOVEI T1,[ASCIZ /STS:/] ;Output STS code
PUSHJ P,ASCTYP
LOAD T1,STS(D)
PUSHJ P,OCTTYP
MOVEI T1,[ASCIZ /, STV:/] ;And STV
PUSHJ P,ASCTYP
LOAD T1,STV(D)
PUSHJ P,OCTTYP
SETZ T1,
IDPB T1,ERRPTR
MOVE T1,DESPTR ;Restore original error pntr
MOVEM T1,ERRPTR
MOVEI T1,TXTBF2 ;Save pntr to message for $J code
MOVEM T1,%RMEPT ;Save error address
SKIPE %RMPDP ;$SNH?
POPJ P, ;No, done
;Here for $SNH errors, which never return to DIALOG or take an ERR=.
MOVE P2,%ERPTR ;Point to error block
PUSHJ P,EMSGT0 ;Get error message text
MOVEI T1,"@" ;Convert 1st character to SNH
MOVEM T1,INICHR
PJRST FOREC2 ;Go output and die
> ; End %IF20
SUBTTL %RMECL - Cleanup after an RMS error
;++
; FUNCTIONAL DESCRIPTION:
;
; If the error was ER$RTN (RENAME to two different nodes), the user
; tried to:
;
; a) Rename a local OPEN filespec to a remote CLOSE filespec.
; b) Rename a remote file to another node.
;
; In these cases the "remoteness" of the file [NODNAM(D), USERID(D)
; PASWRD(D)] is zeroed, since in re-entering DIALOG after such an
; error there is no way for the user to remove a file's "nodeness".
; This is done now, rather than at the point of error, since FORERR
; must have the node information available to output as part of the
; error text.
;
; In all cases of an RMS error, STS(D) and STV(D) are zeroed here,
; so that a subsequent DIALOG entry which itself gets an error
; (quite possibly unrelated to any RMS file) does not re-call the
; RMS error handler.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMECL
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; STS(D) - RMS completion status code
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; STS(D) - Zeroed
; STV(D) - Zeroed
;
; The following are cleared on ER$RTN
;
; NODNAM(D) - Node name
; PASWRD(D) - Password
; USERID(D) - User ID
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5007] New
%IF20,<
%RMECL: LOAD T1,STS(D) ;Get STS
CAIE T1,ER$RTN ;Two different nodes error?
JRST ZERSV ;No
SETZM NODNAM(D) ;Yes, forget about file's remoteness
SETZM JFNBLK+.GJNOD ; in the JFN block
SETZM PASWRD(D) ; and the DDB
SETZM USERID(D)
SETZM JFNBLK+.GJATR
ZERSV: SETZ T1, ;Clear both STS and STV
STORE T1,STS(D)
STORE T1,STV(D)
POPJ P,
> ;End %IF20
SUBTTL STS Error Table
%IF20,<
DEFINE USER (STS,STRING) < ;;For RMS errors
.COD.==<STS-ER$MIN>
XWD [ASCIZ @STRING@],.COD.
PURGE .COD.,STS
> ;End USER
DEFINE SNH (STS,STRING) < ;;RMS which $SNH
.COD.==<STS-ER$MIN>+FL%SNH
XWD [ASCIZ @STRING@],.COD.
PURGE .COD.,STS
> ;End SNH
DEFINE IGNORE (STS,STRING) < ;;For ignored RMS error strings
REPEAT 0,<
USER (STS,STRING)
> ;End REPEAT 0
> ;End IGNORE
STSTAB:
IGNORE ER$AID,<Bad AID value>
IGNORE ER$ALQ,<Allocation quantity incorrect>
IGNORE ER$ANI,<Not ANSI 'D' format>
IGNORE ER$BKS,<Bad bucket size>
IGNORE ER$BKZ,<'BKZ' field invalid in XAB>
SNH ER$BLN,<Bad block length>
SNH ER$BSZ,<Bad byte size>
USER ER$BUG,<Internal bug found in RMS-20>
USER ER$CCF,<Cannot $CLOSE file>
USER ER$CCR,<Cannot $CONNECT RAB>
USER ER$CDR,<Cannot $DISCONNECT RAB>
USER ER$CEF,<Cannot $ERASE file>
USER ER$CGJ,<Cannot get JFN for file>
USER ER$CHG,<Key value cannot change>
SNH ER$COD,<Bad COD value in XAB>
USER ER$COF,<Cannot open file>
USER ER$CUR,<No current record>
IGNORE ER$DAN,<Bad data-area number>
USER ER$DEL,<Record has been deleted>
USER ER$DEV,<Illegal device>
IGNORE ER$DFL,<Bad data-fill percentage value>
USER ER$DLK,<Deadlock condition detected>
USER ER$DME,<Dynamic memory exhausted>
SNH ER$DTP,<Bad data-type in XAB>
USER ER$DUP,<Duplicate key exists>
IGNORE ER$EDQ,<Unexpected ENQUE/DEQUE error>
USER ER$EOF,<End of file>
SNH ER$FAB,<Block is not a valid FAB>
SNH ER$FAC,<Bad file access value>
USER ER$FEX,<File already exists>
SNH ER$FLG,<Bad XAB flag combination>
USER ER$FLK,<File already locked by someone else>
SNH ER$FNA,<Bad FNA value>
IGNORE ER$FNC,<File not closed>
USER ER$FNF,<File not found>
SNH ER$FOP,<Bad file options>
IGNORE ER$FSZ,<Invalid header size for VFC-file>
IGNORE ER$FUL,<File full>
IGNORE ER$IAL,<Invalid argument list>
IGNORE ER$IAN,<Bad index-area number>
SNH ER$IBC,<Illegal block mode connection>
SNH ER$IBO,<Illegal block mode operation>
SNH ER$IBS,<Illegal block mode sharing>
SNH ER$IFI,<Bad IFI value>
IGNORE ER$IFL,<Bad index fill percentage>
IGNORE ER$IMX,<Illegal multiple XABs>
SNH ER$IOP,<Invalid operation attempted>
IGNORE ER$IRC,<Illegal record encountered>
SNH ER$ISI,<Bad ISI value>
SNH ER$JFN,<Bad JFN value>
USER ER$KBF,<Bad KBF value>
USER ER$KEY,<Bad record key>
USER ER$KRF,<Bad key of reference value>
USER ER$KSZ,<Bad key size>
IGNORE ER$LSN,<Bad line-sequence number>
USER ER$MRN,<Bad MRN value>
USER ER$MRS,<Bad MRS value>
USER ER$NEF,<Not positioned at EOF>
IGNORE ER$NLG,<Log file not active>
USER ER$NPK,<Indexed file - no primary key defined>
SNH ER$NXT,<Invalid 'NXT' field in a XAB>
SNH ER$ORD,<XABs are not in correct order>
SNH ER$ORG,<Bad file organization value>
USER ER$PEF,<Cannot position to end-of-file>
IGNORE ER$PLG,<Error detected in file's prologue>
SNH ER$POS,<Bad key position value>
USER ER$PRV,<Privilege violation>
IGNORE ER$QPE,<Quiet point enabled>
SNH ER$RAB,<Block is not a valid RAB>
SNH ER$RAC,<Bad record access value>
SNH ER$RAT,<Bad record attributes>
SNH ER$RBF,<Invalid record buffer address>
USER ER$REF,<Bad key reference (REF) value>
IGNORE ER$RER,<File processor read error>
USER ER$REX,<Record already exists>
SNH ER$RFA,<Bad RFA value>
IGNORE ER$RFM,<Bad record format>
USER ER$RLK,<Record already locked by someone else>
USER ER$RNF,<Record not found>
IGNORE ER$RNL,<Record not locked>
SNH ER$ROP,<Bad record options>
IGNORE ER$RRV,<Invalid RRV record found>
IGNORE ER$RSA,<Record stream active>
IGNORE ER$RSD,<Record size discrepancy>
USER ER$RSZ,<Bad record size value>
SNH ER$RTB,<Record too big>
IGNORE ER$SEQ,<Key value not in sequential order>
USER ER$SIZ,<'SIZ' field in XAB invalid>
IGNORE ER$TRE,<Index tree error detected>
USER ER$TRU,<Cannot truncate this file>
SNH ER$UBF,<Bad buffer address>
IGNORE ER$UDF,<File is in undefined state>
IGNORE ER$VER,<Error in version number>
IGNORE ER$WER,<File processor write error>
SNH ER$XAB,<Not a valid XAB>
USER ER$XCL,<File must be open in exclusive access>
USER ER$FSI,<File spec has invalid format>
USER ER$DPE,<DAP protocol error>
USER ER$SUP,<Unsupported operation>
USER ER$DCF,<DAP connection failure>
USER ER$EXT,<File extend error>
SNH ER$NAM,<Invalid NAM block>
IGNORE ER$NMF,<No more files>
USER ER$RTD,<RENAME -- two different devices>
USER ER$RTN,<RENAME -- two different nodes>
USER ER$DCB,<DECNET connection broken>
USER ER$IAC,<Invalid access information>
SNH ER$TYP,<Invalid TYP block>
IGNORE ER$CLA,<Invalid file data class>
Z ;END OF TABLE
PURGE FL%SNH
> ; End %IF20
SUBTTL FNDRMS - See if RMS is around
;***************************************************************************
;* *
;* MISCELLANEOUS ROUTINES *
;* *
;***************************************************************************
;++
; FUNCTIONAL DESCRIPTION:
;
; Does a GTJFN% on SYS:RTL.EXE and XRMS.EXE to see if they are around
; for dynamic-library invocation. If so, just return (or if we
; have already been called). If not, go to DIALOG.
;
; Called from FOROPN DFDEV1 after the device index is established
; as either DI.RMS or DI.RSF.
;
; CALLING SEQUENCE:
;
; PUSHJ P,FNDRMS
; <Error return; enter DIALOG>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RMSJFN - If non-zero on entry, we've already been called
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; RMSJFN - Holds a released JFN
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[5000] New
IF20,<
FNDRMS: SKIPE RMSJFN ;Already done this before?
JRST %POPJ1 ;Yes, just return
MOVX T1,GJ%SHT+GJ%OLD+GJ%PHY ;No, check for the RTL
HRROI T2,[ASCIZ /SYS:RTL.EXE/]
GTJFN%
ERJMP NORMS ;Go fail
RLJFN% ;Release JFN
ERJMP .+1
MOVX T1,GJ%SHT+GJ%OLD+GJ%PHY ;Check for XRMS.EXE
HRROI T2,[ASCIZ /SYS:XRMS.EXE/]
GTJFN%
ERJMP NORMS ;Go fail
MOVEM T1,RMSJFN ;Save JFN as flag
RLJFN%
ERJMP .+1
MOVEI T1,FTEXT ;Get global compilation switch
JUMPN T1,%POPJ1
;RMS is on SYS: but FOROTS was compiled on a non-extended machine.
HRROI T1,[ASCIZ/
?RMS can only be called on a processor which supports extended addressing.
This build of FOROTS was compiled on a non-extended machine./]
PSOUT%
SETZM RMSJFN
HALTF%
JRST .-1
;Here when XRMS.EXE/RTL.EXE are not on SYS:. Issue error, enter DIALOG.
NORMS: $DCALL RNA
SEGMENT DATA
RMSJFN: BLOCK 1
SEGMENT CODE
> ;End IF20
SUBTTL RMFAB - Allocate FAB/CONFIG blocks
;++
; FUNCTIONAL DESCRIPTION:
;
; Allocates and initializes a FAB block and returns its address
; in T1. If the file is remote (i.e. a nodename was included in
; the filespec), allocate a CONFIG XAB as well and point FAB FB$XAB
; at it. Allocates via a call to global routine %GTBLK.
;
; FAB format:
;
; !=====================================!
; ! BID ! BLN !
; !-------------------------------------!
; ! STS ! STV !
; !-------------------------------------!
; ! CTX !
; !-------------------------------------!
; ! IFI ! JFN !
; !-------------------------------------!
; ! FAC ! SHR !
; !-------------------------------------!
; ! FOP !ORG! BSZ ! BLS !
; !-------------------------------------!
; ! FNA !
; !-------------------------------------!
; ! RAT ! MRS !
; !-------------------------------------!
; ! MRN !
; !-------------------------------------!
; ! <UNUSED> ! BKS ! RFM !
; !-------------------------------------!
; ! LOG ! XAB !
; !-------------------------------------!
; ! DEV ! SDC !
; !-------------------------------------!
; ! <UNUSED> !
; !-------------------------------------!
; ! <UNUSED> !
; !-------------------------------------!
; ! <UNUSED> !
; !-------------------------------------!
; ! <UNUSED> !
; !=====================================!
;
; Local non-indexed RMS files will be allocated a FAB only,
; whose XAB field will be zero. Local indexed RMS files will have
; a FAB whose XAB field points to the first key XAB of any chain.
;
; Remote non-indexed files (including RSF) will be chained as
; follows to a CONFIG XAB:
;
; --------------------
; FAB: | |
; -------.....---------
; F$XAB:|address of CONFIG |
; --------------------
;
; --------------------
; CONFIG: | |
; -------.....--------
; X$NXT:| 0 |
; --------------------
;
; Remote indexed files' X$NXT in their CONFIG XABs will point
; to the start of the key XAB chain, if any.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RMFAB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; NODNAM(D) - Nodename string from OPEN
;
; OUTPUT PARAMETERS:
;
; T1 - Address of allocated FAB
;
; IMPLICIT OUTPUTS:
;
; FABLNK - Link address
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
RMFAB: SKIPN T2,NODNAM(D) ;Nodename specified?
JRST ALFAB ;No, allocate FAB only
MOVX T1,XA$SXC ;Yes. Get length of CONFIG XAB
PUSHJ P,%GTBLK ;Get a block
$ACALL MFU ;Can't
MOVE T2,T1 ;T1 off'd by XAB$B
XAB$B CFG,<(T2)> ;Declare it
XAB$E ;End declaration
ALFAB: MOVEM T2,FABLNK ;Save link address (or zero)
MOVX T1,FA$LNG ;Get FAB length block
PUSHJ P,%GTBLK
$ACALL MFU ;Can't
MOVE T2,T1 ;T1 off'd by FAB$B
FAB$B <(T2)> ;Declare it
FAB$E ;End declaration
MOVE T1,FABLNK ;Restore link address
$STORE T1,XAB,<(T2)>
MOVE T1,T2 ;Return address of FAB
POPJ P, ;Return
> ; End %IF20
SUBTTL RMRAB - Allocate a RAB
;++
; FUNCTIONAL DESCRIPTION:
;
; Allocates a RAB and returns its address in T1. Allocates via a call
; to global routine %GTBLK.
;
; RAB format:
;
; !-------------------------------------!
; ! BID ! BLN !
; !-------------------------------------!
; ! STS ! STV !
; !-------------------------------------!
; ! CTX !
; !-------------------------------------!
; ! ISI ! FAB !
; !-------------------------------------!
; ! RAC ! MBF ! ROP !
; !-------------------------------------!
; ! UBF !
; !-------------------------------------!
; ! RBF !
; !-------------------------------------!
; ! RSZ ! USZ !
; !-------------------------------------!
; ! RFA !
; !-------------------------------------!
; ! KRF ! KSZ ! LSN !
; !-------------------------------------!
; ! KBF !
; !-------------------------------------!
; ! BKT !
; !-------------------------------------!
; ! PAD ! <UNUSED> !
; !-------------------------------------!
; ! <UNUSED> !
; !-------------------------------------!
; ! <UNUSED> !
; !-------------------------------------!
; ! <UNUSED> !
; !-------------------------------------!
;
;
; CALLING SEQUENCE:
;
; PUSHJ P,RMRAB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; T1 - Address of allocated RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
RMRAB: MOVX T1,RA$LNG ;Get RAB length
PUSHJ P,%GTBLK ;Get it
$ACALL MFU ;Can't
MOVE T2,T1 ;T1 off'd by RAB$B
RAB$B <(T2)> ;Declare it
RAB$E ;End declaration
MOVE T1,T2 ;Return address in T1
POPJ P, ;Return
> ; End %IF20
SUBTTL RMXAB - Allocate a KEY XAB
;++
; FUNCTIONAL DESCRIPTION:
;
; Allocates a key XAB and returns its address in T1. Allocates via
; a call to global routine %GTBLK.
;
; Key XAB format:
;
; !=====================================!
; ! BID ! BLN !
; !-------------------------------------!
; ! <UNUSED> ! COD ! NXT !
; !-------------------------------------!
; ! <UNUSED> ! DTP ! FLG !
; !-------------------------------------!
; ! IAN ! DAN ! LAN ! REF !
; !-------------------------------------!
; ! IFL ! DFL !
; !-------------------------------------!
; ! KNM !
; !-------------------------------------!
; ! <RESERVED> !
; !-------------------------------------!
; ! <RESERVED> !
; !-------------------------------------!
; ! <UNUSED> !
; !-------------------------------------!
; ! <UNUSED> !
; !-------------------------------------!
; ! <UNUSED> !
; !-------------------------------------!
; ! POS0 ! SIZ0 !
; !-------------------------------------!
; ! POS1 ! SIZ1 !
; !-------------------------------------!
; ! POS2 ! SIZ2 !
; !-------------------------------------!
; ! POS3 ! SIZ3 !
; !-------------------------------------!
; ! POS4 ! SIZ4 !
; !-------------------------------------!
; ! POS5 ! SIZ5 !
; !-------------------------------------!
; ! POS6 ! SIZ6 !
; !-------------------------------------!
; ! POS7 ! SIZ7 !
; !=====================================!
;
;
; CALLING SEQUENCE:
;
; PUSHJ P,RMXAB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; T1 - Address of allocated XAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
RMXAB: MOVX T1,XA$SXK ;Length of key XAB
PUSHJ P,%GTBLK ;Ask for it
$ACALL MFU ;Can't get it
MOVE T2,T1 ;T1 off'd by XAB$B
XAB$B KEY,<(T2)> ;Declare a KEY XAB
XAB$E
MOVE T1,T2 ;Return address in T1
POPJ P, ;Return
> ;End %IF20
SUBTTL %RMDAB - Deallocate FAB, RAB, XAB(s), cache
;++
; FUNCTIONAL DESCRIPTION:
;
; Deallocates FAB(D), RAB(D) and any XAB(D) chain. Deallocates via
; calls to global routine %FREBLK. If CACHE(D) is non-zero,
; deallocates the cache.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMDAB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
; RAB(D) - Address of RAB
; XAB(D) - Address of start of XAB chain
; CACHE(D) - Address of cache
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; Zeros FAB, RAB and XAB(D); CACHE(D), CACHPT(D)
; FABLNK - Link address
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
IF10,< ;No-op on TOPS10
%RMDAB: POPJ P,
> ;End IF10
%IF20,<
%RMDAB: SKIPE %ABFLG ;Are we aborting?
POPJ P, ;Yes, don't deallocate anything
MOVE T1,XAB(D) ;Get Key XAB start if any
MOVEM T1,FABLNK ;Save
SKIPN FAB(D) ;Any FAB?
JRST DXAB ;No, check XAB
MOVE T1,FAB(D) ;Get FAB address
$FETCH T2,XAB,<(T1)> ;Get XAB link from FAB
MOVEM T2,FABLNK ;Save it (maybe CFG start)
PUSHJ P,%FREBLK ;Deallocate the FAB
SETZM FAB(D) ;Clear DDB
DXAB: SKIPN T1,FABLNK ;Was there a XAB link?
JRST DRAB ;No, go check RAB
PUSHJ P,RMDXB ;Deallocate the chain
SETZM XAB(D) ;Clear DDB
DRAB: SKIPN T1,RAB(D) ;Any RAB?
JRST DCACH ;No, check cache
PUSHJ P,%FREBLK ;Yes. Get rid of it
SETZM RAB(D) ;Clear DDB
DCACH: SKIPN T1,CACHE(D) ;Any cache setup?
JRST DABEND ;No, clear buffer pointer
PUSHJ P,%FREBLK ;Yes, it's gone
SETZM CACHE(D) ; with all its pointers
SETZM CACHPT(D)
DABEND: SETZM BUFADR(D) ;Clear any buffer pointer
POPJ P,
> ; End %IF20
SUBTTL %RMDKB - Deallocate DIALOG /KEY arglist
;++
; FUNCTIONAL DESCRIPTION:
;
; Deallocates a secondary arglist created by parsing /KEY in DIALOG.
; Deallocates via a call to global routine %FREBLK.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%RMDKB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; D.KEY - Address of secondary arglist. Its count word is in
; address-1
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; D.KEY - Address of secondary arglist is zeroed
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5000] New
IF10,<
%RMDKB: POPJ P, ;No-op on TOPS10
> ;End IF10
%IF20,<
%RMDKB: SKIPN T1,D.KEY ;Anything to deallocate?
POPJ P, ;No, just return
SUBI T1,1 ;Get count word address
PUSHJ P,%FREBLK ;Deallocate the arglist
SETZM D.KEY ;It's gone
POPJ P, ;Return
> ; End %IF20
SUBTTL RMDXB - Deallocate a XAB chain
;++
; FUNCTIONAL DESCRIPTION:
;
; Deallocates a XAB chain the first link of which is pointed to by
; T1. Deallocates via calls to global routine %FREBLK.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RMDXB
; <Return here>
;
; INPUT PARAMETERS:
;
; T1 - Address of first XAB to deallocate
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
RMDXB: JUMPE T1,%POPJ ;Zero NXT terminates loop
$FETCH T2,NXT,<(T1)> ;Get this XAB's NXT field
PUSH P,T2 ;Save
PUSHJ P,%FREBLK ;Deallocate this XAB
POP P,T1 ;Make next XAB the current one
JRST RMDXB ; and continue
SEGMENT DATA
PXBADR: BLOCK 1 ;Address of previous XAB
FABLNK: BLOCK 1 ;FAB XAB link
SEGMENT CODE
> ; End %IF20
SUBTTL RMDUXB - Deallocate and unlink a XAB chain
;++
; FUNCTIONAL DESCRIPTION:
;
; Deallocates the XAB chain the first link of which is pointed
; to by XAB(D). Then clears the link from FAB(D) F$XAB if there is
; no CONFIG XAB, or from CONFIG F$NXT if there is one. Clears
; XAB(D) on return. Calls RMDXB to deallocate, ULKXAB to unlink.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RMDUXB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; XAB(D) - Address of key XAB chain start
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; XAB(D) - Zeroed
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1.
;
;--
;[5000] New
%IF20,<
RMDUXB: SKIPN T1,XAB(D) ;Any chain to worry about?
POPJ P, ;No, just return
PUSHJ P,RMDXB ;Yes, deallocate it
PJRST ULKXAB ;Unlink and return
> ; End %IF20
SUBTTL ULKXAB - Unlink FAB or CONFIG from XAB chain
;++
; FUNCTIONAL DESCRIPTION:
;
; Unlinks a key XAB chain from either F$XAB of FAB(D) or F$NXT
; of the CONFIG XAB, if there is one.
;
; CALLING SEQUENCE:
;
; PUSHJ P,ULKXAB
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
; XAB(D) - Address of 1st key XAB
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; FAB(D) F$XAB - Zeroed if no CONFIG XAB
; CONFIG F$NXT - Zeroed if a CONFIG exists
; XAB(D) - Zeroed
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
ULKXAB: SKIPN XAB(D) ;Any XAB chain
POPJ P, ;No, nothing to do
MOVE T1,FAB(D) ;Get FAB address
$FETCH T2,XAB,<(T1)> ;Get its link address
JUMPE T2,%POPJ ;None, just return
CAME T2,XAB(D) ;FAB point to key chain start?
JRST ULKCFG ;No, there's a CONFIG XAB
SETZ T2, ;Yes, clear FAB F$XAB
$STORE T2,XAB,<(T1)>
JRST ZERXAB ;and go clear XAB(D)
ULKCFG: SETZ T1, ;Clear CONFIG's F$NXT
$STORE T1,NXT,<(T2)>
ZERXAB: SETZM XAB(D)
POPJ P,
> ; End %IF20
SUBTTL FABSTV - Update STV(D) and STS(D) from FAB/RAB
;++
; FUNCTIONAL DESCRIPTION:
;
; Called after every RMS service call to update the status return
; values from FAB(D). RMS service calls which update the RAB's
; STV should call RABSTV.
;
; Entry FABST2 is used when the caller passes the address of a
; different FAB in T1 (e.g. a scratch FAB).
;
; CALLING SEQUENCE:
;
; PUSHJ P,FABSTV
; <Return here>
;
; INPUT PARAMETERS:
;
; T1 - Address of FAB (entry FABST2 only)
;
; IMPLICIT INPUTS:
;
; FAB(D) STV - STV value returned to FAB/RAB
; FAB(D) STS - STS value returned to FAB/RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS value
;
; IMPLICIT OUTPUTS:
;
; STV(D) - STV from FAB/RAB
; STS(D) - STS from FAB/RAB
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
FABSTV: SKIPA T1,FAB(D) ;Get FAB address
RABSTV: MOVE T1,RAB(D) ;or RAB
FABST2: $FETCH T2,STV,<(T1)> ;Get STV value
STORE T2,STV(D) ;Save
$FETCH T2,STS,<(T1)> ;Get STS value
STORE T2,STS(D) ;Save
CAIGE T2,SU$SUC ;Real error or real success?
$SNH ;No, real bad
POPJ P, ;Yes, return STS
> ; End %IF20
SUBTTL RLSLNK - Release a logical link
;++
; FUNCTIONAL DESCRIPTION:
;
; Does a $CLOSE to release any logical link allocated to the FAB.
; $CLOSE errors are ignored. Called only for fatal OPEN errors.
;
; Entry RLSLNX $CLOSEs the SCRFAB.
;
; CALLING SEQUENCE:
;
; PUSHJ P,RLSLNK
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
; Closes the file if open on the FAB.
;
;--
;[5000] New
%IF20,<
RLSLNX: SKIPA T1,[SCRFAB] ;Get scratch FAB address
RLSLNK: MOVE T1,FAB(D) ;Get FAB address
$CLOSE <(T1)> ;Yes. Release link, ignore errors.
POPJ P,
> ; End %IF20
SUBTTL CVTFNS - Convert NAMBLK filespec to TOPS20
;++
; FUNCTIONAL DESCRIPTION:
;
; Using the expanded filespec string pointed to by RSA of the
; NAMBLK, copies and converts the string to the destination pointed
; to by T1. Conversion affects only the nodename field, which is
; translated from:
;
; node"userid password account"::
;
; to:
;
; node::
;
; If CVFLAG is non-zero, each byte in the directory field (except
; for open/close delimiters) is ^V-quoted in the copy.
;
; The opening delimiter of the generation field is always returned
; as a "."
;
; CALLING SEQUENCE:
;
; PUSHJ P,CVTFNS
; <Return here>
;
; INPUT PARAMETERS:
;
; T1 - Byte pointer to destination where converted string
; is to be written
;
; IMPLICIT INPUTS:
;
; NAMBLK - NAM block pointers
; CVFLAG - Non-zero if ^V'ing is to be performed on the
; directory field.
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; CVFLAG - Cleared
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
;
;--
;[5000] New
%IF20,<
CVTFNS: PUSHJ P,MOVNOD ;Copy/convert node
$FETCH T2,DVA,NAMBLK ;Get Device pntr
$FETCH T3,DVL,NAMBLK ;and length
PUSHJ P,MOVSTR
$FETCH T2,DRA,NAMBLK ;Directory
$FETCH T3,DRL,NAMBLK
MOVEI T4,MOVSTR ;Assume no ^V'ing
SKIPE CVFLAG ;^V this field?
MOVEI T4,CTVDIR ;Yes, use different routine
PUSHJ P,(T4)
$FETCH T2,NMA,NAMBLK ;Name
$FETCH T3,NML,NAMBLK
PUSHJ P,MOVSTR
$FETCH T2,TPA,NAMBLK ;Extention
$FETCH T3,TPL,NAMBLK
PUSHJ P,MOVSTR
$FETCH T2,VRA,NAMBLK ;Generation
$FETCH T3,VRL,NAMBLK
ILDB T4,T2 ;Make sure delimiter is TOPS20
SUBI T3,1 ;Correct the count
MOVEI T4,"."
IDPB T4,T1
PUSHJ P,MOVSTR
SETZ T4,
IDPB T4,T1 ;End with null
SETZM CVFLAG ;Clear ^V flag
POPJ P, ;Return
SEGMENT DATA
CVFLAG: BLOCK 1 ;-1 if ^V'ing is being done
SEGMENT CODE
> ; End %IF20
SUBTTL MOVNOD - Move a node name from the NAM block
;++
; FUNCTIONAL DESCRIPTION:
;
; Moves a nodename of NAM block form (node"userid password account"::)
; to the destination in the form "node::".
;
; CALLING SEQUENCE:
;
; PUSHJ P,MOVNOD
; <Return here>
;
; INPUT PARAMETERS:
;
; T1 - Destination byte pointer
;
; IMPLICIT INPUTS:
;
; NAMBLK - NAM block field pointers
; NDA/NDL - Nodename character descriptor
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
;
;--
;[5000] New
%IF20,<
MOVNOD: $FETCH T2,NDA,NAMBLK ;Get pointer to node string
$FETCH T3,NDL,NAMBLK ;Get total length
NODLP: JUMPE T3,%POPJ ;Count exhausted
ILDB T4,T2 ;Get a byte
CAIE T4,"""" ;Look for quotes
CAIN T4,":" ; or colon delimiter
JRST GOTNOD ;Got it
IDPB T4,T1 ;Store character
SOJA T3,NODLP ;Keep going
GOTNOD: MOVEI T3,":" ;"node::"
IDPB T3,T1
IDPB T3,T1
POPJ P, ;Return
> ; End %IF20
SUBTTL CTVDIR - Control-V a directory field
;++
; FUNCTIONAL DESCRIPTION:
;
; Copies the NAM block directory field to the destination, preceding
; each directory field character with a ^V.
;
; CALLING SEQUENCE:
;
; PUSHJ P,CTVDIR
; <Return here>
;
; INPUT PARAMETERS:
;
; T1 - Destination byte pointer
; T2 - Source pointer
; T3 - Field length in bytes
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T0-T4.
;
;--
;[5000] New
%IF20,<
CTVDIR: JUMPE T3,%POPJ ;No length
SUBI T3,2 ;Subtract open/close widgets
JUMPLE T3,%POPJ ;Bad length! Just ignore
ILDB T4,T2 ;Get opening delimiter
IDPB T4,T1 ;Store without ^V
MOVEI T0,"" ;Get a Control-V
CDIRLP: ILDB T4,T2 ;Get source byte
IDPB T0,T1 ;^V this byte
IDPB T4,T1 ;Write the byte
SOJG T3,CDIRLP ;Loop for count
ILDB T4,T2 ;Get closing delimiter
IDPB T4,T1 ;Store without ^V
POPJ P, ;Return
> ; End %IF20
SUBTTL ABINI - Initialize some srgument blocks
;++
; FUNCTIONAL DESCRIPTION:
;
; Initializes the NAM block, a scratch FAB, and a TYP block.
; All are cleared before initialization.
;
; CALLING SEQUENCE:
;
; PUSHJ P,ABINI
; <Return here>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; NAMBLK RSA - Set to address of RSA buffer
; NAMBLK RSS - Set to length of RSA buffer
; NAMBLK ESA - Set to address of ESA buffer
; NAMBLK ESS - Set to length of ESA buffer
;
; TYPBLK CLA - Set to type IMAGE.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
ABINI: NAM$Z NAMBLK ;Clear NAM block
NAM$B NAMBLK ;Reinit
NAM$E
XMOVEI T1,NAMBLK
MOVE T2,[POINT 7,RSABUF] ;Setup RSA pointer in NAM
$STORE T2,RSA,<(T1)>
MOVEI T2,RSALC ;Byte-length
$STORE T2,RSS,<(T1)>
MOVE T2,[POINT 7,ESABUF] ;Setup ESA pointer
$STORE T2,ESA,<(T1)>
MOVEI T2,ESALC
$STORE T2,ESS,<(T1)>
FAB$Z SCRFAB ;Re-init the SCRFAB
FAB$B SCRFAB
FAB$E
TYP$Z TYPBLK ;Re-init the TYP block
TYP$B TYPBLK
T$CLA TY$IMA ;Class is image, image is class
TYP$E
POPJ P,
> ; End %IF20
SUBTTL MOVSTR - Move string
;++
; FUNCTIONAL DESCRIPTION:
;
; Moves an ASCII string from source to destination. Returns on
; a null byte or when the count is exhausted, whichever occurs
; first.
;
; CALLING SEQUENCE:
;
; PUSHJ P,MOVSTR
; <Return here>
;
; INPUT PARAMETERS:
;
; T1 - Destination byte pointer
; T2 - Source byte pointer
; T3 - Number of bytes to transfer
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1-T4.
;
;--
;[5000] New
%IF20,<
MOVSTR: JUMPLE T3,%POPJ ;Return on count exhausted
ILDB T4,T2 ;Get a source byte
JUMPE T4,%POPJ ;Quit on null
IDPB T4,T1 ;Write to destination
SOJA T3,MOVSTR ;loop
> ; End %IF20
SUBTTL OPEN$ Do $OPEN
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $OPEN and updates FAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,OPEN$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $OPEN
; T4 - Address of FAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T0-T2,T4.
;
;--
;[5000] New
%IF20,<
OPEN$: $OPEN @FAB(D)
RMSFRT: PUSHJ P,FABSTV ;Update STS/STV
MOVE T0,(P) ;Get return address off stack
MOVEM T0,%RMPDP ;Save
MOVE T4,FAB(D) ;Return FAB address
CAIL T2,ER$MIN ;Error?
POPJ P, ;Yes, return +1
JRST %POPJ1
ERCRET: MOVE T0,(P) ;Get return address off stack
MOVEM T0,%RMPDP ;Save error return
$RETURN ;Return to after $call
RETSUC: MOVX T2,SU$SUC ;Clear the error
SETZ T3,
MAKSTS: $STORE T2,STS,<(T1)>
$STORE T3,STV,<(T1)>
PJRST FABST2
> ;End %IF20
SUBTTL CREA$ - Do $CREATE
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $CREATE and updates FAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,CREA$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $CREATE
; T4 - Address of FAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
CREA$: $CREATE @FAB(D)
JRST RMSFRT
> ;End %IF20
SUBTTL CLOS$ - Do $CLOSE
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $CLOSE and updates FAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,CLOS$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $CLOSE
; T4 - Address of FAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
CLOS$: $CLOSE @FAB(D)
JRST RMSFRT
> ;End %IF20
SUBTTL PARS$ - Do $PARSE
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $PARSE and updates FAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,PARS$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FAB(D) - Address of FAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $PARSE
; T4 - Address of FAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
PARS$: $PARSE @FAB(D)
JRST RMSFRT
> ;End %IF20
SUBTTL GET$ - Do $GET
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $GET and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,GET$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $GET
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T0-T2,T4.
;
;--
;[5000] New
%IF20,<
GET$: $GET @RAB(D)
RMSRRT: MOVE T0,(P) ;Get return address off stack
MOVEM T0,%RMPDP
PUSHJ P,RABSTV
MOVE T4,RAB(D) ;Return RAB address
CAIL T2,ER$MIN ;Error?
POPJ P, ;Yes
JRST %POPJ1
> ;End %IF20
SUBTTL CONN$ - Do $CONNECT
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $CONNECT and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,CONN$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $CONNECT
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
CONN$: $CONNECT @RAB(D)
JRST RMSRRT
> ;End %IF20
SUBTTL DISC$ - Do $DISCONNECT
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $DISCONNECT and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,DISC$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D)
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $DISCONNECT
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[5004] New
%IF20,<
DISC$: $DISCONNECT @RAB(D)
PJRST RMSRRT
> ;End %IF20
SUBTTL REWI$ - Do $DISCONNECT/$CONNECT
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $DISCONNECT/$CONNECT sequence to rewind a file to its
; starting position.
;
; CALLING SEQUENCE:
;
; PUSHJ P,REWI$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[5013] New
%IF20,<
REWI$: PUSHJ P,DISC$
POPJ P, ;Error
PUSHJ P,CONN$
POPJ P, ;Error
JRST %POPJ1 ;Success
> ;End %IF20
SUBTTL READ$ - Do $READ
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $READ and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,READ$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $READ
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
READ$: $READ @RAB(D)
JRST RMSRRT
> ;End %IF20
SUBTTL PUT$ - Do $PUT
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $PUT and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,PUT$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $PUT
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
PUT$: $PUT @RAB(D)
JRST RMSRRT
> ;End %IF20
SUBTTL WRIT$ - Do $WRITE
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $WRITE and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,WRIT$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $WRITE
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
WRIT$: $WRITE @RAB(D)
JRST RMSRRT
> ;End %IF20
SUBTTL TRUN$ - Do $TRUNCATE
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $TRUNCATE and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,TRUN$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $TRUNCATE
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
TRUN$: $TRUNCATE @RAB(D)
JRST RMSRRT
> ;End %IF20
SUBTTL FIND$ - Do $FIND
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $FIND and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,FIND$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $FIND
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
FIND$: $FIND @RAB(D)
JRST RMSRRT
> ;End %IF20
SUBTTL UPDA$ - Do $UPDATE
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $UPDATE and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,UPDA$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $UPDATE
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2.
;
;--
;[5000] New
%IF20,<
UPDA$: $UPDATE @RAB(D)
JRST RMSRRT
> ;End %IF20
SUBTTL DELE$ - Do $DELETE
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $DELETE and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,DELE$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $DELETE
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2
;
;--
;[5013] New
%IF20,<
DELE$: $DELETE @RAB(D)
JRST RMSRRT
> ;End %IF20
SUBTTL FREE$ - Do $FREE
;++
; FUNCTIONAL DESCRIPTION:
;
; Does $FREE and updates RAB's STS/STV
;
; CALLING SEQUENCE:
;
; PUSHJ P,FREE$
; <Error return>
; <Success return>
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; RAB(D) - Address of RAB
;
; OUTPUT PARAMETERS:
;
; T2 - STS code from $FREE
; T4 - Address of RAB
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Uses T1,T2
;
;--
;[5014] New
%IF20,<
FREE$: $FREE @RAB(D)
JRST RMSRRT
> ;End %IF20
;***************************************************************************
;* *
;* STATIC RMS ARGUMENT BLOCKS *
;* *
;***************************************************************************
;Scratch FAB for LOOKUPs:
IF20,<
IFNRMS,<ER$MIN==300000>
%ERMIN: ER$MIN ;RMS error base
> ;End IF20
%IF20,<
SEGMENT DATA
SCRFAB: BLOCK FA$LNG
NAMBLK: BLOCK NA$LNG
TYPBLK: BLOCK TY$LNG
RSALW==LTEXTW ;RSA length is %TXTBF's length
RSALC==LTEXTC ;and in characters
ESALC==RSALC ;ESA ditto
RSABUF: BLOCK LTEXTW ;RSA buffer
ESABUF: BLOCK LTEXTW ;ESA buffer
EXFATT: BLOCK 1 ;Pointer to attributes portion
EXFBUF: BLOCK LTEXTW ;Resultant string saved here
SEGMENT CODE
;PURGE as many RMS-generated symbols as we can
DEFINE RMSPRG (PFX,FLDS) <
IF2,<
IRP PFX,<
IRP FLDS,< IFDEF PFX'$$'FLDS,<PURGE PFX'$$'FLDS>
IFDEF $$'PFX'FLDS,<PURGE $$'PFX'FLDS>
IFDEF C$$'FLDS,<PURGE C$$'FLDS>
> ;End IRP FLDS
> ;;End IRP PFX
PURGE FAB$B,FAB$E,RAB$B,RAB$E,XAB$B,XAB$E,NAM$B,NAM$E,TYP$B,TYP$E
PURGE T$$OF,T$$PS,T$$SZ,$$ADDR,$$NEWVAL,$$SET,$$CURR,$$MAPADD
PURGE SF$$CT,SF$$RT,SN$$CT,SN$$RT,SR$$RT,ST$$CT,STO$$C,SX$$CT
PURGE SX$$RT
> ;End IF2
> ;End RMSPRG
RMSPRG (<F,R,X,N,T>,<AID,ALQ,BID,BKS,BKT,BKZ,BLN,BLS,BSZ,CDT,
CHA,COD,CTX,DAN,DEV,DFL,DRA,DTP,DVA,DVL,EDT,EDT,ELS,
ESA,ESL,ESS,FAB,FAC,FLG,FNA,FNB,FOP,FSZ,IAN,IFI,IFL,
ISI,JFN,JNL,KBF,KNM,KRF,KSZ,LAN,LSN,MBF,MRN,MRS,NAM,
NDA,NDL,NMA,NML,NOA,NOK,NOP,NXT,ORG,PAD,PS0,PS1,PS2,
PS3,PS4,PS5,PS6,PS7,RAC,RAT,RBF,RDT,REF,RFA,RFM,RLF,
ROP,RS1,RS2,RS6,RS7,RS8,RS9,RSA,RSL,RSS,RSZ,RX0,RX1,
RX2,RX3,RX4,RX5,SDC,SHR,STS,STV,SZ0,SZ1,SZ2,SZ3,SZ4,
SZ5,SZ6,SZ7,TPA,TPL,TYP,UBF,USZ,VRA,VRL,WCC,XAB>)
> ;End %IF20
END