Google
 

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