Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/t20src/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