Google
 

Trailing-Edge - PDP-10 Archives - BB-JF18A-BM - sources/diu/diudis.bli
There are 4 other files named diudis.bli in the archive. Click here to see a list.
MODULE DIUDIS (
               %require ('DIUPATSWITCH')
               IDENT = '253') =
BEGIN
!++
!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 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:	DIU    Data Interchange Utility
!
! ENVIRONMENT:  VAX VMS V4.0	
!		TOPS-20 v. 6.0
!		BLISS V4
!		XPORT
!
! ABSTRACT:	This module contains the utility routines to display the
!		contents of DIU record descriptions, which are based on CRX
!		record descriptions.
!
! AUTHOR:  Rick Fricchione				CREATED: 4-May-1984
!
! HISTORY:
!
!  253  Rename file to DIUDIS.
!       Gregory A. Scott 1-Jul-86
!
!	V01-005 CLR0003		Charlotte Richardson		12-July-85
!		Account for DIL complex numbers.
!
!	V01-004	CLR0002		Charlotte Richardson		30-May-85
!		Add CRX_TAG_FFD node.
!
!	V01-003 CLR0001		Charlotte Richardson		 10-Dec-84
!		Convert to transportable Bliss and DIU data structures.
!		Add DIU facility-specific block.  Clean up code.
!
!	V01-002	RDF0003		Rick Fricchione			 24-Oct-1984
!               Add support of INITIAL VALUE clause on member node
!		and put definition of $FAO_PUT in here to better
!		document whats going on.  Add support for tag variables.
!
!	V01-001	RDF0002		Rick Fricchione			 12-Oct-1984
!		Add OTHERWISE clause to DIU$CDD_DUMP_SUBTREE to allow
!		for unknown CRX records to be SIGNAL'd.  Get rid of 
!		ridiculous $SKIP macro, and clean up slightly.
!
!	V01-000	RDF0001		Rick Fricchione			 4-Feb-1984
!		Original version of DIU$CDD_ROUTINES. Figure out
!		interface to CRX. Build debugging dump routine,
!
!--
!********************************************************************
!           L I B R A R Y   A N D   R E Q U I R E    F I L E S
!********************************************************************

REQUIRE 'DIUPATPROLOG';			! General module prologue

%BLISS36 (
LIBRARY 'FAO.L36';			! TOPS-20 FAO stuff
)

LIBRARY 'DIUACTION';			! PAT action routine library
%IF %BLISS (BLISS32) %THEN
UNDECLARE %QUOTE $DESCRIPTOR;
%FI
LIBRARY 'DIUCRX';                       ! Transportable CRX data structures
%IF %BLISS (BLISS32) %THEN
UNDECLARE %QUOTE $DESCRIPTOR;
%FI
LIBRARY 'BLI:XPORT';			! Transportable data structures
UNDECLARE %QUOTE $DESCRIPTOR;		! Clean up after XPORT
LIBRARY 'DIUMLB';			! Library for datatype mapping
UNDECLARE %QUOTE $DESCRIPTOR;		! Clean up after XPORT
%BLISS32 (
LIBRARY 'SYS$LIBRARY:STARLET';		! VMS System Services
)
!******************************************************************
!                    G L O B A L S 
!******************************************************************

own

! Things of use to FAO:

fao_buf		: VECTOR [ch$allocation (255)],
fao_len,
fao_desc	: $STR_DESCRIPTOR (string = (255, ch$ptr (fao_buf))),
lcontrol	: $STR_DESCRIPTOR (CLASS = DYNAMIC),

! DIU datatypes:

DT_UNK		: $STR_DESCRIPTOR (string = '** unknown **'),
DT_A7		: $STR_DESCRIPTOR (string = 'DIX$K_DT_ASCII_7'),
DT_A8		: $STR_DESCRIPTOR (string = 'DIX$K_DT_ASCII_8'),
DT_AZ		: $STR_DESCRIPTOR (string = 'DIX$K_DT_ASCIZ'),
DT_E8		: $STR_DESCRIPTOR (string = 'DIX$K_DT_EBCDIC_8'),
DT_E9		: $STR_DESCRIPTOR (string = 'DIX$K_DT_EBCDIC_9'),
DT_S		: $STR_DESCRIPTOR (string = 'DIX$K_DT_SIXBIT'),
DT_S128		: $STR_DESCRIPTOR (string = 'DIX$K_DT_SBF128'),
DT_S16		: $STR_DESCRIPTOR (string = 'DIX$K_DT_SBF16'),
DT_S32		: $STR_DESCRIPTOR (string = 'DIX$K_DT_SBF32'),
DT_S36		: $STR_DESCRIPTOR (string = 'DIX$K_DT_SBF36'),
DT_S48		: $STR_DESCRIPTOR (string = 'DIX$K_DT_SBF48'),
DT_S64		: $STR_DESCRIPTOR (string = 'DIX$K_DT_SBF64'),
DT_S72		: $STR_DESCRIPTOR (string = 'DIX$K_DT_SBF72'),
DT_S8		: $STR_DESCRIPTOR (string = 'DIX$K_DT_SBF8'),
DT_SVAR		: $STR_DESCRIPTOR (string = 'DIX$K_DT_SBFVAR'),
DT_U16		: $STR_DESCRIPTOR (string = 'DIX$K_DT_UBF16'),
DT_U32		: $STR_DESCRIPTOR (string = 'DIX$K_DT_UBF32'),
DT_U8		: $STR_DESCRIPTOR (string = 'DIX$K_DT_UBF8'),
DT_UVAR		: $STR_DESCRIPTOR (string = 'DIX$K_DT_UBFVAR'),
DT_U128		: $STR_DESCRIPTOR (string = 'DIX$K_DT_UBF128'),
DT_U36		: $STR_DESCRIPTOR (string = 'DIX$K_DT_UBF36'),
DT_U64		: $STR_DESCRIPTOR (string = 'DIX$K_DT_UBF64'),
DT_U72		: $STR_DESCRIPTOR (string = 'DIX$K_DT_UBF72'),
DT_DF		: $STR_DESCRIPTOR (string = 'DIX$K_DT_D_FLOAT'),
DT_FF		: $STR_DESCRIPTOR (string = 'DIX$K_DT_F_FLOAT'),
DT_F36		: $STR_DESCRIPTOR (string = 'DIX$K_DT_FLOAT_36'),
DT_F72		: $STR_DESCRIPTOR (string = 'DIX$K_DT_FLOAT_72'),
DT_GF		: $STR_DESCRIPTOR (string = 'DIX$K_DT_G_FLOAT'),
DT_GF72		: $STR_DESCRIPTOR (string = 'DIX$K_DT_G_FLOAT72'),
DT_HF		: $STR_DESCRIPTOR (string = 'DIX$K_DT_H_FLOAT'),
DT_DC		: $STR_DESCRIPTOR (string = 'DIX$K_DT_D_CMPLX'),
DT_FC		: $STR_DESCRIPTOR (string = 'DIX$K_DT_F_CMPLX'),
DT_FC36		: $STR_DESCRIPTOR (string = 'DIX$K_DT_F_CMPLX36'),	![5]
DT_GC		: $STR_DESCRIPTOR (string = 'DIX$K_DT_G_CMPLX'),
DT_HC		: $STR_DESCRIPTOR (string = 'DIX$K_DT_H_CMPLX'),
DT_6LO		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN6LO'),
DT_6LS		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN6LS'),
DT_6TO		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN6TO'),
DT_6TS		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN6TS'),
DT_6U		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN6U'),
DT_7LO		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN7LO'),
DT_7LS		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN7LS'),
DT_7TO		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN7TO'),
DT_7TS		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN7TS'),
DT_7U		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN7U'),
DT_8LO		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN8LO'),
DT_8LS		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN8LS'),
DT_8TO		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN8TO'),
DT_8TS		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN8TS'),
DT_8U		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN8U'),
DT_9LO		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN9LO'),
DT_9LS		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN9LS'),
DT_9TO		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN9TO'),
DT_9TS		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN9TS'),
DT_9U		: $STR_DESCRIPTOR (string = 'DIX$K_DT_DN9U'),
DT_PD8		: $STR_DESCRIPTOR (string = 'DIX$K_DT_PD8'),
DT_PD9		: $STR_DESCRIPTOR (string = 'DIX$K_DT_PD9'),
DT_OVLY		: $STR_DESCRIPTOR (string = 'VARIANTS node'),
DT_STR		: $STR_DESCRIPTOR (string = 'STRUCTURE node'),

TERMINAL	: $XPO_IOB ();
!******************************************************************
!                    M A C R O S 
!******************************************************************

MACRO  $FAO_PUT (indent, faostring) [] = 

    ! This MACRO is intended to provide an easier interface to the $FAO
    ! system service.  Using this, a control string, and the FAO arguments
    ! to that string are given.  If the FAO service completes successfully,
    ! the formatted ASCII text is printed on SYS$OUTPUT.  If not, the error
    ! status from $FAO is returned, and no text is printed.   The indent
    ! parameter will be used to determine how many <tabs> to place in front
    ! of the FAO control string.  This will be from one to n "!_" prefixing
    ! the string argument given.  (Note that indent is treated as a value
    ! and not an address)

BEGIN

    $STR_DESC_INIT (DESCRIPTOR = lcontrol, CLASS = DYNAMIC);

    IF indent GTR 0
	THEN INCR idx FROM 1 TO indent
	    DO $STR_APPEND (string = '!_', TARGET = lcontrol);
		         
    $STR_APPEND (string = faostring, target = lcontrol);

    fao_len = 0;
    $FAO (lcontrol, fao_len, fao_desc, %REMAINING);
    fao_desc [STR$H_LENGTH] = .fao_len;
    $XPO_PUT (IOB = terminal, STRING = fao_desc);
    fao_desc [STR$H_LENGTH] = 255;
    $XPO_FREE_MEM (STRING = lcontrol);

END%;
!******************************************************************
!             T A B L E    O F    C O N T E N T S
!******************************************************************

FORWARD ROUTINE

ADDITIONAL_NODE : NOVALUE,	! Display an additional information block
DIMENSION_NODE : NOVALUE,	! Display dimension node
DUMP_SUBTREE : NOVALUE,		! Dump a subtree of record description
DUMP_TREE : NOVALUE,		! Dump record description tree
GET_DATATYPE,			! Return string descriptor to datatype name
LITERAL_LIST_NODE : NOVALUE,	! Display literal-list node
MEMBER_NODE : NOVALUE,		! Display member node
MORE_MEMBER : NOVALUE,		! Second half of MEMBER_NODE
				! (Crock to get around Bliss-36 bug!)
OVERLAY_NODE : NOVALUE,		! Display overlay node
PLI_SPECIFIC_NODE : NOVALUE,	! Display PL1-specific node
RECORD_NODE : NOVALUE,		! Display record node
STRINGLIST_NODE : NOVALUE,	! Display stringlist node
TAG_FFD_NODE : NOVALUE,		! Display tag FFD node
TREE : NOVALUE;			! Driver for DUMP_TREE
!******************************************************************
!	    G E T _ D A T A T Y P E 
!******************************************************************

ROUTINE GET_DATATYPE (p_type) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine is passed a (long)word containing the DIU internal 
!	data type code for a given item.  It will return the address of
!	a string descriptor which gives a readable datatype for the 
!	numeric code.
!	
! FORMAL PARAMETERS
!
!	p_type.rlu.r	The address of a (long)word containing the DIU
!			data type code to convert.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	Address of a descriptor for the string which corresponds to the
!	longword datatype given.  If no match is found, "** unknown **
!	is returned.
!
!--

SELECTONE .p_type OF
    SET       

    [DIX$K_DT_ASCII_7]:		return DT_A7;
    [DIX$K_DT_ASCII_8]:		return DT_A8;
    [DIX$K_DT_ASCIZ]:		return DT_AZ;
    [DIX$K_DT_EBCDIC_8]:	return DT_E8;
    [DIX$K_DT_EBCDIC_9]:	return DT_E9;
    [DIX$K_DT_SIXBIT]:		return DT_S;
    [DIX$K_DT_SBF128]:		return DT_S128;
    [DIX$K_DT_SBF16]:		return DT_S16;
    [DIX$K_DT_SBF32]:		return DT_S32;
    [DIX$K_DT_SBF36]:		return DT_S36;
    [DIX$K_DT_SBF48]:		return DT_S48;
    [DIX$K_DT_SBF64]:		return DT_S64;
    [DIX$K_DT_SBF72]:		return DT_S72;
    [DIX$K_DT_SBF8]:		return DT_S8;
    [DIX$K_DT_SBFVAR]:		return DT_SVAR;
    [DIX$K_DT_UBF16]:		return DT_U16;
    [DIX$K_DT_UBF32]:		return DT_U32;
    [DIX$K_DT_UBF8]:		return DT_U8;
    [DIX$K_DT_UBFVAR]:		return DT_UVAR;
    [DIX$K_DT_UBF128]:		return DT_U128;
    [DIX$K_DT_UBF36]:		return DT_U36;
    [DIX$K_DT_UBF64]:		return DT_U64;
    [DIX$K_DT_UBF72]:		return DT_U72;
    [DIX$K_DT_D_FLOAT]:		return DT_DF;
    [DIX$K_DT_F_FLOAT]:		return DT_FF;
    [DIX$K_DT_FLOAT_36]:	return DT_F36;
    [DIX$K_DT_FLOAT_72]:	return DT_F72;
    [DIX$K_DT_G_FLOAT]:		return DT_GF;
    [DIX$K_DT_G_FLOAT72]:	return DT_GF72;
    [DIX$K_DT_H_FLOAT]:		return DT_HF;
    [DIX$K_DT_D_CMPLX]:		return DT_DC;
    [DIX$K_DT_F_CMPLX]:		return DT_FC;
    [DIX$K_DT_F_CMPLX36]:	return DT_FC36;		![5]
    [DIX$K_DT_G_CMPLX]:		return DT_GC;
    [DIX$K_DT_H_CMPLX]:		return DT_HC;
    [DIX$K_DT_DN6LO]:		return DT_6LO;
    [DIX$K_DT_DN6LS]:		return DT_6LS;
    [DIX$K_DT_DN6TO]:		return DT_6LO;
    [DIX$K_DT_DN6TS]:		return DT_6LS;
    [DIX$K_DT_DN6U]:		return DT_6U;
    [DIX$K_DT_DN7LO]:		return DT_7LO;
    [DIX$K_DT_DN7LS]:		return DT_7LS;
    [DIX$K_DT_DN7TO]:		return DT_7TO;
    [DIX$K_DT_DN7TS]:		return DT_7TS;
    [DIX$K_DT_DN7U]:		return DT_7U;
    [DIX$K_DT_DN8LO]:		return DT_8LO;
    [DIX$K_DT_DN8LS]:		return DT_8LS;
    [DIX$K_DT_DN8TO]:		return DT_8TO;
    [DIX$K_DT_DN8TS]:		return DT_8TS;
    [DIX$K_DT_DN8U]:		return DT_8U;
    [DIX$K_DT_DN9LO]:		return DT_9LO;
    [DIX$K_DT_DN9LS]:		return DT_9LS;
    [DIX$K_DT_DN9TO]:		return DT_9TO;
    [DIX$K_DT_DN9TS]:		return DT_9TS;
    [DIX$K_DT_DN9U]:		return DT_9U;
    [DIX$K_DT_PD8]:		return DT_PD8;
    [DIX$K_DT_PD9]:		return DT_PD9;
    [DIU$K_DT_OVERLAY]:		return DT_OVLY;
    [DIU$K_DT_STRUCTURE]:	return DT_STR;

    [OTHERWISE]:		return DT_UNK;
TES;
		
END;
!******************************************************************
!	       R E C O R D _ N O D E 
!******************************************************************

ROUTINE RECORD_NODE (p_tree, depth) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump a record node.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the record node.
!
!	depth.rlu.v     A (long)word containing the current
!			indentation level for the $FAO_PUT macro.  This
!			is incremented on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

LOCAL
    text	: $STR_DESCRIPTOR (CLASS = DYNAMIC),
    cdd_record	: REF crx_record;

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

! Get field addressibility via REF.

cdd_record  = .p_tree;

$FAO_PUT (0, ' ');
%IF %BLISS (BLISS32) %THEN
$FAO_PUT (.depth, 'Record root at: !XL:', .p_tree);
%ELSE
$FAO_PUT (.depth, 'Record root at: !OL:', .p_tree);
%FI
$FAO_PUT (.depth, 'mbz: !SL', .cdd_record [CRX$L_MBZ]);
%IF %BLISS (BLISS32) %THEN
$FAO_PUT (.depth, 'First member: !XL', .cdd_record [crx$a_root]);
%ELSE
$FAO_PUT (.depth, 'First member: !OL', .cdd_record [crx$a_root]);
%FI
$FAO_PUT (.depth, 'id: !SB', .cdd_record [CRX$B_ID]);
$FAO_PUT (.depth, 'core_level: !SB', .cdd_record [CRX$B_CORE_LEVEL]);
$STR_DESC_INIT (DESCRIPTOR = text, CLASS = DYNAMIC);
$STR_COPY (string = (10, ch$ptr (cdd_record [CRX$T_PROTOCOL])),
    target = text);
$FAO_PUT (.depth, 'protocol: !AS', text);
$FAO_PUT (.depth, 'facility code: !SW',
    .cdd_record [CRX$W_FACILITY_CODE]);
$FAO_PUT (.depth, 'description_cnt: !SB',
    .cdd_record [CRX$B_DESCRIPTION_CNT]);
%IF %BLISS (BLISS32) %THEN
$FAO_PUT (.depth, 'facility addr: !XL', .cdd_record [CRX$A_FACILITY]);
%ELSE
$FAO_PUT (.depth, 'facility addr: !OL', .cdd_record [CRX$A_FACILITY]);
%FI
$FAO_PUT (.depth, 'format: !SL', .cdd_record [CRX$L_FORMAT]);
%IF %BLISS (BLISS32) %THEN
$FAO_PUT (.depth, 'Description: !XL', .cdd_record [CRX$A_DESCRIPTION]);
%ELSE
$FAO_PUT (.depth, 'Description: !OL', .cdd_record [CRX$A_DESCRIPTION]);
%FI

DUMP_SUBTREE (.cdd_record [CRX$A_FACILITY], .depth + 1);
DUMP_SUBTREE (.cdd_record [CRX$A_DESCRIPTION], .depth + 1);
DUMP_SUBTREE (.cdd_record [CRX$A_ROOT], .depth + 1);

END;
!******************************************************************
!	       M E M B E R _ N O D E 
!******************************************************************

ROUTINE MEMBER_NODE (p_tree, depth) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump a member node.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the member node.
!
!	depth.rlu.v     A (long)word containing the current
!			indentation level for the $FAO_PUT macro.  This
!			is incremented on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

LOCAL
    text	: $STR_DESCRIPTOR (CLASS = DYNAMIC),
    member	: REF crx_member,
    mbr_idx	: INITIAL(0),
    type	: REF $STR_DESCRIPTOR ();

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

! Get field addressibility via REF.

member      = .p_tree;

DO BEGIN
    mbr_idx = .mbr_idx + 1;     
	
    $FAO_PUT (0, ' ');
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Member node: !SL at !XL:',
	.mbr_idx, .member);
    $FAO_PUT (.depth, 'Previous: !XL', .member [CRM$A_PREVIOUS]);
    $FAO_PUT (.depth, 'Next: !XL', .member [CRM$A_NEXT]);
    %ELSE
    $FAO_PUT (.depth, 'Member node: !SL at !OL:',
	.mbr_idx, .member);
    $FAO_PUT (.depth, 'Previous: !OL', .member [CRM$A_PREVIOUS]);
    $FAO_PUT (.depth, 'Next: !OL', .member [CRM$A_NEXT]);
    %FI
    $FAO_PUT (.depth, 'Id: !SB', .member [CRM$B_ID]);
    $FAO_PUT (.depth, 'Description Count: !SB',
	.member [CRM$B_DESCRIPTION_CNT]);
    $FAO_PUT (.depth, 'Source Len: !SW', .member [CRM$W_SOURCE_LENGTH]);
    $FAO_PUT (.depth, 'Ref Len: !SW', .member [CRM$W_REF_LENGTH]);
    $FAO_PUT (.depth, 'Children Count: !SW',
	.member [CRM$W_CHILDREN_CNT]);
    $FAO_PUT (.depth, 'Tag variable count: !SB',
	.member [CRM$B_TAG_VARIABLE_CNT]);
    $FAO_PUT (.depth, 'Dimensions cnt: !SB',
	.member [CRM$B_DIMENSIONS_CNT]);
    $STR_DESC_INIT (DESCRIPTOR = text, CLASS = DYNAMIC);
    $STR_COPY (string = (.member [CRM$B_NAME_LENGTH],
	ch$ptr (member [CRM$T_NAME])), target = text);
    $FAO_PUT (.depth, 'Member name: !AS', text);
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Description: !XL', .member [CRM$A_DESCRIPTION]);
    $FAO_PUT (.depth, 'Source type: !XL', .member [CRM$A_SOURCE_TYPE]);
    $FAO_PUT (.depth, 'Reference: !XL', .member [CRM$A_REFERENCE]);
    $FAO_PUT (.depth, 'Children: !XL', .member [CRM$A_CHILDREN]);
    $FAO_PUT (.depth, 'Tag variable: !XL', .member [CRM$A_TAG_VARIABLE]);
    %ELSE
    $FAO_PUT (.depth, 'Description: !OL', .member [CRM$A_DESCRIPTION]);
    $FAO_PUT (.depth, 'Source type: !OL', .member [CRM$A_SOURCE_TYPE]);
    $FAO_PUT (.depth, 'Reference: !OL', .member [CRM$A_REFERENCE]);
    $FAO_PUT (.depth, 'Children: !OL', .member [CRM$A_CHILDREN]);
    $FAO_PUT (.depth, 'Tag variable: !OL', .member [CRM$A_TAG_VARIABLE]);
    %FI
    $STR_COPY (string = (.member [CRM$W_SOURCE_LENGTH],
	.member [CRM$A_SOURCE_TYPE]), target = text);
    $FAO_PUT (.depth, 'Source: !AS', text);
    $FAO_PUT (.depth, 'Length: !SL', .member [CRM$L_LENGTH]);
    $FAO_PUT (.depth, 'Offset: !SL', .member [CRM$L_OFFSET]);
    $FAO_PUT (.depth, 'Member length: !SL', .member [CRM$L_MEMBER_LENGTH]);
    $FAO_PUT (.depth, 'Member offset: !SL', .member [CRM$L_MEMBER_OFFSET]);
    $FAO_PUT (.depth, 'String units: !SL', .member [CRM$L_STRING_UNITS]);
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Dimensions: !XL', .member [CRM$A_DIMENSIONS]);
    %ELSE
    $FAO_PUT (.depth, 'Dimensions: !OL', .member [CRM$A_DIMENSIONS]);
    %FI
    $FAO_PUT (.depth, 'Total cells: !SL', .member [CRM$L_TOTAL_CELLS]);
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Facility: !XL', .member [CRM$A_FACILITY]);
    %ELSE
    $FAO_PUT (.depth, 'Facility: !OL', .member [CRM$A_FACILITY]);
    %FI
    MORE_MEMBER (.member, .depth);	! Avoid Bliss bug!

    member = .member [CRM$A_NEXT];	! Next sibling at this level

END UNTIL .member EQLA NULL_PTR;

END;
!******************************************************************
!	       M O R E _M E M B E R 
!******************************************************************

ROUTINE MORE_MEMBER (p_tree, depth) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will finish dumping a member node.
!	This is an attempt to prevent Bliss-36 from running out of heap
!	space while compiling MEMBER_NODE.  Sigh...
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the member node.
!
!	depth.rlu.v     A (long)word containing the current
!			indentation level for the $FAO_PUT macro.  This
!			is incremented on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

BIND
    member		= p_tree : REF crx_member,
    initial_value 	= .member [CRM$A_INITIAL_VALUE],
    additional_blk 	= .member [CRM$A_FACILITY] : crx_additional;

LOCAL
    text	: $STR_DESCRIPTOR (CLASS = DYNAMIC),
    mbr_idx	: INITIAL(0),
    type	: REF $STR_DESCRIPTOR ();

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

type = GET_DATATYPE (.member [CRM$W_DATATYPE]);
$FAO_PUT (.depth, 'Datatype: !AS', .type);
$FAO_PUT (.depth, 'Digits: !SW', .member [CRM$W_DIGITS]);
$FAO_PUT (.depth, 'Max Digits: !SW', .member [CRM$W_MAX_DIGITS]);
$FAO_PUT (.depth, 'Scale: !SW', .member [CRM$W_SCALE]);
$FAO_PUT (.depth, 'Base: !SB', .member [CRM$B_BASE]);
IF .member [CRM$V_COLUMN_MAJOR]
    THEN $FAO_PUT (.depth, 'Column Major');
IF .member [CRM$V_STRING_TYPE]
    THEN $FAO_PUT (.depth, 'String type');
IF .member [CRM$V_COMPUTE_TYPE]
    THEN $FAO_PUT (.depth, 'Compute type');
IF .member [CRM$V_DEBUG_FLAG]
    THEN $FAO_PUT (.depth, 'Debug flag');
IF .member [CRM$V_FIRST_CHILD]
    THEN $FAO_PUT (.depth, 'First child flag');
IF .member [CRM$V_BLANK_WHEN_ZERO]
    THEN $FAO_PUT (.depth, 'Blank-when-zero flag');
IF .member [CRM$V_RIGHT_JUSTIFIED]
    THEN $FAO_PUT (.depth, 'Right-justified flag');
IF .member [CRM$V_SOURCE_TYPE_TRUNC]
    THEN $FAO_PUT (.depth, 'Source-type-truncated flag');
IF .member [CRM$V_REFERENCE_TRUNC]
    THEN $FAO_PUT (.depth, 'Reference-string-truncated flag');
IF .member [CRM$V_INITIAL_VALUE_TRUNC]
    THEN $FAO_PUT (.depth, 'Initial-value-truncated flag');
IF .member [CRM$A_INITIAL_VALUE] NEQA NULL_PTR
    THEN BEGIN
	$FAO_PUT (.depth, 'Initial Value: !AF',
	    .member [CRM$W_INITIAL_LENGTH],
	    .member [CRM$A_INITIAL_VALUE])
!	IF .ADDITIONAL_BLK NEQA NULL_PTR
!	    THEN SELECTONE .additional_blk [CRA$L_INITIAL_TYPE] OF
!		SET
!		[T_UNSIGNED_INTEGER]:
!		    $FAO_PUT (.depth, 'Initial value is an unsigned integer');
!		[T_SIGNED_INTEGER]:
!		    $FAO_PUT (.depth, 'Initial value is a signed integer');
!		[T_FIXED_POINT]:
!		    $FAO_PUT (.depth, 'Initial value is a fixed-point number');
!		[T_FLOATING_POINT]:
!		    $FAO_PUT (.depth, 'Initial value is a floating-point number');
!		[T_OCTAL_NUMBER]:
!		    $FAO_PUT (.depth, 'Initial value is octal');
!		[T_HEX_NUMBER]:
!		    $FAO_PUT (.depth, 'Initial value is hexadecimal');
!		[T_QUOTED_STRING]:
!		    $FAO_PUT (.depth, 'Initial value is a character string');
!		[NT_COMPLEX_NUMBER]:
!		    $FAO_PUT (.depth, 'Initial value is a complex number');
!		TES;
	END;
! Bit one is used in forming the structure of the tree.
IF .member [CRM$V_FACILITY_USE_1]
    THEN $FAO_PUT (.depth, 'Facility-use bit 1');
! Bit two is used to mark a "used" field for MOVE OTHERS MATCHING.
IF .member [CRM$V_FACILITY_USE_2]
    THEN $FAO_PUT (.depth, 'Facility-use bit 2');
! Bit 3 is used to indicate that the initial value is allocated in words.
IF .member [CRM$V_FACILITY_USE_3]
    THEN $FAO_PUT (.depth, 'Facility-use bit 3');
! Bit 4 is not used.
! Bits 5 and 6 together are used to indicate the member's origin.
$FAO_PUT (.depth, 'Facility-use bits 5 and 6: !SL',
    .member [CRM$V_FACILITY_USE_5]);

! Dump subtrees under this node:

ADDITIONAL_NODE (.member [CRM$A_FACILITY], .depth + 1);
DUMP_SUBTREE (.member [CRM$A_DESCRIPTION], .depth + 1);
DUMP_SUBTREE (.member [CRM$A_REFERENCE], .depth + 1);
DUMP_SUBTREE (.member [CRM$A_TAG_VARIABLE], .depth + 1);
DUMP_SUBTREE (.member [CRM$A_DIMENSIONS], .depth + 1);
DUMP_SUBTREE (.member [CRM$A_CHILDREN], .depth + 1);

END;
!******************************************************************
!	       A D D I T I O N A L _ N O D E
!******************************************************************

ROUTINE ADDITIONAL_NODE (p_tree, depth) : NOVALUE =
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump the facility-specific DIU additional
!	information block associated with each member node.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the additional node
!
!	depth.rlu.v	A (long)word containing the current indentation
!			level for the $FAO_PUT macro.  This is incremented
!			on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

LOCAL
    type	: REF $STR_DESCRIPTOR (),
    add_blk	: REF crx_additional;

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

! Get field addressibility via REF.

add_blk = .p_tree;

$FAO_PUT (0, ' ');
%IF %BLISS (BLISS32) %THEN
$FAO_PUT (.depth, 'Additional block at !XL:', .add_blk);
$FAO_PUT (.depth, 'Source locator: !XL', .add_blk [CRA$L_LOCATOR]);
%ELSE
$FAO_PUT (.depth, 'Additional block at !OL:', .add_blk);
$FAO_PUT (.depth, 'Source locator: !OL', .add_blk [CRA$L_LOCATOR]);
%FI
$FAO_PUT (.depth, 'Alignment token type: !SL', .add_blk [CRA$L_ALIGNMENT]);
$FAO_PUT (.depth, 'Field type: !SL', .add_blk [CRA$L_TYPE]);
$FAO_PUT (.depth, 'Max. member length: !SL',
    .add_blk [CRA$L_MAX_MEMBER_LENGTH]);
$FAO_PUT (.depth, 'Initial value type: !SL', .add_blk [CRA$L_INITIAL_TYPE]);
$FAO_PUT (.depth, 'Initial value type (real part): !SL',
    .add_blk [CRA$L_INITIAL_TYPE_1]);
$FAO_PUT (.depth, 'Initial value type (imaginary part): !SL',
    .add_blk [CRA$L_INITIAL_TYPE_2]);
$FAO_PUT (.depth, 'Initial value length (real part): !SL',
    .add_blk [CRA$L_INITIAL_LENGTH_1]);
IF .add_blk [CRA$V_ALIGNMENT_EXISTS]
    then $FAO_PUT (.depth, 'Alignment-exists flag');
IF .add_blk [CRA$V_LENGTH_SET]
    then $FAO_PUT (.depth, 'Length-set flag');
IF .add_blk [CRA$V_OFFSET_SET]
    then $FAO_PUT (.depth, 'Offset-set flag');
IF .add_blk [CRA$V_DIMENSION]
    then $FAO_PUT (.depth, 'Dimension-seen flag');
IF .add_blk [CRA$V_SYNC_LEFT]
    then $FAO_PUT (.depth, 'Synchronized left');
IF .add_blk [CRA$V_SYNC_RIGHT]
    then $FAO_PUT (.depth, 'Synchronized right');

END;
!******************************************************************
!	       O V E R L A Y _ N O D E 
!******************************************************************

ROUTINE OVERLAY_NODE (p_tree, depth) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump an overlay node.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the overlay node.
!
!	depth.rlu.v     A (long)word containing the current
!			indentation level for the $FAO_PUT macro.  This
!			is incremented on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

LOCAL
    overlay	: REF crx_overlay,
    mbr_idx	: INITIAL(0);

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

! Get field addressibility via REF.

overlay     = .p_tree;

DO BEGIN
    mbr_idx = .mbr_idx + 1;

    $FAO_PUT (0, ' ');
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Overlay node: !SL at !XL:',
	.mbr_idx, .overlay);
    $FAO_PUT (.depth, 'Previous: !XL', .overlay [CRO$A_PREVIOUS]);
    $FAO_PUT (.depth, 'Next: !XL', .overlay [CRO$A_NEXT]);
    %ELSE
    $FAO_PUT (.depth, 'Overlay node: !SL at !OL:',
	.mbr_idx, .overlay);
    $FAO_PUT (.depth, 'Previous: !OL', .overlay [CRO$A_PREVIOUS]);
    $FAO_PUT (.depth, 'Next: !OL', .overlay [CRO$A_NEXT]);
    %FI
    $FAO_PUT (.depth, 'Id: !SB', .overlay [CRO$B_ID]);
    $FAO_PUT (.depth, 'Fields cnt: !SW', .overlay [CRO$W_FIELDS_CNT]);
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Fields: !XL', .overlay [CRO$A_FIELDS]);
    %ELSE
    $FAO_PUT (.depth, 'Fields: !OL', .overlay [CRO$A_FIELDS]);
    %FI
    $FAO_PUT (.depth, 'Max length: !SL', .overlay [CRO$L_MAX_LENGTH]);
    $FAO_PUT (.depth, 'Min offset: !SL', .overlay [CRO$L_MIN_OFFSET]);
    $FAO_PUT (.depth, 'Max member length: !SL',
	.overlay [CRO$L_MAX_MEMBER_LENGTH]);
    $FAO_PUT (.depth, 'Min member offset: !SL',
	.overlay [CRO$L_MIN_MEMBER_OFFSET]);
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Tag values: !XL', .overlay [CRO$A_TAG_VALUES]);
    %ELSE
    $FAO_PUT (.depth, 'Tag values: !OL', .overlay [CRO$A_TAG_VALUES]);
    %FI
    $FAO_PUT (.depth, 'Tag values cnt: !SW', .overlay [CRO$W_TAG_VALUES_CNT]);
    $FAO_PUT (.depth, 'Total length: !SL', .overlay [CRO$L_TOTAL_LENGTH]);

    DUMP_SUBTREE (.overlay [CRO$A_TAG_VALUES], .depth + 1);
    DUMP_SUBTREE (.overlay [CRO$A_FIELDS], .depth + 1);

    overlay = .overlay [CRO$A_NEXT];	! On to the next sibling

END UNTIL .overlay EQLA NULL_PTR;

END;
!******************************************************************
!	       D I M E N S I O N _ N O D E 
!******************************************************************

ROUTINE DIMENSION_NODE (p_tree, depth) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump a dimension node.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the dimension node.
!
!	depth.rlu.v     A (long)word containing the current
!			indentation level for the $FAO_PUT macro.  This
!			is incremented on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

LOCAL
    dimension	: REF crx_dimension,
    mbr_idx	: INITIAL(0);

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

! Get field addressibility via REF.

dimension   = .p_tree;

DO BEGIN
    mbr_idx = .mbr_idx + 1;

    $FAO_PUT (0, ' ');
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Dimension node !SL at !XL:',
	.mbr_idx, .dimension);
    $FAO_PUT (.depth, 'Previous: !XL', .dimension [CRD$A_PREVIOUS]);
    $FAO_PUT (.depth, 'Next: !XL', .dimension [CRD$A_NEXT]);
    %ELSE
    $FAO_PUT (.depth, 'Dimension node !SL at !OL:',
	.mbr_idx, .dimension);
    $FAO_PUT (.depth, 'Previous: !OL', .dimension [CRD$A_PREVIOUS]);
    $FAO_PUT (.depth, 'Next: !OL', .dimension [CRD$A_NEXT]);
    %FI
    $FAO_PUT (.depth, 'Id: !SB', .dimension [CRD$B_ID]);
    $FAO_PUT (.depth, 'Depend item cnt: !SB',
	.dimension [CRD$B_DEPEND_ITEM_CNT]);
    $FAO_PUT (.depth, 'Low bound: !SL', .dimension [CRD$L_LOWER_BOUND]);
    $FAO_PUT (.depth, 'Upper bound: !SL', .dimension [CRD$L_UPPER_BOUND]);
    $FAO_PUT (.depth, 'Stride: !SL', .dimension [CRD$L_STRIDE]);
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Depend item: !XL', .dimension [CRD$A_DEPEND_ITEM]);
    %ELSE
    $FAO_PUT (.depth, 'Depend item: !OL', .dimension [CRD$A_DEPEND_ITEM]);
    %FI
    $FAO_PUT (.depth, 'Min occurs: !SL', .dimension [CRD$L_MIN_OCCURS]);
    IF .dimension [CRD$V_LOWER_BOUND_FL]
	THEN $FAO_PUT (.depth, 'Lower-bound flag');
    IF .dimension [CRD$V_UPPER_BOUND_FL]
	THEN $FAO_PUT (.depth, 'Upper-bound flag');
    IF .dimension [CRD$V_STRIDE_FL]
	THEN $FAO_PUT (.depth, 'Stride flag');
    IF .dimension [CRD$V_MIN_OCCURS_FL]
	THEN $FAO_PUT (.depth, 'Min-occurs flag');

    DUMP_SUBTREE (.dimension [CRD$A_DEPEND_ITEM], .depth + 1);

    dimension = .dimension [CRD$A_NEXT];	! On to the next

END UNTIL .dimension EQLA NULL_PTR; 

END;
!******************************************************************
!	       S T R I N G L I S T _ N O D E 
!******************************************************************

ROUTINE STRINGLIST_NODE (p_tree, depth) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump a stringlist node.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the record description subtree.
!
!	depth.rlu.v     A (long)word containing the current
!			indentation level for the $FAO_PUT macro.  This
!			is incremented on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

LOCAL
    text	: $STR_DESCRIPTOR (CLASS = DYNAMIC),
    stringlist	: REF crx_stringlist,
    mbr_idx	: INITIAL(0);

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

! Get field addressibility via REF.

stringlist  = .p_tree;

DO BEGIN
    mbr_idx = .mbr_idx + 1;

    $FAO_PUT (0, ' ');
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Stringlist node !SL at !XL:',
	.mbr_idx, .stringlist);
    $FAO_PUT (.depth, 'Previous: !XL', .stringlist [CRS$A_PREVIOUS]);
    $FAO_PUT (.depth, 'Next: !XL', .stringlist [CRS$A_NEXT]);
    %ELSE
    $FAO_PUT (.depth, 'Stringlist node !SL at !OL:',
	.mbr_idx, .stringlist);
    $FAO_PUT (.depth, 'Previous: !OL', .stringlist [CRS$A_PREVIOUS]);
    $FAO_PUT (.depth, 'Next: !OL', .stringlist [CRS$A_NEXT]);
    %FI
    $FAO_PUT (.depth, 'Id: !SB', .stringlist [CRS$B_ID]);
    IF .stringlist [CRS$V_STRING_TRUNC]
	THEN $FAO_PUT (.depth, 'String-truncated flag');
    IF .stringlist [CRS$V_BINARY_STRING]
	THEN $FAO_PUT (.depth, 'Binary-string flag');
    $STR_DESC_INIT (DESCRIPTOR = text, CLASS = DYNAMIC);
    $STR_COPY (string = (.stringlist [CRS$W_STRING_LENGTH],
	.stringlist [CRS$A_STRING]), target = text);
    $FAO_PUT (.depth, 'String: !AS', text);
 
    stringlist = .stringlist [CRS$A_NEXT];	! On to the next

END UNTIL .stringlist EQLA NULL_PTR;

END;
!******************************************************************
!              T A G _ F F D _ N O D E
!******************************************************************

ROUTINE TAG_FFD_NODE (p_tree, depth) : NOVALUE =
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump a tag field FFD node.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the record description subtree.
!
!	depth.rlu.v	A (long)word containing the current
!			indentation level for the $FAO_PUT macro.  This
!			is incremented on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

LOCAL
    tag_ffd	: REF crx_tag_ffd;

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

! Get field addressability via REF.

tag_ffd = .p_tree;

$FAO_PUT (0, ' ');
%IF %BLISS (BLISS32) %THEN
$FAO_PUT (.depth, 'Tag FFD node at !XL:', .tag_ffd);
$FAO_PUT (.depth, 'Previous: !XL', .tag_ffd [CRT$A_PREVIOUS]);
$FAO_PUT (.depth, 'Next: !XL', .tag_ffd [CRT$A_NEXT]);
%ELSE
$FAO_PUT (.depth, 'Tag FFD node at !OL:', .tag_ffd);
$FAO_PUT (.depth, 'Previous: !OL', .tag_ffd [CRT$A_PREVIOUS]);
$FAO_PUT (.depth, 'Next: !OL', .tag_ffd [CRT$A_NEXT]);
%FI
$FAO_PUT (.depth, 'Id: !UB', .tag_ffd [CRT$B_ID]);
IF .tag_ffd [CRT$V_SUSPICIOUS_TAG]
    THEN $FAO_PUT (.depth, 'Suspicious-tag flag');
%IF %BLISS (BLISS32) %THEN
$FAO_PUT (.depth, 'Unit: !XL', .tag_ffd [CRT$V_UNIT]);
%ELSE
$FAO_PUT (.depth, 'Unit: !OL', .tag_ffd [CRT$V_UNIT]);
%FI
$FAO_PUT (.depth, 'Length: !ZL', .tag_ffd [CRT$V_LENGTH]);
$FAO_PUT (.depth, 'Scale: !ZL', .tag_ffd [CRT$V_SCALE]);
$FAO_PUT (.depth, 'Offset: !ZL', .tag_ffd [CRT$V_OFFSET]);
$FAO_PUT (.depth, 'Type: !ZL:', .tag_ffd [CRT$V_TYPE]);
$FAO_PUT ((.depth+1), 'Dt_type: !ZL', .tag_ffd [CRT$V_DT_TYPE]);
$FAO_PUT ((.depth+1), 'Dt_class: !ZL', .tag_ffd [CRT$V_DT_CLASS]);
$FAO_PUT (.depth, 'Align: !ZL', .tag_ffd [CRT$V_ALIGN]);
$FAO_PUT (.depth, 'System of origin: !ZL', .tag_ffd [CRT$V_SYS_ORIG]);

END;
!******************************************************************
!	       P L I _ S P E C I F I C _ N O D E 
!******************************************************************

ROUTINE PLI_SPECIFIC_NODE (p_tree, depth) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump a PL1 specific node.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the PL1 specific node.
!
!	depth.rlu.v     A (long)word containing the current
!			indentation level for the $FAO_PUT macro.  This
!			is incremented on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

LOCAL
    text	: $STR_DESCRIPTOR (CLASS = DYNAMIC),
    pli		: REF crx_pli_specific;

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

! Get field addressibility via REF.

pli	    = .p_tree;

$FAO_PUT (0, ' ');
%IF %BLISS (BLISS32) %THEN
$FAO_PUT (.depth, 'PL/1 Specific node at !XL:', .p_tree);
$FAO_PUT (.depth, 'Previous: !XL', .pli [CRX_PLI$A_PREVIOUS]);
%ELSE
$FAO_PUT (.depth, 'PL/1 Specific node at !OL:', .p_tree);
$FAO_PUT (.depth, 'Previous: !OL', .pli [CRX_PLI$A_PREVIOUS]);
%FI
$FAO_PUT (.depth, 'Mbz: !SL', .pli [CRX_PLI$L_MBZ]);
$FAO_PUT (.depth, 'Id:  !SB', .pli [CRX_PLI$B_ID]);
!text [STR$H_LENGTH] = .pli [CRX_PLI$B_NAME_LENGTH];
!text [STR$A_POINTER] = .pli [CRX_PLI$A_NAME_STRING];
!$FAO_PUT (.depth, 'PL/1 Name: !AS', text);
!text [STR$H_LENGTH] = .pli [CRX_PLI$W_PICTURE_LENGTH];
!text [STR$A_POINTER] = .pli [CRX_PLI$A_PICTURE];
!$FAO_PUT (.depth, 'PL/1 Picture: !AS', text);

END;
!******************************************************************
!	       L I T E R A L _ L I S T _ N O D E 
!******************************************************************

ROUTINE LITERAL_LIST_NODE (p_tree, depth) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump a literal list node.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the literal list node.
!
!	depth.rlu.v     A (long)word containing the current
!			indentation level for the $FAO_PUT macro.  This
!			is incremented on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

LOCAL
    lit_idx	: INITIAL (0),
    litlist	: REF crx_literal_list;

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

! Get field addressability via REF.

litlist = .p_tree;

DO BEGIN
    lit_idx = .lit_idx + 1;
    $FAO_PUT (0, ' ');
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Literal list !SL at: !XL', .lit_idx, .litlist);
    $FAO_PUT (.depth, 'Previous: !XL', .litlist [CRL$A_PREVIOUS]);
    $FAO_PUT (.depth, 'Next: !XL', .litlist [CRL$A_NEXT]);
    %ELSE
    $FAO_PUT (.depth, 'Literal list !SL at: !OL', .lit_idx, .litlist);
    $FAO_PUT (.depth, 'Previous: !OL', .litlist [CRL$A_PREVIOUS]);
    $FAO_PUT (.depth, 'Next: !OL', .litlist [CRL$A_NEXT]);
    %FI
    $FAO_PUT (.depth, 'Id: !SB', .litlist [CRL$B_ID]);
    $FAO_PUT (.depth, 'Literals cnt: !SW', .litlist [CRL$W_LITERALS_CNT]);
    %IF %BLISS (BLISS32) %THEN
    $FAO_PUT (.depth, 'Literals: !XL', .litlist [CRL$A_LITERALS]);
    %ELSE
    $FAO_PUT (.depth, 'Literals: !OL', .litlist [CRL$A_LITERALS]);
    %FI

    DUMP_SUBTREE (.litlist [CRL$A_LITERALS], .depth + 1);

    litlist = .litlist [CRL$A_NEXT];	! On to the next

    END UNTIL .litlist EQLA NULL_PTR;

END;
!******************************************************************
!	       D U M P _ S U B T R E E 
!******************************************************************

ROUTINE DUMP_SUBTREE (p_tree, depth) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump the DIU record description subtree 
!	to SYS$OUTPUT.   We handle formatting and indentation via 
!	the use of a depth argument.  Since we will recursively call 
!	ourselves to handle children of the current node, we increment 
!	the depth indicator prior to the call.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The address of the record description subtree.
!
!	depth.rlu.v     A (long)word containing the current
!			indentation level for the $FAO_PUT macro.  This
!			is incremented on each recursive call.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

LOCAL
    cdd_record	: REF crx_record;

IF .p_tree EQLA NULL_PTR THEN RETURN;		! Nothing to do...

! Get field addressibility via REF.

cdd_record  = .p_tree;

SELECTONE .cdd_record [CRX$B_ID] OF
SET 

    [CRX$K_RECORD] :  		RECORD_NODE (.p_tree, .depth);

    [CRX$K_MEMBER] :		MEMBER_NODE (.p_tree, .depth);

    [CRX$K_OVERLAY] :		OVERLAY_NODE (.p_tree, .depth);

    [CRX$K_DIMENSION] :		DIMENSION_NODE (.p_tree, .depth);

    [CRX$K_STRINGLIST] :	STRINGLIST_NODE (.p_tree, .depth);

    [CRX$K_PLI_SPECIFIC] :	PLI_SPECIFIC_NODE (.p_tree, .depth);

    [CRX$K_LITERAL_LIST] :	LITERAL_LIST_NODE (.p_tree, .depth);

    [CRX$K_TAG_FFD] :		TAG_FFD_NODE (.p_tree, .depth);

TES;

END;
!******************************************************************
!	           D U M P _ T R E E 
!******************************************************************

GLOBAL ROUTINE DUMP_TREE (p_tree) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump the DIU record description tree.
!	The real work is done in DUMP_SUBTREE.
!
! FORMAL PARAMETERS
!
!	p_tree.ra.r	The root address of the record description tree.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!--


DUMP_SUBTREE (.p_tree, 0);

! This does the grunt work, we pass it a zero so that we start indentation
! properly for the root node.  The routine will make recursive calls
! on itself to dump each subtree and handle indentation properly.

END;
!******************************************************************
!	              T R E E 
!******************************************************************

GLOBAL ROUTINE TREE (rectree) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine will dump a DIU record description tree.
!
! FORMAL PARAMETERS
!
!	rectree		Address of root of tree.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	None
!
!--

$XPO_OPEN (IOB = terminal, FILE_SPEC = $XPO_OUTPUT);

DUMP_TREE (.rectree);

$XPO_CLOSE (IOB = terminal);

END;

END
ELUDOM