Google
 

Trailing-Edge - PDP-10 Archives - BB-H138F-BM_1988 - 7-sources/rmsdmp.b36
There are 6 other files named rmsdmp.b36 in the archive. Click here to see a list.
%TITLE 'D E B G   -- $DEBUG and debugging code'
!<BLF/REQUIRE 'RMSBLF.REQ'>
MODULE debg (IDENT = '3.0'
		) =
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.
!

!
!			  COPYRIGHT (c) 1984 BY
!	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! 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:	RMS
!
! ABSTRACT:
!
!	DEBG contains all routines which support and
!	process the debugging facilities of RMS-20.
!
! ENVIRONMENT:	User mode, compiled with debugging enabled
!
! AUTHOR: Ron Lusk , CREATION DATE: 17-Mar-83
!
! MODIFIED BY:
!
!	, : VERSION
! 01	-
!--

!
! TABLE OF CONTENTS
!
!
!	$DEBUG	    -	process $DEBUG verb
!	DUMP	    -
!	DUMPRST	    -	dump a Record Status Table
!	DUMPIDB	    -	dump an Index Descriptor Block
!	DUMPKDB	    -	dump a Key Descriptor Block
!	DUMPRD	    -	dump a Record Descriptor
!	DUMPHEADER  -	dump a Bucket Header
!
!
! INCLUDE FILES:
!

REQUIRE 'rmsreq';

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

GLOBAL BIND
    debgv = 2^24 + 0^18 + 400;			! Module version

!
! OWN STORAGE:
!
!   None.
!
! EXTERNAL REFERENCES:
!
EXTERNAL
    D$gTrace;

EXTERNAL ROUTINE
    NoValRet;
%SBTTL '$DEBUG -- $DEBUG processor'

GLOBAL ROUTINE $debug (bitvalue, dummyarg) : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	$DEBUG processes the $DEBUG macro for using the
!	RMS-20 debugging facilities.  The format of this
!	macro is as follows:
!
!	    $DEBUG (value-1 [ OR value-n ... ]);    in BLISS
!
!		    or
!
!	    $DEBUG value-1 [ ! value-n ... ]	    in MACRO
!
!	Values are:
!	    DB$TRC  -	Trace entry to each routine
!	    DB$ERR  -	Trace user errors
!	    DB$RTR  -	Trace routine execution
!	    DB$LOC  -	Print out local variables
!	    DB$ENQ  -	Print out ENQ blocks
!	    DB$BLK  -	Print out all internal RMS-20 blocks
!	    DB$IO   -	Trace I/O page faults (buffer faults)
!
!
! FORMAL PARAMETERS
!
!	BITVALUE    -	Value to set for debugging
!
! IMPLICIT INPUTS
!
!	?
!
! ROUTINE VALUE:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	?
!
!--

    BEGIN
    bugflg = .bitvalue;				! Set debugging flags

    IF (.bugflg AND dbg$m_dap_trace) NEQ 0
    THEN D$Gtrace = -1
    ELSE D$Gtrace = 0;

    NoValRet ();
    END;					! End of $DEBUG
%SBTTL 'DUMP -- Dump a block of data'

GLOBAL ROUTINE dump (blksiz, blkaddr) : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine is used for debugging only.  It
!	prints out the contents of a block in core.
!
! FORMAL PARAMETERS
!
!	BLKSIZ	-   length of block to dump
!	BLKADDR	-   address to start dumping (passed as value)
!
! IMPLICIT INPUTS
!
!	?
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	?
!
!--

    BEGIN

%IF dbug
%THEN

    LOCAL
	datablock;				! Need temporary local

    datablock = .blkaddr;			! Get address of block
    !
    !   Loop over the entire block.
    !

    INCR j FROM 1 TO .blksiz DO
	BEGIN
	txtout (mf$oct, .datablock);		! Put out <TAB>octal number
	datablock = .datablock + 1;		! Bump pointer
	END
%ELSE
    RETURN;

%FI

    END;					! End of DUMP
%SBTTL 'DUMPRST -- Dump Record Status Table'

GLOBAL ROUTINE dumprst : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	DUMPRST prints out a formatted copy of the
!	Record Status Table for use in debugging.
!
! FORMAL PARAMETERS
!
!	None.
!
! IMPLICIT INPUTS
!
!	The Record Status Table pointed to by RST.
!
! ROUTINE VALUE:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    BEGIN

%IF dbug
%THEN

    bugout ('** Dump of RST **');%([ PRINT OUT EACH FIELD ])%
    txtout (mf$rsf, $stradd ('BLOCKTYPE'), .rst [blocktype]);
    txtout (mf$rsf, $stradd ('BLOCKLENGTH'), .rst [blocklength]);
    txtout (mf$rsf, $stradd ('BLINK'), .rst [blink]);
    txtout (mf$rsf, $stradd ('FLINK'), .rst [flink]);
    txtout (mf$rsf, $stradd ('RSTRSZ'), .rst [rstrsz]);
    txtout (mf$rsf, $stradd ('RSTRSZW'), .rst [rstrszw]);
    txtout (mf$rsf, $stradd ('RSTDATARFA'), .rst [rstdatarfa]);
    txtout (mf$rsf, $stradd ('RSTFLAGS'), .rst [rstflags]);
    txtout (mf$rsf, $stradd ('RSTPAGPTR'), .rst [rstpagptr]);
    txtout (mf$rsf, $stradd ('RSTLASTOPER'), .rst [rstlastoper]);
    txtout (mf$rsf, $stradd ('RSTNRP'), .rst [rstnrp]);
    type ('');					! Blank line
    RETURN
%ELSE
	RETURN;
%FI

    END;					! End of DUMPRST
%SBTTL 'DUMPIDB -- Dump Index Descriptor Block'

GLOBAL ROUTINE dumpidb (idbptr : REF BLOCK) : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	DUMPIDB dumps out the contents of an Index
!	Descriptor Block pointed to by IDBPTR.
!
! FORMAL PARAMETERS
!
!	IDBPTR	    -	Pointer to Index Descriptor Block
!
! IMPLICIT INPUTS
!
!	None.
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    BEGIN

%IF dbug
%THEN

    txtout (mf$rsf, $stradd ('BLOCKTYPE'), .idbptr [blocktype]);
    txtout (mf$rsf, $stradd ('BLOCKLENGTH'), .idbptr [blocklength]);
    txtout (mf$rsf, $stradd ('IDBROOT'), .idbptr [idbroot]);
    txtout (mf$rsf, $stradd ('IDBLEVELS'), .idbptr [idblevels]);
    txtout (mf$rsf, $stradd ('IDBNXT'), .idbptr [idbnxt]);
    RETURN
%ELSE
	RETURN;
%FI

    END;					! End of DUMPIDB
%SBTTL 'DUMPKDB -- Dump Key Descriptor Block'

GLOBAL ROUTINE dumpkdb (kdbptr : REF BLOCK) : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	DUMPKDB dumps a Key Descriptor Block pointed to by
!	KDBPTR.
!
! FORMAL PARAMETERS
!
!	KDBPTR	    -	pointer to a Key Descriptor Block
!
! IMPLICIT INPUTS
!
!	None.
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    BEGIN

%IF dbug
%THEN
    txtout (mf$rsf, $stradd ('BLOCKTYPE'), .kdbptr [blocktype]);
    txtout (mf$rsf, $stradd ('BLOCKLENGTH'), .kdbptr [blocklength]);
    txtout (mf$rsf, $stradd ('KDBROOT'), .kdbptr [kdbroot]);
    txtout (mf$rsf, $stradd ('KDBHSZ'), .kdbptr [kdbhsz]);
    txtout (mf$rsf, $stradd ('KDBKSZ'), .kdbptr [kdbksz]);
    txtout (mf$rsf, $stradd ('KDBKSZW'), .kdbptr [kdbkszw]);
    txtout (mf$rsf, $stradd ('KDBDTP'), .kdbptr [kdbdtp]);
    txtout (mf$rsf, $stradd ('KDBREF'), .kdbptr [kdbref]);
    txtout (mf$rsf, $stradd ('KDBIDBADDR'), .kdbptr [kdbidbaddr]);
    txtout (mf$rsf, $stradd ('KDBFLAGS'), .kdbptr [kdbflags]);
    txtout (mf$rsf, $stradd ('KDBNXT'), .kdbptr [kdbnxt]);
    txtout (mf$rsf, $stradd ('KDBIFLOFFSET'), .kdbptr [kdbifloffset]);
    txtout (mf$rsf, $stradd ('KDBDFLOFFSET'), .kdbptr [kdbdfloffset]);
    txtout (mf$rsf, $stradd ('KDBIAN'), .kdbptr [kdbian]);
    txtout (mf$rsf, $stradd ('KDBDAN'), .kdbptr [kdbdan]);
    txtout (mf$rsf, $stradd ('KDBKBSZ'), .kdbptr [kdbkbsz]);
    txtout (mf$rsf, $stradd ('KDBLEVELS'), .kdbptr [kdblevels]);
    txtout (mf$rsf, $stradd ('KDBMINRSZ'), .kdbptr [kdbminrsz]);
    txtout (mf$rsf, $stradd ('KDBIBKZ'), .kdbptr [kdbibkz]);
    txtout (mf$rsf, $stradd ('KDBDBKZ'), .kdbptr [kdbdbkz]);
    !
    !   Note that the key position and size fields
    !   are not printed out.
    !
    RETURN;
%ELSE
    RETURN;
%FI

    END;					! End of DUMPKDB
%SBTTL 'DUMPRD -- Dump a record descriptor'

GLOBAL ROUTINE dumprd (rdptr : REF BLOCK) : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	DUMPRD dumps out the contents of a Record Descriptor
!	packet pointed to by RDPTR.
!
! FORMAL PARAMETERS
!
!	RDPTR	    -	pointer to Record Descriptor packet
!
! IMPLICIT INPUTS
!
!	None.
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    BEGIN

%IF dbug
%THEN
    txtout (mf$rsf, $stradd ('RDFLAGS'), .rdptr [rdflags]);
    txtout (mf$rsf, $stradd ('RDSTATUS'), .rdptr [rdstatus]);
    txtout (mf$rsf, $stradd ('RDUSERSIZE'), .rdptr [rdusersize]);
    txtout (mf$rsf, $stradd ('RDCOUNT'), .rdptr [rdcount]);
    txtout (mf$rsf, $stradd ('RDLASTLEVEL'), .rdptr [rdlastlevel]);
    txtout (mf$rsf, $stradd ('RDLEVEL'), .rdptr [rdlevel]);
    txtout (mf$rsf, $stradd ('RDUSERPTR'), .rdptr [rduserptr]);
    txtout (mf$rsf, $stradd ('RDRFA'), .rdptr [rdrfa]);
    txtout (mf$rsf, $stradd ('RDRECPTR'), .rdptr [rdrecptr]);
    txtout (mf$rsf, $stradd ('RDLASTRECPTR'), .rdptr [rdlastrecptr]);
    txtout (mf$rsf, $stradd ('RDRRV'), .rdptr [rdrrv]);
    txtout (mf$rsf, $stradd ('RDLENGTH'), .rdptr [rdlength]);
    RETURN
%ELSE
	RETURN;
%FI

    END;					! End of DUMPRD
%SBTTL 'DUMPHEADER - dump bucket header'

GLOBAL ROUTINE dumpheader (bktptr : REF BLOCK) : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	DUMPHEADER dumps the header of an indexed file
!	bucket pointed to by BKTPTR.
!
! FORMAL PARAMETERS
!
!	BKTPTR	    -	Pointer to bucket header
!
! IMPLICIT INPUTS
!
!	None.
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    BEGIN

%IF dbug
%THEN
    txtout (mf$rsf, $stradd ('BHFLAGS'), .bktptr [bhflags]);
    txtout (mf$rsf, $stradd ('BHLEVEL'), .bktptr [bhlevel]);
    txtout (mf$rsf, $stradd ('BHBTYPE'), .bktptr [bhbtype]);
    txtout (mf$rsf, $stradd ('BHNEXTBYTE'), .bktptr [bhnextbyte]);
    txtout (mf$rsf, $stradd ('BHTHISAREA'), .bktptr [bhthisarea]);
    txtout (mf$rsf, $stradd ('BHNEXTBKT'), .bktptr [bhnextbkt]);
    txtout (mf$rsf, $stradd ('BHLASTID'), .bktptr [bhlastid]);
    txtout (mf$rsf, $stradd ('BHNEXTID'), .bktptr [bhnextid]);
    RETURN
%ELSE
	RETURN;
%FI

    END;					! End of DUMPHEADER

END						! End of Module DEBG

ELUDOM