Google
 

Trailing-Edge - PDP-10 Archives - tops20-v7-ft-dist1-clock - 7-sources/rmsdis.b36
There are 6 other files named rmsdis.b36 in the archive. Click here to see a list.
%TITLE 'D I S P L A Y   -- $DISPLAY processor'
!<BLF/REQUIRE 'RMSBLF.REQ'>
MODULE RMSDIS (IDENT = '3.0(656)'
		) =
BEGIN
!
!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 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.
!

!++
! FACILITY:	RMS
!
! ABSTRACT:
!
!	DISPLAY contains all routines which process
!	the $DISPLAY macro in RMS-20.
!
! ENVIRONMENT:	User mode, interrupts deferred until JSYS return
!
! AUTHOR: Ron Lusk , CREATION DATE: 17-Mar-83
!
!--
! Revision History
!
! RMS edit
! 656   - (GAS, 15-Oct-86) Fill in the file's protection to the protection XAB 
!         if there is one specified (dispfile).

!
! TABLE OF CONTENTS
!
!
!	$DISPLAY    -	processor for $DISPLAY macro
!	DISPFILE    -	routine called by $DISPLAY and $OPEN
!
!
! INCLUDE FILES:
!

REQUIRE 'rmsreq';
REQUIRE 'rmsosd';				! OS-dependent definitions

!
! MACROS:
!
!   None.
!
! EQUATED SYMBOLS:
!

GLOBAL BIND
    dsplv = 3^24 + 0^18 + 572;			! Module version

!
! OWN STORAGE:
!
!   None.
!
! EXTERNAL REFERENCES:

EXTERNAL ROUTINE
    D$Display;
EXTERNAL
    OurCfg: $XabCfg_decl;
GLOBAL ROUTINE $display (fabblock, errorroutine) : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	$DISPLAY displays the attributes of an indexed file
!	by transferring the contents of the File Prologue
!	Area and Index Descriptor Blocks into the user's XAB
!	chain.  This function may also be used to fill in a
!	Date XAB or a Summary XAB for any file organization.
!
!	Each user XAB is scanned, in turn, and appropriate
!	information from the file is loaded into it:
!
!	For Area XABs, only the area bucket size is stored
!	    into the XAB.
!	For Key XABs, all key characteristics including the
!	    key name are moved.
!	For Date XABs, the relevant information is acquired
!	    from the monitor and stored into the user's XAB.
!	For Summary XABs, the size of the Area Descriptor
!	    Block and the number of Key Descriptor Blocks in
!	    the KDB chain are stored into the XAB.
!
! FORMAL PARAMETERS
!
!	FABBLOCK    -	address of user File Access Block
!
!	ERRORRETURN -	address of user's error routine
!
! IMPLICIT INPUTS
!
!	?
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	?
!
!--

    BEGIN
    rmsentry ($display);
    !
    !   Fetch the user's FAB and error addresses.
    !
    fab = .fabblock;				! Get FAB address
    erradr = .errorroutine;			! And user error address
    fsetup ();					! Set up the rest

!+
!   Check out if this is a good file.
!-

    IF .fst [blocktype] NEQ fstcode		! Valid FST?
    THEN
	usererror (er$ifi);

!+
!   Check if he has an XAB chain.
!-

    IF .fab [fabxab, 0] NEQ 0
    THEN
	BEGIN

	REGISTER
	    temp;

        IF .fst[fst$v_remote]           ! Is it remote? !m571
        THEN temp = d$display( .fab, .fst )
        ELSE temp = dispfile ();			! Display the file

	IF .temp NEQ true			! Failure?
	THEN
	    usrsts = .temp			! Return proper code
	END;

    usrret ();
    END;					! End of $DISPLAY
GLOBAL ROUTINE t20protra (p_t20_bits)  =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Translate TOPS-20 protection bits to DAP protection bits.  DAP
!       protection bits are mapped roughly to the TOPS-20 protection bits based
!       on the following:
!                                
!       DAP protection bit                        TOPS-20 protection code
!       bit 0   (deny read access)                code 40 (read access)
!       bit 1/3 (deny write/delete access)        code 20 (write/delete access)
!       bit 2   (deny execute access)             code 10 (execute access)
!       bit 4/8 (deny append/extend access)       code 04 (append access)
!       bit 5   (deny directory list access)      code 02 (directory list)
!
! FORMAL PARAMETERS
!
!	p_T20_bits: TOPS-20 protection to translate
!
! IMPLICIT INPUTS
!
!       None.
!
! ROUTINE VALUE:
!
!	DAP protection code.
!       
!--

LOCAL retcode : BITVECTOR[36];
BIND t20_bits = p_t20_bits : BITVECTOR[36];

retcode = 0;                            ! Assume full access

IF NOT .t20_bits[1]                     ! Deny wildcard access?
THEN retcode = .retcode OR
     XAB$M_NOLIST;                      ! Yes indicate this

IF NOT .t20_bits[2]                     ! Deny append access?
THEN retcode = .retcode OR
     XAB$M_NOAPPEND OR XAB$M_NOEXTEND;  ! Yes, and deny append & extend access

IF NOT .t20_bits[3]                     ! Deny execute access?
THEN retcode = .retcode OR
     XAB$M_NOEXECUTE;                   ! Yes, deny execute access

IF NOT .t20_bits[4]                     ! Deny write access?
THEN retcode = .retcode OR
     XAB$M_NOWRITE OR XAB$M_NODELETE;   ! Deny delete and write access

IF NOT .t20_bits[5]                     ! Deny read access?
THEN retcode = .retcode OR
     XAB$M_NOREAD;                      ! Yes, deny read access

RETURN .retcode;                        ! Return the code we created

END;                                    ! t20protra
GLOBAL ROUTINE dispfile =

!++
! FUNCTIONAL DESCRIPTION:
!
!	DISPFILE actually fills the user's XAB chain with
!	the correct file attribute information.
!
!	Note that this routine is driven by the contents of
!	the user's XAB chain, not the contents of the File
!	Prologue.  This reasonable because the Prologue will
!	always be on page 0, and because it avoids many
!	searches of the XAB chain.
!
!	Note also that the File Status Table must be set up
!	before this routine is called.  Thus, any
!	modifications to the $OPEN processing should take
!	this fact into account.
!
! FORMAL PARAMETERS
!
!	None.
!
! IMPLICIT INPUTS
!
!	?
!
! COMPLETION CODES:
!
!	TRUE	    -	Success
!	ER$DME	    -	Dynamic memory exhausted in
!			    mapping File Prologue
!	ER$XAB	    -	Invalid block in XAB chain
!	ER$COD	    -	Invalid XAB code detected
!	ER$BLN	    -	Invalid XAB length detected
!	ER$ORD	    -	Key XABs out of order
!			Area XABs out of order
!	ER$IMX	    -	More than one Date XAB
!			More than one Summary XAB
!	ER$NXT	    -	Bad NXT field in XAB
!
! SIDE EFFECTS:
!
!	The RAB STV field will be set to the address of the bad XAB
!	if an error is detected.
!
!--

    BEGIN

    REGISTER
	xabptr : REF BLOCK,
	idbptr : REF BLOCK,
	acptr : REF BLOCK,
	temp;

    LABEL
	loop,
	outerloop;

    LOCAL
!	bucketdesc : VECTOR [bdsize],		! Bucket descriptor
	dates_blk : BLOCK [dates_blksiz],	! Block for dates
	windowpage,				! Current window page number
	winpageglobal,				! Windowpage or .RMSSEC
	xabtype,				! Type of this XAB
	filepagenumber,				! Page number of currently
						!   mapped file page
	errorcode,				! Storage for error codes
        proflag,                                ! Flag for prot XAB seen
	dateflag,				! Flag for Date XAB seen
	summaryflag,				! Flag for Summary XAB seen
	highestarea,				! Highest area ID seen
	highestref,				! Highest key of reference seen
	keyref,					! Key of reference
	loopstatus,
	keypointer,
	userkeyptr;				!610 User's original keypointer

    TRACE ('DISPFILE');
    !
    !   Get the address of the XAB chain.
    !
    xabptr = .fab [fabxab, 0];
    !
    !   Initialize some more stuff.
    !
    highestarea = (highestref = -1);		! Set to low number
    proflag = dateflag = summaryflag = false;   ! Clear these flags
    errorcode = true;
    filepagenumber = allones;			! This means no page mapped

!+
!   Get a free page to use for the prologue.
!
!   Note that this operation is superfluous for non-indexed
!   files, but it is easier to do it this way than to check
!   below if there is a page already allocated.
!-

    IF (windowpage = gpage (1)) EQL false THEN RETURN er$dme;

!+
!   Do this loop for all XABs.
!-

outerloop :
    BEGIN

    WHILE .xabptr NEQ 0 DO
	BEGIN
	xabptr = .xabptr OR .blksec;		! Get global address

!+
!   We need two BEGIN-END pairs here so we can exit correctly.
!-

loop :
	BEGIN
	loopstatus = true;			! Assume no error

	IF .xabptr [blocktype] NEQ xabcode	! Is this an XAB?
	THEN
	    loopstatus = er$xab;

	IF .xabptr [xabcod, 0] GTR XAB$K_COD_MAX 	! Is this a valid XAB?
	THEN loopstatus = ER$COD;       ! Nope, give invalid XAB code

!+
!   Did we find an error above?
!-

	IF .loopstatus NEQ true THEN LEAVE loop WITH false;

	!
	!   Check the block length of this XAB.
	!
	xabtype = .xabptr [xabcod, 0];		! Get type code
	temp = (CASE .xabtype FROM 0 TO XAB$K_COD_MAX OF
	    SET
	    [xab$k_key] : xab$k_keylen;         ! Key   
	    [xab$k_all] : xab$k_alllen;         ! Area
	    [xab$k_dat] : xab$k_datlen;         ! Date
	    [xab$k_sum] : xab$k_sumlen;         ! Summary
            [XAB$K_PRO] : XAB$K_PROLEN;         ! Protection
            [xab$k_cfg] : xab$k_cfglen;         ! Configuration
	    TES);

	IF .xabptr [blocklength] NEQ .temp	! Block length OK?
	THEN
	    LEAVE loop WITH (loopstatus = er$bln);	! Bad block length

!+
!   Select the proper XAB code.
!-

        CASE .xabtype FROM 0 TO XAB$K_COD_MAX OF
             SET

	    [XAB$K_KEY] :
		BEGIN                   ! Key

		IF NOT idxfile
		THEN
		    LEAVE loop WITH (loopstatus = true);


		!	Find the internal KDB.

		keyref = .xabptr [xabref, 0];

		IF .keyref LEQ .highestref	! Keys out of order?
		THEN
		    LEAVE loop WITH (loopstatus = er$ord);

		highestref = .keyref;		! Update new high keys

!+
!   We will allow a Key XAB with a key
!   of reference greater than the
!   highest key number in the file.
!-

		IF (kdb = getkdb (.keyref)) EQL false
		THEN
		    LEAVE loop WITH (loopstatus = true);	! Bad reference

!+
!   Locate the index descriptor for this key.
!-

!+
!   Check to see if the IDB is on the page we currently have mapped in.
!-

		IF ((temp = (.kdb [kdbidbaddr]^w2p)) NEQ .filepagenumber)
		THEN 				! We must map in a new page
		    BEGIN
		    filepagenumber = .temp;
		    winpageglobal = .windowpage OR (.rmssec^s2p);
		    pagin (.fst [fstjfn], 	! JFN
			.filepagenumber, 	! From file
			.winpageglobal, 	! To memory
			axupd, 			! Access
			1);			! One page
		    END;

		!
		!	Form a pointer to this IDB.
		!
		idbptr = ((.windowpage^p2w) + 	!
		(.kdb [kdbidbaddr] AND ofsetmask));	!
		!	Save the user's key name pointer.
		!
		keypointer = userkeyptr =.xabptr [xabknm, 0];	!610

!+
!   If local section address, get global address.
!-

		IF .keypointer<wrd> NEQ 0	!
		THEN 				!

		    IF .keypointer<lh> EQL 0	!
		    THEN 			!
			keypointer = .keypointer OR .blksec;	!

!+
!   Move the XAB stored in the file to the XAB.
!-

		IF .rmssec NEQ 0
		THEN
		    xcopy (			! Move with XBLT
			.idbptr + idbxaboffset + xabhdrsize, 	! From
			.xabptr + xabhdrsize, 	! To
			keyxabsize - xabhdrsize)	! Size
		ELSE
		    movewords (			! Normal BLT
			.idbptr + idbxaboffset + xabhdrsize, 	! From
			.xabptr + xabhdrsize, 	! To
			keyxabsize - xabhdrsize);	! Size

!+ 610
!	Replace the keypointer with the user's original ptr and
!	Copy the KeyName field
!-

		IF (xabptr[xabknm,0] = .userkeyptr) GTR minuserbuff	!610
		THEN

		    IF .rmssec NEQ 0
		    THEN
			xcopy (			! XBLT
			    .idbptr + idbxaboffset + keyxabsize, 	! From
			    .keypointer, 	! To
			    keynamesize)	! Size
		    ELSE
			movewords (		!
			    .idbptr + idbxaboffset + keyxabsize, 	! From
			    .keypointer, 	! To
			    keynamesize);	! Size

		loopstatus = true
		END;

	    [XAB$K_ALL] :
		BEGIN				! Area

		IF NOT idxfile THEN LEAVE loop WITH (loopstatus = true);

!+
!   Check to see if the AID value conforms
!   to the highest area in the file (we must
!   subtract 2 from the blocklength because
!   of the header, and because the area
!   numbers start at 0).
!-

		IF (temp = .xabptr [xabaid, 0]) GTR 	!
		    ((.adb [adb$h_bln] - 2)/areadescsize)	! Area count
		THEN
		    LEAVE loop WITH (loopstatus = true);

		IF .temp LEQ .highestarea	!
		THEN
		    LEAVE loop WITH (loopstatus = er$ord);

		highestarea = .temp;		! Update new high
		xabptr [xabbkz, 0] = .adb[adb$v_bkz, .temp];
		loopstatus = true		! Set value
		END;


         [XAB$K_PRO]: BEGIN          ! Fill in protection xab if given

                      LOCAL fprotect;   ! File's protection
                      BIND pxab = xabptr[0,0,0,0] : $XABPRO_DECL;

                      IF .proflag       ! Seen protection already?
                      THEN LEAVE loop WITH (loopstatus = ER$IMX);

                      IF NOT GTFDB (.fst[fstjfn],       ! Get file protection
                                    ($XWD (1,$FBPRT)),
                                    fprotect)
                      THEN fprotect = %O'777777';       ! Return 777777 if punt

                      ! Translate the TOPS-20 protection to the DAP style
                      ! protection bits.  Note that the TOPS-20 world
                      ! protection is set to allow anything since a WHEEL
                      ! or OPERATOR can do anything with a file.

                      pxab[XAB$V_PROTSYS] = 0;
                      pxab[XAB$V_PROTWLD] = t20protra (.fprotect);
                      pxab[XAB$V_PROTGRP] = t20protra (.fprotect ^ -6);
                      pxab[XAB$V_PROTOWN] = t20protra (.fprotect ^ -12);

                      proflag =         ! Remember we have been here before
                      loopstatus = TRUE

                      END;              ! end of XAB$K_PRO code
                      
            [XAB$K_DAT] :
		BEGIN				! Date

                                        ! Check that only one of these are
                                        ! given.  Note that this check is
                                        ! really not necessary, it is included
                                        ! here for compatability with RMS-11.

		IF .dateflag NEQ 0      ! Have we seen a DATE XAB?
		THEN
		    LEAVE loop WITH (loopstatus = er$imx);

		dateflag = 1;			! Set flag

                ! Read the file's dates from the monitor.

		datofile (.fst [fstjfn], 	! JFN
		    dates_blk, 			! Pointer to block
		    dates_blksiz);		! Size

                !  Fill in the user's XAB.

		xabptr [xabcdt, 0] = .dates_blk [dt_cre, wrd];
		xabptr [xabrdt, 0] = .dates_blk [dt_wri, wrd];
		xabptr [xabedt, 0] = 0;		! No deletion
		loopstatus = true		! Indicate success

		END;                    ! End of XAB$K_DAT code 

	    [XAB$K_SUM] :
		BEGIN				! Summary

		IF .summaryflag NEQ 0		! Have we seen a SUMMARY XAB?
		THEN
		    LEAVE loop WITH (loopstatus = er$imx);

		summaryflag = 1;		! Set flag

! The following line was deleted long ago, yet kept -- RL, Mar-83
!		xabptr [xabnor, 0] = 0;		! Record descriptor[?]
		temp = 0;			! Assume no areas

		IF idxfile			! Do only for index files
		THEN
		    temp = (.adb[adb$h_bln] - 1)/areadescsize;

		xabptr [xabnoa, 0] = .temp;	! Store in XAB
		temp = 0;			! Init counter
		acptr = .fst [fstkdb];		! Pointer to first KDB

!+
!   Loop over all KDBs and count them
!   (this means that we don't have to
!   scan thru the file IDBs to determine
!   the number of keys).
!-

		UNTIL .acptr EQL 0 DO
		    BEGIN
		    acptr = .acptr [kdbnxt];
		    temp = .temp + 1;		! Bump KDB counter
		    END;

		xabptr [xabnok, 0] = .temp;
		loopstatus = true
		END;

            ! Configuration XAB

            [XAB$K_CFG]:
                IF .rmssec NEQ 0
                THEN
                    $rms$xcopy( OurCfg + Xab$k_HdrLen,  ! Copy local config
                                .Xabptr + Xab$k_HdrLen, ! xab , except for
                                Xab$k_CfgLen - Xab$k_HdrLen )  ! header  !m553
                ELSE
                    $move_words( OurCfg + Xab$k_HdrLen,  ! Copy local config
                                .Xabptr + Xab$k_HdrLen, ! xab , except for
                                Xab$k_CfgLen - Xab$k_HdrLen );  ! header  !m572
	    TES;

	END;

!+
!   Check to see if the next XAB address is ok.
!-

	temp = .xabptr [xabnxt, 0];		! Get next XAB address

	IF (.temp NEQ 0) AND (.temp LEQ minuserbuff)	!
	THEN
	    loopstatus = er$nxt;		! Bad next address

!+
!   Did we find an error during our XAB scan?
!-

	IF .loopstatus NEQ true
	THEN
	    BEGIN
	    usrstv = .xabptr;			! Remember XAB
	    LEAVE outerloop WITH (errorcode = .loopstatus)
	    END;

	!
	!   Go to next XAB.
	!
	xabptr = .temp
	END;

    END;

!+
!   Flush the free page we got earlier.
!-

    ppage (.windowpage, 1, true);
    RETURN .errorcode
    END;					! End of DISPFILE
END						! End of Module DISPLAY

ELUDOM