MODULE XDUMPF ( IDENT = 'V1.2-10'		%TITLE 'XPO$DUMP_FIELD - XPORT Control Block Dumper'
		%BLISS32( ,ADDRESSING_MODE( EXTERNAL=LONG_RELATIVE ) )
		%BLISS36( ,ENTRY( XPO$DUMP_FIELD ),OTS='' )
		) =
BEGIN

!
!			  COPYRIGHT (c) 1983 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:  BLISS Library
!
! ABSTRACT:
!
!	This module dumps the contents of a single control block field
!	to the user's terminal.
!
! ENVIRONMENT:  User mode - multiple host operating/file systems
!
! AUTHOR:  Ward Clark,	CREATION DATE:  29 May 1979
!
!--

!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE
    XPO$DUMP_FIELD :  NOVALUE;				! Control block field dumper

!
! INCLUDE FILES:
!

LIBRARY  'XPORT' ;					! Public XPORT control block and macro definitions
LIBRARY  'XPOSYS' ;					! Internal XPORT macro definitions
UNDECLARE $xpo$internal;				! Cause XPORT temporary strings to be freed

    $XPO_SYS_TEST( $ALL )

!
! MACROS:
!

MACRO
    add_text( string_info ) =
	%EXPAND $STR_APPEND( STRING = string_info,
				TARGET = message,
				FAILURE = 0 ) %;

!
! EQUATED SYMBOLS:
!

!
! PSECT DECLARATIONS:
!

    $XPO_PSECTS						! Declare XPORT PSECT names and attributes

!
! OWN STORAGE:
!

OWN
    message :						! Message descriptor
	  $STR_DESCRIPTOR( CLASS=DYNAMIC_BOUNDED ),

    message_iob :  $XPO_IOB(),

    apostrophe :  $STR_DESCRIPTOR( STRING = '''' );

!
! EXTERNAL REFERENCES:
!

GLOBAL ROUTINE XPO$DUMP_FIELD ( field_name, field_type, field_value ) :  NOVALUE =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine displays the content of a single control block field.
!
! FORMAL PARAMETERS:
!
!	field_name - address of field name descriptor
!	field_type - field type code
!	field_value - value associated with the field (type-dependent)
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    BIND
	descriptor = .field_value :  $STR_DESCRIPTOR( CLASS = BOUNDED );

    LOCAL
	data_type,					! Local field data type code
	value;						! Local field value

    $LITERAL						! Internal data types:
	binary_desc = -$DISTINCT,			!    binary data descriptor
	ref_binary_desc = -$DISTINCT,			!    REF binary data descriptor
	invalid_desc = -$DISTINCT,			!    invalid descriptor
	ref_invalid_desc = -$DISTINCT;			!    REF invalid descriptor

!
! Open the message output IOB if necessary.
!

    IF NOT .message_iob[IOB$V_OPEN]			! If the message IOB has not been opened,
    THEN						!
	BEGIN						!
	$XPO_OPEN( IOB = message_iob,			! open the message file for output
		FILE_SPEC = $XPO_OUTPUT,		!
		OPTIONS = OUTPUT,			!
		FAILURE = 0 );				!
							!
	$STR_DESC_INIT( DESCRIPTOR = message,		! and then initialize the message descriptor.
			CLASS = DYNAMIC_BOUNDED );
	END;

!
! Setup the local field data type code and field value.
!

    data_type = .field_type;				! Start out with the field type code.

    value = .field_value;				! Setup the default field value.

    SELECTONE .data_type OF				! Possibly select an alternate internal data type.
	SET

	[ XPO$K_DESCRIPTO ] :
	    IF .descriptor[STR$B_DTYPE] EQL XPO$K_DTYPE_BU
	    THEN
		data_type = binary_desc
	    ELSE
		IF NOT $STR_VALIDATE( descriptor )
		THEN
		    data_type = invalid_desc;

	[ XPO$K_REF_DESCR ] :
	    IF descriptor EQL 0
	    THEN
		data_type = XPO$K_ADDRESS
	    ELSE
		IF .descriptor[STR$B_DTYPE] EQL XPO$K_DTYPE_BU
		THEN
		    data_type = ref_binary_desc
		ELSE
		    IF NOT $STR_VALIDATE( descriptor )
		    THEN
			data_type = ref_invalid_desc;
	TES;


!
! Each line begins with the name of the field.
!

    $STR_COPY( STRING = .field_name, TARGET = message, FAILURE = 0 );

!
! Use the field data type to select appropriate message segments.
!

    SELECT .data_type OF
	SET

	[ XPO$K_BYTE, XPO$K_BYTES,
	  XPO$K_INTEGER,
	  XPO$K_ADDRESS, XPO$K_POINTER,
	  binary_desc, invalid_desc ] :

	    add_text( '	= ' );

	[ XPO$K_SUB_BLOCK, XPO$K_STRING ] :

	    add_text( '	begins at ' );

	[ XPO$K_BIT ] :

	    IF .value
	    THEN
		add_text( '	= on' )
	    ELSE
		add_text( '	= off' );

	[ XPO$K_BITS ] :

	    BEGIN
	    add_text( '	= %B''' );
	    add_text( $STR_ASCII(.value,BASE2) );
	    add_text( apostrophe );
	    END;

	[ XPO$K_DESCRIPTO ] :

	    add_text( '	= ''' );

	[ XPO$K_REF_DESCR ] :

	    add_text( '	= REF ''' );

	[ XPO$K_DESCRIPTO, XPO$K_REF_DESCR ] :

	    BEGIN
	    IF .descriptor[STR$B_DTYPE] EQL STR$K_DTYPE_XXX
	    THEN
		add_text( '[invalid string]' )
	    ELSE
		add_text( (.descriptor[STR$H_LENGTH], .descriptor[STR$A_POINTER]) );
	    add_text( apostrophe );
	    END;

	[ ref_binary_desc, ref_invalid_desc ] :

	    add_text( ' = REF ' );

	[ binary_desc, ref_binary_desc ] :

	    BEGIN
	    add_text( $STR_ASCII(.descriptor[STR$H_LENGTH]) );
	    add_text( ' units at ' );

	    value = .descriptor[STR$A_POINTER];		! Have the message point to the data
							! rather than to the descriptor.
	    END;

	[ invalid_desc, ref_invalid_desc ] :

	    add_text( '[invalid descriptor] at ' );

	[ XPO$K_INTEGER ] :

	    add_text( $STR_ASCII(.value) );

	[ XPO$K_BYTE, XPO$K_BYTES,
	  %BLISS16( XPO$K_ADDRESS %QUOTE , )
	  %BLISS32( XPO$K_ADDRESS %QUOTE , )
	  XPO$K_POINTER,
	  XPO$K_SUB_BLOCK, XPO$K_STRING,
	  binary_desc, ref_binary_desc,
	  invalid_desc, ref_invalid_desc ] :

	    BEGIN
%IF %BLISS(BLISS32) %THEN
	    add_text( '%X''' );
	    add_text( $STR_ASCII(.value,BASE16) );
%ELSE
	    add_text( '%O''' );
	    add_text( $STR_ASCII(.value,BASE8) );
%FI
	    add_text( apostrophe );
	    END;

	[ XPO$K_ADDRESS ] :

	    BEGIN
%IF %BLISS(BLISS36) %THEN
	    add_text( '%O''' );
	    add_text( $STR_ASCII(.value,BASE8,LENGTH=6) );
%FI
	    add_text( ' (address)' );
	    END;

	[ XPO$K_POINTER ] :

	    add_text( ' (pointer)' );

	[ XPO$K_DESCRIPTO, XPO$K_REF_DESCR, binary_desc, ref_binary_desc ] :

	    BEGIN
	    add_text( ', CLASS = ' );

	    SELECTONE .descriptor[STR$B_CLASS] OF
		SET

		[ STR$K_CLASS_Z ] :

		    add_text( 'undefined' );

		[ STR$K_CLASS_F ] :

		    add_text( 'FIXED' );

		[ STR$K_CLASS_D ] :

		    add_text( 'DYNAMIC' );

		[ STR$K_CLASS_B ] :

		    BEGIN
		    add_text( 'BOUNDED' );
		    add_text( ', maximum length = ' );
		    add_text( $STR_ASCII(.descriptor[STR$H_MAXLEN]) );
		    END;

		[ STR$K_CLASS_DB ] :

		    BEGIN
		    add_text( 'DYNAMIC_BOUNDED', TARGET = message, FAILURE =0 );
		    add_text( ', maximum length = ' );
		    add_text( $STR_ASCII(.descriptor[STR$H_MAXLEN]) );
		    END;

		[ OTHERWISE ] :

		    add_text( '[invalid class]' );

		TES;
	    END;
	TES;

!
! Output a completed message.
!

    $XPO_PUT( IOB = message_iob, STRING = message );


!
! Return to the caller.
!

    RETURN

    END;
END
ELUDOM