Trailing-Edge
-
PDP-10 Archives
-
BB-H138F-BM_1988
-
7-sources/rmsuin.b36
There are 6 other files named rmsuin.b36 in the archive. Click here to see a list.
%TITLE 'U T L I N T -- RMSUTL interface module'
!<BLF/REQUIRE 'RMSBLF.REQ'>
MODULE utlint ( ! RMSUTL interface module
IDENT = '2.0'
) =
BEGIN
GLOBAL BIND
utilv = 3^24 + 0^18 + 556; ! Edit date: 30-Jan-1985
!+
!
!
! FUNCTION: THIS MODULE CONTAINS ALL ROUTINES WHICH PROCESS
! THE $UTLINT MACRO IN RMS-10/20.
! THIS MACRO IS USED BY THE UTILITY RMSUTL
! TO PROVIDE AN INTERFACE TO SOME LOW-LEVEL
! FUNCTIONS IN RMS, WHICH RMSUTL COULD UTILIZE.
!
! NOTE: THIS MACRO IS FOR THE EXCLUSIVE USE
! OF RMSUTL.
!
! AUTHOR: A. UDDIN
!
!
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1979, 1986.
! 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 THAT IS NOT SUPPLIED BY DIGITAL.
!
!
!
! EDIT DESCRIPTION
!
! 556 RL - 30-Jan-85 Preserve registers 3,4,5 in FFFINT linkage
!
!-
LINKAGE ! $FFFINT linkage !A550
FFFINT_LNKG = PUSHJ (REGISTER = 1) : ! Argument in register !A550
LINKAGE_REGS (15,13,1) ! Normal otherwise !A550
NOPRESERVE (2) ! ... !A550!M556
PRESERVE (0,3,4,5,6,7,8,9,10,11,12,14); ! ... !A550!M556
! ********** TABLE OF CONTENTS **************
!
FORWARD ROUTINE ! FUNCTION
! ======= ========
!
$UTLINT : NOVALUE, ! $UTLINT MACRO PROCESSOR
$FFFINT : fffint_lnkg NOVALUE, ! $FFFINT PROCESSOR !M550
Util; ! DO THE WORK FOR BOTH
!
! REVISION HISTORY
!
! PRODUCT MODULE SPR
! EDIT EDIT QAR DESCRIPTION
! ====== ====== ===== ===========
!
! ** Begin RMS v2 Development **
!
! 400 400 xxxxx Clean up BLISS code (RL,22-Apr-83)
!
! 442 442 xxxxx Add ALCBKT function for RMSLOD
!
! *** Begin RMS-20 v3 development ***
!
! 524 524 Add FFFINT entry point for
! FFF to call UTLINT without clobbering ACs
!
! 550 550 Define FFFINT linkage, stop using the
! ERRORRETURN argument (RL, 14-Jan-85)
!
! ***** END OF REVISION HISTORY *****
!-
REQUIRE 'rmsreq';
!
! MACROS
!
MACRO
neg_arg =
SIGN(.arglst [0,wrd] ) %;
%SBTTL '$UTLINT - utility interface'
GLOBAL ROUTINE $utlint (utlblock, errorreturn) : NOVALUE =
! $UTLINT
! ====
!
! THIS ROUTINE PROCESSES THE $UTLINT MACRO.
! IT IS CALLED DIRECTLY FROM THE RMS-20 VERB DISPATCHER.
! THIS ROUTINE UPON COMPLETION WILL EXIT DIRECTLY BACK TO
! THE RMS-20 EXIT PROCESSING ROUTINE.
!
! FORMAT OF $UTLINT MACRO:
!
! $UTLINT <ARGBLK-ADDRESS> [,<ERROR-ADDRESS>]
!
! FORMAT OF ARGBLK:
!
! -n,,function
! ARG_1
! ARG_2
! .
! .
! argn
!
! where:
! n = number of arguments(Minus sign to distinguish from _AB blocks)
! function = U$---- (SEE RMSLIB)
!
!
! INPUT:
! BLOCK ADDRESS OF USER ARG BLOCK
! ERRORRETURN DUMMY, NOT USED FOR THIS CALL
!
! OUTPUT:
! The return status is in the UAB.
!
!
!
!
BEGIN
rmsentry ($utlint);
if Util( .utlblock) ! All OK?
then
usrret () ! Yes - normal return
else
usrerr (); ! No - error return
Usrret();
END;
%SBTTL '$FFFINT - Foreign file facility interface'
GLOBAL ROUTINE $FFFint (utlblock) : FFFINT_LNKG NOVALUE =
! $FFFINT
! ====
!
! THIS ROUTINE PROCESSES THE $FFFINT MACRO.
! IT IS CALLED DIRECTLY FROM THE RMS-20 VERB DISPATCHER.
! THIS ROUTINE UPON COMPLETION WILL EXIT DIRECTLY BACK TO
! THE RMS-20 EXIT PROCESSING ROUTINE.
!
! FORMAT OF ARGBLK:
!
! -n,,function
! ARG_1
! ARG_2
! .
! .
! argn
!
! where:
! n = number of arguments(Minus sign to distinguish from _AB blocks)
! function = U$---- (SEE RMSLIB)
!
!
! INPUT:
! BLOCK ADDRESS OF USER ARG BLOCK
!
! OUTPUT:
! No value is returned.
!
!
BEGIN
! Note the absence of "RMSENTRY"
Util( .utlblock);
! Note the absence of "USRRET"
END;
GLOBAL ROUTINE Util ( Arglst: REF BLOCK) =
!+
! FUNCTIONAL DESCRIPTION
!
! Does the dispatch for $UTLINT and $FFFINT
!
! FORMAL PARAMETERS:
!
! ARGLIST: addr of block:
! -n,,function
! ARG_1
! ARG_2
! .
! .
! argn
! where:
! n = number of arguments(Minus sign to distinguish from _AB blocks)
! function = U$---- (SEE RMSLIB)
!
!
!+
BEGIN
LOCAL
ret_value,
temp,
func;
!+
! Check for valid arg list
!-
IF neg_arg NEQ true
THEN
BEGIN
arglst [0, wrd] = 0; ! Set false
usrsts = er$ial; ! Invalid argument list
return false; ! Error return
END;
temp = ABS (.arglst [no_of_args]); ! Make it positive
func = .arglst [rms_func]; ! Which RMS function?
IF .func GEQ u$envneed
THEN
BEGIN ! Insure environment current
rab = .rabutl; ! Restore RAB
rst = .rab [rabisi, 0]; ! Set RST
fst = .rst [rstfst]; ! and FST
END;
arglst [0, wrd] = 0; ! Presume false return, because
! RMS can fail without ever
! returning to $UTLINT.
CASE .func FROM 0 TO u$$max OF
SET
[u$setenvir] :
BEGIN ! SETENVIR
ret_value = true;
rabutl = .arglst [arg_1]; ! Set where RST/FST gotten from
END;
[u$ckeyku] :
BEGIN ! Compare key string with
! key in record
ret_value = !
ckeyku (.arglst [arg_1], ! Key string via RDP ptr
.arglst [arg_2]); ! Record ptr
END;
[u$ckeykk] :
BEGIN ! Compare key string with
! key string
ret_value = !
ckeykk (.arglst [arg_1], ! Key string via RDP ptr
.arglst [arg_2]); ! Key string ptr
END;
[u$chkdup] :
ret_value = chkdup ( ! Is UDR already in SIDR?
.arglst [arg_1], ! Recdesc for 1st SIDR
! Recptr, key string,
! UDR RFA, FLGRETEX input
! Recptr, SIDRelement output
! if false
! True, says no dups
.arglst [arg_2]); ! Bkt desc of 1st SIDR
[u$fbyrrv] :
BEGIN ! Find data record (may
! start with ptr to RRV)
ret_value = !
fbyrrv (.arglst [arg_1], ! Target recdesc (RDRFA set)
.arglst [arg_2]); ! Desc of bucket found
IF .ret_value EQL false !
THEN !
IF .usrsts EQL su$suc !
THEN !
usrsts = er$rfa; !
END;
[u$fbyrfa] :
BEGIN
ret_value = fbyrfa ( ! Find record using RFA
.arglst [arg_1], ! Target Rec Desc (RDRFA set)
.arglst [arg_2], ! Desc of bucket found
false); ! Never lock
IF .ret_value EQL false
THEN
IF .usrsts EQL su$suc THEN usrsts = er$rfa;
END;
[u$fnddata] :
ret_value = fnddata ( !
.arglst [arg_1], ! Rd with key string data
.arglst [arg_2]); ! Bd returned
[u$folopath] :
ret_value = followpath ( !
.arglst [arg_1], ! Rd with addr of search key,
! and its size
.arglst [arg_2]); ! Bd of data bkt
[u$getbkt] :
BEGIN
ret_value = getbkt ( ! GETBKT
.arglst [arg_1], ! Bucket no.
.arglst [arg_2], ! Bucket size
.arglst [arg_3], ! Lock flag
.arglst [arg_4]); ! Bucket descriptor
END;
[u$gmem] :
BEGIN
ret_value = gmem ( ! GMEM
.arglst [arg_1]); ! Size of request
IF .ret_value EQL false THEN usrsts = er$dme;
END;
[u$pmem] :
BEGIN ! PMEM
pmem (.arglst [arg_2], ! No of words
.arglst [arg_1]); ! Addr of chunk
ret_value = true;
END;
[u$gpage] :
BEGIN
ret_value = gpage ( ! GPAGE
.arglst [arg_1]); ! Page # of first page
IF .ret_value EQL false THEN usrsts = er$dme;
END;
[u$getidb] :
BEGIN ! GETIDB
ret_value = getidb (.arglst [arg_1]); ! Bucket desc
END;
[u$getroot] :
BEGIN ! GETROOT
ret_value = getroot (.arglst [arg_1], ! Record desc
.arglst [arg_2]); ! Bucket desc
END;
[u$gtbktptr] :
BEGIN ! GTBKTPTR
ret_value = gtbktptr (.arglst [arg_1], ! Record desc
.arglst [arg_2], ! Current bkt desc
.arglst [arg_3]); ! Next bkt desc
END;
[u$getkdb] :
BEGIN
IF (ret_value = getkdb ( ! GETKDB
.arglst [arg_1] ! Key of reference
)) NEQ false
THEN
kdb = .ret_value; ! Setup KDB
END;
[u$movekey] :
BEGIN ! Move segmented key to KEYBUF
ret_value = true;
movekey (.arglst [arg_1], ! Record ptr
.arglst [arg_2]); ! Keybuf ptr
END;
[u$path] :
ret_value = path;
[u$ppage] :
BEGIN ! PPAGE
ppage (.arglst [arg_1], ! Page # of first page
.arglst [arg_2], ! # Of pages
.arglst [arg_3]); ! Kill flag
ret_value = true;
END;
[u$putbkt] :
BEGIN
putbkt (.arglst [arg_1], ! Update flag
.arglst [arg_2]); ! Bucket descriptor
ret_value = true;
END;
[u$putsidr] :
ret_value = putsidr ( ! Create SIDR entry for
! specific key
.arglst [arg_1]); ! Record Descriptor has RRV
! of UDR & key string
[u$alcbkt] :
BEGIN
ret_value = alcbkt ( ! ALCBKT
.arglst [arg_1], ! Bucket type
.arglst [arg_2], ! Bucket flags
.arglst [arg_3], ! Level Number
.arglst [arg_4]); ! Bucket descriptor
END;
[INRANGE, OUTRANGE] :
BEGIN
usrsts = er$iop; ! Invalid Operation attempted
return false; ! Error return
END;
TES;
!+
! A successful routine returns SU$SUC in the status field.
! An unsuccessful routine returns an ER$xxx value there
! A successful return may return TRUE or FALSE (eg. CKEYKK)
!
! SETSUCCESS is not referenced because it seems inappropriate to
! treat a call to $UTLINT as an RMS operation in the usual sense.
!-
arglst [0, wrd] = .ret_value;
IF .usrsts NEQ su$suc ! What do we do now?
THEN
return false ! Error occurred somewhere
ELSE
return true; ! All is OK
END; ! End $UTLINT
END
ELUDOM