MODULE xdump ( IDENT = 'X00.07',		%TITLE 'XDUMP - Generate Structure Dump Module'
		MAIN = FIELD_DUMP			!Entry point of main program
		%BLISS32( ,ADDRESSING_MODE( EXTERNAL=LONG_RELATIVE ) )
		) =
BEGIN

!
!			  COPYRIGHT (c) 1980 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 generates a BLISS module (<structure-name>.BLI)
!	which when used in conjunction with XDUMPR will dump the
!	contents of a requested data structure from a requested REQUIRE file.
!
!	REQUIREMENTS:
!		1.) At the beginning of the data structure a comment line
!		    must appear such that the '!' is in the first column
!	 	    and the name of the structure (upper case) follows 
!		    this. (Example: ! IOB )
!
!		2.) At the beginning of the data structure a comment line
!		    starting in the first column with the words End of <structure name>
!		    must appear. (Example: ! End of IOB )
!
! ENVIRONMENT:  User mode - multiple host operating/file systems
!
! AUTHOR:  Linda Duffell,	CREATION DATE: 9/14/79  
!
!--
!

! TABLE OF CONTENTS:
!

FORWARD ROUTINE
    FIELD_DUMP :  NOVALUE,				! Principal dumping routine
    FIND_STRUCTURE,					! Structure finding routine
    FIND_FIELD;						! Field finding routine

!
! INCLUDE FILES:
!

LIBRARY  'XPORT' ;					! Public XPORT control block and macro definitions


!
! MACROS:
!

MACRO
    SKIP( literal_string )=
        %STRING( %CHAR(10), literal_string )%;

!
! EQUATED SYMBOLS:
!

LITERAL
    true = 1,						! Used for completion codes from routines.
    false = 0,						! Used for completion codes from routines.
    true_fetch = 1,					! Used for completion codes from routines.
    true_no_fetch = 3,					! Used for completion codes from routines.
    maxlength = 6;					! Maximum length of characters in file name.

!
! OWN STORAGE:
!

OWN
    code,						! Value returned from a routine

    tty_input :  $XPO_IOB(),				! IOB for  input from terminal
    tty_output :  $XPO_IOB(),				! IOB for output to terminal
    input_file :  $XPO_IOB(),				! IOB for input file
    output_file :  $XPO_IOB(),				! IOB for output file

    file_name :  $STR_DESCRIPTOR (),			! String descriptor for file name
    message : $STR_DESCRIPTOR
			( CLASS = DYNAMIC_BOUNDED ),	! String descriptor for message
    field_name :  $STR_DESCRIPTOR
			( CLASS = FIXED ),		! String descriptor for field name
    field_type :  $STR_DESCRIPTOR
			( CLASS = FIXED );		! String descriptor for field type


!
! EXTERNAL REFERENCES:
!


ROUTINE FIELD_DUMP :  NOVALUE = 

!++
!
! FUNCTIONAL DESCRIPTION:
!
!
!	This routine requests the name of a REQUIRE file and a data structure.
!	If the structure is found then a BLISS module (<structure-name>.BLI)
!	is created in a format readable by XDUMP.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! COMPLETION CODES:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

!
! Initialize the STRING DESCRIPTORS.
!

    $STR_DESC_INIT( DESCRIPTOR = message, CLASS = DYNAMIC_BOUNDED );

!
! Open the user's terminal for input and output.
!

    $XPO_OPEN( IOB = tty_input,				! Open the user's terminal		
	        FILE_SPEC = $XPO_INPUT,			!    standard input file
		OPTIONS = INPUT );			

    $XPO_OPEN( IOB = tty_output,			! Open the users's terminal
		FILE_SPEC = $XPO_OUTPUT,		!    standard output file
		OPTIONS = OUTPUT );			

!
! Request the name of the REQUIRE file and open that file.
!

    WHILE 1 DO						! Keep asking until an input file can be opened.
	BEGIN
	IF NOT $XPO_GET( IOB = tty_input,		! Read a file name from the terminal
         PROMPT = ( skip('BLISS REQUIRE file name (default = .REQ)? ')))
	THEN						! If terminal end-of-file (^Z) is reached,
	    RETURN XPO$_NORMAL;				! terminate program execution.

	IF $XPO_OPEN( IOB = input_file,			! Open the specified input file:
		FILE_SPEC =				!    input file-spec descriptot
		    tty_input[IOB$T_STRING],
		DEFAULT = ('.REQ'),
		OPTIONS = INPUT,			
		FAILURE = XPO$IO_FAILURE )		
	THEN						! If the input file was successfully opened,
	    EXITLOOP;					! exit the file open loop.
	END;

!
! Request the name of the structure.
!

    IF NOT $XPO_GET( IOB = tty_input,			! Read a file name from the terminal.
	PROMPT = ( skip('Name of structure? ') ) )
    THEN
	RETURN XPO$_NORMAL;				! If terminal end of file (^Z) is reached,
							! terminate program execution.

!
! Save name in upper case.
!

    $STR_COPY( STRING = tty_input[IOB$T_STRING],		
		TARGET = tty_input[IOB$T_STRING],
		OPTIONS = UP_CASE );

!
! Read file and search for structure name.
!

    WHILE 1 DO						! Keep reading the file
	BEGIN						!
	IF NOT $XPO_GET( IOB = input_file )		!
	THEN						!
	    $XPO_PUT_MSG( CODE = XPO$_END_FILE,		! Until end-of-file is reached
		STRING = 'Structure name not found. ',	!
		SEVERITY = FATAL );			!
							!
	IF FIND_STRUCTURE( input_file[IOB$T_STRING],	!
			  tty_input[IOB$T_STRING] )	!
	THEN						!
	    EXITLOOP					! or the requested structure is found.
	END;

!
! Save the file name ( first 6 characters )
!

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

    $STR_COPY( STRING = ( MIN(.tty_input[IOB$H_STRING],maxlength),
				.tty_input[IOB$A_STRING] ),
		TARGET = file_name );

!
! Open the output file.   The name of the output file will be the given
! structure name (first 6 characters) and the extension will be .BLI.
!

    $XPO_OPEN( IOB = output_file,					
		  FILE_SPEC = file_name,
		  DEFAULT = '.BLI',
		  OPTIONS = OUTPUT );

!
! Write out the module prologue to the file.
!

    $XPO_PUT( IOB = output_file,			! Output:  MODULE <structure-name> = BEGIN
		STRING = $STR_CONCAT( 'MODULE ',
				file_name,
				' %BLISS36( (ENTRY(',
				file_name,
				')) ) = BEGIN' ) );

    $XPO_PUT( IOB = output_file,			! Output:  LIBRARY 'BLI:XPORT';
		STRING = 'LIBRARY ''BLI:XPORT'';' );

    $XPO_PUT( IOB = output_file,			! Output:  REQUIRE '<require-file-name>';
		STRING = $STR_CONCAT( 'REQUIRE ''',
				input_file[IOB$T_RESULTANT],
				''';' ) );

    $XPO_PUT( IOB = output_file,			! Output:  %BLISS32( PSECT OWN=$CODE$; )
		STRING = '%BLISS32( PSECT OWN=$CODE$; )' );

    $XPO_PUT( IOB = output_file,			! Output:  'GLOBAL ROUTINE <structure-name>
		STRING = $STR_CONCAT( 'GLOBAL ROUTINE ',	!		(control block) :  NOVALUE = BEGIN
				    file_name,
				    '(control_block) :  NOVALUE = BEGIN') );

    $XPO_PUT( IOB = output_file, STRING = '' );

!
! Read through structure searching for fields.
!

    WHILE 1 DO					
	BEGIN
	IF NOT $XPO_GET( IOB = input_file)		! Keep reading file
	THEN
	    EXITLOOP;					! until end-of-file 

	IF CH$RCHAR(.input_file[IOB$A_STRING]) EQL %C'!'
	THEN
	    IF $STR_SCAN( STRING = input_file[IOB$T_STRING],
	    		FIND = $STR_CONCAT( 'End of ', tty_input[IOB$T_STRING] ) )
	    THEN
		EXITLOOP;				! or the end of structure is reached

	code = FIND_FIELD( input_file[IOB$T_STRING],	! Obtain the field name and field type
			  field_name,field_type );
	IF .code
	THEN
	    BEGIN					! Here if fields were found
	    $STR_COPY( STRING = $STR_CONCAT( '$XPO_DUMP_FIELD( FIELD_NAME=',
					 field_name,
					 ', TYPE=',
					 field_type ),
			TARGET = message );


	    IF .code EQL true_fetch			! If fields have been found and 
	    THEN					! fetch parameter is to be included.
		$STR_APPEND( STRING = 
		  (', VALUE=.BLOCK[.control_block,'),
			    TARGET = message )
	    ELSE					! Else, do not include fetch parameter
		$STR_APPEND( STRING = 
  		  (', VALUE=BLOCK[.control_block,'),
			    TARGET = message );

	    $STR_APPEND( STRING = $STR_CONCAT( field_name, '] );' ),
			    TARGET = message );
	    
	    $XPO_PUT( IOB = output_file,
			STRING = message );
	    END;
	END;
    $XPO_PUT( IOB = output_file, STRING = '' );

    $XPO_PUT( IOB = output_file,			! Write epilogue to file.
		STRING = 'END;  END  ELUDOM ' );
    $XPO_CLOSE( IOB = output_file );			! Close output file.

    $XPO_PUT( IOB = tty_output,				! Tell user about success
	   	STRING = $STR_CONCAT( .output_file[IOB$A_FILE_SPEC],
				    '.BLI display module generated ' ) );
    END;


ROUTINE FIND_STRUCTURE( source_line, structure_name )=

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine searches a file for a given structure name.
!
!	Restrictions:
!		A comment line with the '!' being the first
!		character followed by the structure name in
!		upper case must precede the data structure.
!
! FORMAL PARAMETERS:
!
!	source_line - string descriptor of the line to search through - READ ONLY PRIVILEGES 
!	structure_name - string descriptor of requested structure name - READ ONLY PRIVILEGES
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! COMPLETION CODE
!
!	true - If structure name is found.
!	false - If structure name is not found.
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    MAP
	source_line :  REF $STR_DESCRIPTOR(),
	structure_name :  REF $STR_DESCRIPTOR();

    LOCAL

	local_source :  $STR_DESCRIPTOR( CLASS = BOUNDED ),	! Used to point to string passed by caller
	value;							! Used to store value of this routine

!
! Initialize the lexeme descriptor block.
!

    $STR_DESC_INIT( DESCRIPTOR = local_source,			! Point to string passed by caller
		    CLASS = BOUNDED,
		    STRING = .source_line );

!
! Assume this routine is false until proven otherwise.
!

    value = false;

!
! Looks for '! <structure name> ' at the beginning of the line.
!

    IF .source_line[STR$H_LENGTH] NEQ 0			! Make sure line is not null
    THEN
	IF CH$RCHAR( .local_source[STR$A_POINTER] ) EQL %C'!'		
	THEN
	    BEGIN
	    $STR_SCAN( REMAINDER = local_source,
			SPAN = '!	 ',
			SUBSTRING= local_source );
	    
	    $STR_SCAN( REMAINDER = local_source,
			STOP = '	 ',
			SUBSTRING = local_source );

	    value = $STR_EQL( STRING1 = local_source,		! Check if the lexeme matches the structure name
				   STRING2 =.structure_name );
	    END;
	    
!
! Return to caller the results of finding the structure name.
!
    RETURN .value

    END;


ROUTINE FIND_FIELD( line_desc,name_desc,type_desc )=

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine searches for both the field name and field type and
!	updates the corresponding descriptors. 
!
!
! FORMAL PARAMETERS:
!
!	line_desc - string descriptor of line to search through - READ ONLY PRIVILEGES
!	name-desc - string descriptor for storage of the field name - READ & WRITE PRIVILEGES
!	type-desc - string descriptor for storage of the field type - READ & WRITE PRIVILEGES
!
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	false - If either the field name or field type is not found.
!
!	true_fetch - If both the field name and type  are found and it does
!	    require the fetch parameter.
!
!	true_no_fetch - If both the field name and type are found and it doesn't
!	    require the fetch parameter.
!
!
! SIDE EFFECTS:
!
!	None
!
!--


    BEGIN
    MAP
	line_desc :  REF $STR_DESCRIPTOR(),
	name_desc :  REF $STR_DESCRIPTOR( CLASS = FIXED ),
	type_desc :  REF $STR_DESCRIPTOR( CLASS = FIXED );

    LABEL
	exit_search;

    LOCAL
	value,							! Storage area for routine value
	local_line_desc :  $STR_DESCRIPTOR( CLASS = BOUNDED );	

!
! Initialize the lexeme descriptor block.
!

    $STR_DESC_INIT( DESCRIPTOR = local_line_desc,		! Point to string passed by caller
		    CLASS = BOUNDED,
		    STRING = .line_desc );


!		
! Assume routine is false until proven otherwise.
!

    value = false;

!
! Get field name.
!
  exit_search:
    BEGIN
    WHILE 1 DO
        BEGIN
        IF $STR_SCAN( REMAINDER = local_line_desc,		! Ignore spaces and tabs
			SPAN = '	 ',
			SUBSTRING = local_line_desc ) NEQ STR$_NORMAL
	THEN
	    LEAVE exit_search;

	IF $STR_SCAN( REMAINDER = local_line_desc,		! Point to the field name
			STOP = '	 =',
			SUBSTRING = local_line_desc ) NEQ STR$_NORMAL
        THEN
            LEAVE exit_search;

        IF NOT $STR_EQL( STRING1 = local_line_desc,		! $FIELD and FIELD are not valid field names
    		          STRING2 = '$FIELD' ) AND
           NOT $STR_EQL( STRING1 = local_line_desc,
		          STRING2 = 'FIELD' )
        THEN
            EXITLOOP;
        END;

!
! Update the field name descriptor.
!

    $STR_DESC_INIT( DESCRIPTOR = .name_desc,
		    CLASS = FIXED,
		    STRING = local_line_desc );

!
! Find the field type
!

    IF $STR_SCAN( REMAINDER = local_line_desc, FIND = '[' )	! Make sure this is a Field and not a Literal
						NEQ STR$_NORMAL	! declaration
    THEN
	LEAVE exit_search;
	
    IF $STR_SCAN( REMAINDER = local_line_desc,			! Point to the field type
			STOP = '$',
			SUBSTRING = local_line_desc ) NEQ STR$_NORMAL
    THEN
	LEAVE exit_search;

    IF $STR_SCAN( REMAINDER = local_line_desc,
			STOP = ' (]',
			SUBSTRING = local_line_desc ) NEQ STR$_NORMAL
    THEN
        LEAVE exit_search;

!
! Update the field type.
!

    $STR_DESC_INIT( DESCRIPTOR = .type_desc,
		    CLASS = FIXED,
		    STRING = (.local_line_desc[STR$H_LENGTH] - 1,
		  CH$PLUS(.local_line_desc[STR$A_POINTER],1)) );	! Get rid of '$' 

    IF $STR_EQL( STRING1 = .type_desc,
		   STRING2 = ('SUB_BLOCK') ) OR
      $STR_EQL( STRING1 = .type_desc,
		  STRING2 = ('DESCRIPTOR') ) OR
      $STR_EQL( STRING1 = .type_desc,
		  STRING2 = ('STRING') )
    THEN
	value = true_no_fetch
    ELSE
	value = true_fetch;
  END;								! End of exit_search

  RETURN .value
  END;


    END
ELUDOM