Google
 

Trailing-Edge - PDP-10 Archives - bb-h138f-bm - 7-sources/diuau1.bli
There are 4 other files named diuau1.bli in the archive. Click here to see a list.
MODULE DIUAU1 (%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.

!++
!
!  TITLE:  ACTUTL 			DDL and Transform Action Utilities
!
!  FACILITY:  DIU
!
!  ABSTRACT:
!
!	This module contains utility routines used by the parser action
!	routines in ACTION.BLI.
!
!  ENVIRONMENT:
!
!	All routines run in user access mode.
!
!	These routines are NOT AST reentrant.
!
!  AUTHOR:  Charlotte Richardson,	1-Feb-85
!
! MODIFICATION HISTORY:
!
!  253  Rename file to DIUAU1.
!       Gregory A. Scott 1-Jul-86
!
!  236  Change library of DIXLIB to DIUDIX.
!       Sandy Clemens  19-Jun-86
!
!  145  Fix FREE_STRINGLIST so that if zero is passed to it, it won't
!       try to release the memory...
!       Sandy Clemens 7-May-86
! 
!	1	Charlotte Richardson	30-May-85
!		Teach FREE_STRINGLIST and friends to deal with CRX_TAG_FFD
!		nodes.
!--
! INCLUDE FILES:

    REQUIRE 'DIUPATPROLOG';		! General module prologue
    LIBRARY 'DIUPATTOKEN';              ! Token manipulation
    LIBRARY 'DIUPATDATA';               ! Shared specification
    LIBRARY 'DIUDEB';			! Debugging
    LIBRARY 'DIUPATLANGSP';		! Language Specific function
    LIBRARY 'DIUPATPARSER';
    LIBRARY 'BLI:XPORT';		! Transportable data structures
    LIBRARY 'DIUACTION';                ! Structures unique to semantic actions
    LIBRARY 'DIUDIX';			! Define data conversion codes
%IF %BLISS (BLISS32) %THEN
    UNDECLARE %QUOTE $DESCRIPTOR;	! Clean up after XPORT
%FI
    LIBRARY 'DIUCRX';			! CRX record structures
%IF %BLISS (BLISS32) %THEN
    UNDECLARE %QUOTE $DESCRIPTOR;	! Yet again...
%FI
    LIBRARY 'DIUTLB';			! Transform data structures
%IF %BLISS (BLISS32) %THEN
    UNDECLARE %QUOTE $DESCRIPTOR;	! Clean up after XPORT
%FI
    LIBRARY 'DIUMLB';			! Datatype mapping library
%IF %BLISS (BLISS32) %THEN
    UNDECLARE %QUOTE $DESCRIPTOR;	! Clean up after XPORT
    LIBRARY 'SYS$LIBRARY:STARLET';
%FI
! TABLE OF CONTENTS:

FORWARD ROUTINE

COMPUTE_ARRAY_LENGTH: NOVALUE,	! Compute array length
COMPUTE_BYTE_SIZE,		! Compute field's byte size
COMPUTE_BYTE_SIZE_WALKER,	! Used by COMPUTE_BYTE_SIZE
COMPUTE_END_OFFSETS: NOVALUE,	! Compute offsets at end of field
COMPUTE_OFFSETS: NOVALUE,	! Compute field offsets
COMPUTE_STRIDES: NOVALUE,	! Compute array strides
COPY_RECORD,			! Copy a record template
DEAL_WITH_TRANSFORM_NAMES,	! Deal with field names used in a transform
DUPLICATE_SUBTREE,		! Duplicate a record description subtree
FIND_DATATYPE,			! Find a datatype for a field
FIND_DATATYPE_WALKER,		! Used by FIND_DATATYPE
DIU$FIND_FIELD,			! Find specified field
FIND_MATCHING_MEMBER,		! Find matching member block given name
FIND_NAMES_IN_TREES,		! Find member blocks to match names
FIX_COPY_TEMPLATE: NOVALUE,	! Map datatypes in COPY template
FIX_VARIANTS: NOVALUE,		! Complete VARIANT blocks in tree
FREE_DIMENSIONS: NOVALUE,	! Free a list of dimensions
FREE_LITLIST: NOVALUE,		! Free a list of literal lists
FREE_MEMBERS: NOVALUE,		! Releases a crx_member and all subtrees
FREE_RECORD: NOVALUE,		! Free a record and all subtrees
FREE_STRINGLIST: NOVALUE,	! Free a stringlist and all subtrees
INIT_LITERAL: NOVALUE,		! Initialize a crx_literal_list node
INIT_MEMBER: NOVALUE,		! Initialize a crx_member node
INIT_STRINGLIST: NOVALUE,	! Initialize a crx_stringlist node
MAKE_DIMS: NOVALUE,		! Make a dims structure
MAKE_FQN: NOVALUE,              ! Make an FQN structure
MAKE_TRANSFORM: NOVALUE,	! Make a transform structure
NAME_SYNTAX,			! Check field name syntax
PRODUCE_FQN,			! Produce fully-qualified name list
VALIDATE_FQN;			! Validate a fuly-qualified name list
! External routines for transform processing:

EXTERNAL ROUTINE

DIU$DEL_DIMS: NOVALUE;		! Delete a dims structure
!++
!  COMPUTE_ARRAY_LENGTH (CMTARR)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine computes the offsets created by an array.  It also calls
!	the routine which computes the stride of the array dimensions,
!	and computes the total number of elements in the array.
!
!  CALLING SEQUENCE:
!
!	COMPUTE_ARRAY_LENGTH (field_offset, field_member_offset,
!		field_blk, sys_org);
!
!  INPUT PARAMETERS:
!
!	field_offset	is the address of the offset from the beginning
!			of the parent field to where the prior field ended.
!			It is updated to reflect the end of the array.
!
!	field_member_offset	is the address of the offset from the beginning
!			of the record to where the prior field ended.
!			It is updated to reflect the end of the array.
!
!	field_blk	is the address of the field block whose offset is to
!			be defined.
!
!	sys_org		System of origin (sys_lcg or sys_8bit/sys_pro)
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	none
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
GLOBAL ROUTINE COMPUTE_ARRAY_LENGTH (FIELD_OFFSET, FIELD_MEMBER_OFFSET,
	FIELD_BLK, SYS_ORG): NOVALUE =
BEGIN
    MAP
	FIELD_BLK :	REF	CRX_MEMBER;

    BIND
	OFFSET = .FIELD_OFFSET,
	MEMBER_OFFSET = .FIELD_MEMBER_OFFSET,
	ADDITIONAL_BLK = .FIELD_BLK [crm$a_facility]: crx_additional;

    LOCAL
	BITS_LEFT,
	BYTE_SIZE,
	BYTES_LEFT,
	BYTES_PER_WORD,
	DCB_PTR :		REF crx_dimension,
	FILL_LENGTH :		INITIAL (0),
	INTEGRAL_WORDS,
	LENGTH,
	NEW_MEMBER_OFFSET :	INITIAL (0),
	NEW_OFFSET :		INITIAL (0),
	NO_ELEMENTS :		INITIAL (0),
	ONE_DIMENSION_FL :	INITIAL (FALSE);

    DEB_EVENT ('Semantic actions',
	PUT_MSG_EOL ('ACTION_RTN called COMPUTE_ARRAY_LENGTH'));
!   Compute field length allowing for field alignment and synchronization:
!   Store current member length and replace it: COMPUTE_END_OFFSETS may try to
!   recompute it, and we are only calling the offset routines to compute the
!   length of the second and succeeding elements.

    LENGTH = .FIELD_BLK [CRM$L_LENGTH];
    NEW_OFFSET = .OFFSET;
    NEW_MEMBER_OFFSET = .MEMBER_OFFSET;
    COMPUTE_OFFSETS (new_offset, new_member_offset, .field_blk, .sys_org);
    COMPUTE_END_OFFSETS (new_offset, new_member_offset, .field_blk, .sys_org);
    FIELD_BLK [CRM$L_LENGTH] = .LENGTH;
    FILL_LENGTH = .NEW_OFFSET - .OFFSET;

! NOTE: This will be the length of each element in the array (except possibly
! the first element) for all arrays EXCEPT character string arrays on 10/20
! systems which are not synchronized and which are not aligned on a datatype
! other than BIT or BYTE.  Grrr....


!   Compute number of elements and member length for simple cases:

    NO_ELEMENTS = 1;
    DCB_PTR = .FIELD_BLK [crm$a_dimensions];
    WHILE .DCB_PTR NEQU NULL_PTR DO
	BEGIN
	    NO_ELEMENTS = .NO_ELEMENTS * (.DCB_PTR [crd$l_upper_bound] -
		.DCB_PTR [crd$l_lower_bound] + 1);
	    DCB_PTR = .DCB_PTR [crd$a_next];
	END;
    FIELD_BLK [crm$l_total_cells] = .NO_ELEMENTS;
    FIELD_BLK [crm$l_member_length] = .NO_ELEMENTS * .FIELD_BLK [crm$l_length];

!   Compute length of record so far if the offset calculation is simple.
!   This will be used to correct the member length later if the offset
!   calculation is not simple or is changed by alignment.

    length = .field_blk [CRM$L_MEMBER_OFFSET] +
	.field_blk [CRM$L_MEMBER_LENGTH];
!   Compute ending field offsets (see NOTE above):

! Calculation of the ending offsets is simple if:
! 1.  This is a VAX or PRO, or
! 2.  This field is not some kind of character string, or
! 3.  This field is aligned on something other than BIT or BYTE, or
! 4.  This field is synchronized.

    IF (.sys_org EQL SYS_8BIT) OR (.sys_org EQL SYS_PRO) OR

	(NOT .field_blk [CRM$V_STRING_TYPE]) OR

	((additional_blk NEQA NULL_PTR) AND
	 (.additional_blk [CRA$V_ALIGNMENT_EXISTS]) AND
	 (.additional_blk [CRA$L_ALIGNMENT] NEQ T_BIT) AND
	 (.additional_blk [CRA$L_ALIGNMENT] NEQ T_BYTE)) OR

	((additional_blk NEQA NULL_PTR) AND
	 (.additional_blk [CRA$V_SYNC_LEFT] OR
	  .additional_blk [CRA$V_SYNC_RIGHT]))

	THEN BEGIN	! "Simple" offset calculation

	    OFFSET = .FILL_LENGTH * (.NO_ELEMENTS - 1) + .OFFSET;
	    MEMBER_OFFSET = .FILL_LENGTH * (.NO_ELEMENTS - 1) + .MEMBER_OFFSET;
	    IF (additional_blk NEQA NULL_PTR) AND
		(.additional_blk [CRA$V_SYNC_LEFT])
		THEN LENGTH = (.FILL_LENGTH - .FIELD_BLK [CRM$L_LENGTH])
		    * (.NO_ELEMENTS - 1)
		ELSE LENGTH = .MEMBER_OFFSET - .LENGTH;

	END		! Of "simple" offset calculation
! The complex offset calculation is needed for byte string arrays on 10/20
! which are BIT or BYTE aligned (or not aligned at all) and which are not
! synchronized (synchronization forces word-alignment and also causes the
! data field to end on a word boundary when slack bytes and bits are included).
! 1.  Find the byte size of the string array.
! 2.  Find how many bytes of this size fit in a word.
! 3.  Find how many bits are left in the last word containing part of the
!     first element in the string array.
! 4.  Fill this word.
! 5.  If there are more bytes, update the offsets to the end of this word.
! 6.  Account for the intregral words, if any, in the offsets.
! 7.  Compute how many bytes go in the last partial word occupied by the
!     string array.
! 8.  Update offsets to the end of the last element in the string array.

	ELSE BEGIN	! Complex offset calculation

	    byte_size = COMPUTE_BYTE_SIZE (.field_blk, .sys_org);
	    bytes_per_word = DIU$K_O_WORD / .byte_size;
	    bits_left = (DIU$K_O_WORD - (.member_offset MOD DIU$K_O_WORD))
		MOD DIU$K_O_WORD;
	    bytes_left = .field_blk [CRM$L_STRING_UNITS] * (.no_elements - 1)
		- (.bits_left / .byte_size);
	    IF .bytes_left GTR 0
		THEN BEGIN	! Won't all fit in current word
		member_offset = ((.member_offset + DIU$K_O_WORD-1)
		    / DIU$K_O_WORD) * DIU$K_O_WORD;
		offset = ((.offset + DIU$K_O_WORD-1)
		    / DIU$K_O_WORD) * DIU$K_O_WORD;
		integral_words = (.bytes_left - 1) / .bytes_per_word;
		END		! Won't all fit in current word
		ELSE BEGIN	! Will fit in current word
		    integral_words = 0;
		    bytes_left = .field_blk [CRM$L_STRING_UNITS]
			* (.no_elements - 1);
		END;		! Will fit in current word
	    member_offset = .member_offset + (.integral_words * DIU$K_O_WORD);
	    offset = .offset + (.integral_words * DIU$K_O_WORD);
	    bytes_left = .bytes_left - (.integral_words * .bytes_per_word);
	    member_offset = .member_offset + (.bytes_left * .byte_size);
	    offset = .offset + (.bytes_left * .byte_size);
	    length = .member_offset - .length;

	END;		! Of complex offset calculation

!   Update member_length in case the offset was complex or the field
!   was aligned or synchronized left:

    field_blk [crm$l_member_length] = .field_blk [crm$l_member_length]
	+ .length;
!   See if array is one-dimensional:

    IF .FIELD_BLK [crm$b_dimensions_cnt] EQL 1
	THEN ONE_DIMENSION_FL = TRUE;

!   Compute dimension strides:

    COMPUTE_STRIDES (.FIELD_BLK [crm$a_dimensions], .FILL_LENGTH,
	.ONE_DIMENSION_FL, .FIELD_BLK [crm$v_column_major]);

END;
!++
!  COMPUTE_BYTE_SIZE (CMTBSZ)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine computes the applicable byte size for aligning a field.
!	For a VAX or PRO, the result is always 8.
!	For a 10/20, the result is:
!		The byte size of the field in question, if it has one
!		The byte size of the first child of the filed found by a
!			depth-first search, if any
!		The byte size of the innermost encompassing structure which
!			has a byte size, if any
!		6 (for SIXBIT, the COBOL default), if no byte size can be
!			determined up through the record level.
!
!  CALLING SEQUENCE:
!
!	byte_size = COMPUTE_BYTE_SIZE (field_blk, sys_org);
!
!  PARAMETERS:
!
!	field_blk	Address of the member block in question
!	sys_org		System of origin (sys_lcg or sys_8bit/sys_pro)
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	Returns the byte size to be used to align the field.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE COMPUTE_BYTE_SIZE (field_blk, sys_org) =
BEGIN

MAP
    field_blk:	REF crx_member;

IF (.sys_org EQL SYS_8BIT)	! VAX case - easy!
    OR (.sys_org EQL SYS_PRO)

    THEN RETURN 8

    ELSE BEGIN			! 10/20 case:

LOCAL
    byte_size,
    current_member:	REF crx_member,
    current_parent:	REF crx_member;

! If field is a string, return its bytesize:

IF .field_blk [CRM$V_STRING_TYPE]
    THEN RETURN size_of (.field_blk [CRM$W_DATATYPE]);

! Try a depth-first search of the children looking for a usable byte-size:

byte_size = COMPUTE_BYTE_SIZE_WALKER (.field_blk, 0);
IF .byte_size NEQ 0
    THEN RETURN .byte_size;

! Look for an encompassing structure with a bytesize, and return that:

current_member = .field_blk;
current_parent = .field_blk [CRM$A_PREVIOUS];

WHILE TRUE DO BEGIN
    IF (.current_parent [CRM$B_ID] NEQ CRX$K_RECORD)
	THEN WHILE (.current_parent [CRM$A_CHILDREN] NEQ .current_member)
	    DO BEGIN		! Still in sibling group
	    current_member = .current_parent;
	    current_parent = .current_member [CRM$A_PREVIOUS];
	    END;

!   Found parent or the top record node.

    IF .current_parent [CRM$B_ID] EQL CRX$K_RECORD
	THEN RETURN 6;		! All the way back up to the record node

    IF .current_parent [CRM$V_STRING_TYPE]
	THEN RETURN size_of (.current_parent [CRM$W_DATATYPE]);

!   Try next higher encompassing structure.

    current_member = .current_parent;
    current_parent = .current_member [CRM$A_PREVIOUS];

END;
END;			! 10/20 case

RETURN 1;		! Satisfy Bliss compiler's need for a value here

END;
!++
!  COMPUTE_BYTE_SIZE_WALKER  (CMTBSW)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine is called by COMPUTE_BYTE_SIZE to find the byte-size
!	of the first child of the field in question found by a depth-first
!	search, if there is any.  Otherwise, it will return zero.
!
!  CALLING SEQUENCE:
!
!	byte_size = COMPUTE_BYTE_SIZE_WALKER (field_blk, depth);
!
!  PARAMETERS:
!
!	field_blk	Address of the member block in question
!	depth		Recursion depth
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	Returns the byte size if it finds one.
!	Returns zero otherwise.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
ROUTINE COMPUTE_BYTE_SIZE_WALKER (field_blk, depth) =
BEGIN

MAP
    field_blk:		REF crx_member;	! Member block in question

LOCAL
    byte_size,				! Returned byte-size
    current_member:	REF crx_member;	! Current member block
IF .field_blk [CRM$B_ID] NEQ CRX$K_MEMBER
    THEN RETURN 0;			! Not a member block, so no byte-size

current_member = .field_blk;

WHILE (.current_member NEQA NULL_PTR) Do
    BEGIN

    IF .current_member [CRM$V_STRING_TYPE]
	THEN RETURN size_of (.current_member [CRM$W_DATATYPE]);

    IF (.current_member [CRM$A_CHILDREN] NEQA NULL_PTR)
	THEN BEGIN
	byte_size = COMPUTE_BYTE_SIZE_WALKER
	    (.current_member [CRM$A_CHILDREN], .depth+1);
	IF .byte_size NEQ 0
	    THEN RETURN .byte_size;
	END;

    IF (.depth NEQ 0)
	THEN current_member = .current_member [CRM$A_NEXT]
	ELSE RETURN 0;

    END;

RETURN 0;

END;
!++
!  COMPUTE_END_OFFSETS (CMTEND)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine computes the offset and member_offset at the end of a
!	field based on the field's length, datatype, and any SYNCHRONIZED
!	clause.
!
!  CALLING SEQUENCE:
!
!	COMPUTE_END_OFFSETS (current_offset, current_member_offset, field_blk,
!		sys_org);
!
!  PARAMETERS:
!
!	current_offset	Address of current offset of this field, updated
!	current_member_offset	Address of current member_offset of this
!				field, updated
!	field_blk	Address of the member block in question
!	sys_org		System of origin or destination for this record
!			(sys_lcg or sys_8bit/sys_pro)
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!--
GLOBAL ROUTINE COMPUTE_END_OFFSETS (current_offset, current_member_offset,
	field_blk, sys_org): NOVALUE =
BEGIN

MAP
    field_blk:		REF crx_member;

BIND
    additional_blk	= .field_blk [CRM$A_FACILITY]: crx_additional,
    member_offset	= .current_member_offset,
    offset		= .current_offset;

LOCAL
    bits_left,
    byte_size,
    bytes_left,
    bytes_per_word,
    integral_words,
    length;
! Handle where the data itself ends:
! If SYS_ORG is a VAX or PRO, data ends where its length indicates.
! If an LCG system:
!    If the data is not a string, it ends where its length indicates.
!    If the data is a string, it ends where its length indicates,
!	adjusted to account for how the bytes are stored.

IF (.sys_org EQL SYS_8BIT) OR (NOT .field_blk [CRM$V_STRING_TYPE])
    OR (.sys_org EQL SYS_PRO)
    THEN BEGIN		! Easy case: it ends where it says it ends
	offset = .offset + .field_blk [CRM$L_LENGTH];
	member_offset = .member_offset + .field_blk [CRM$L_LENGTH];
    END
! Computation of end of a byte field on 10/20:
! 1.  Stuff as many bytes as will fit into the current partial word; the
!     bytes may be aligned improperly in this word due to proceeding fields.
!     DO NOT do this if the current word has nothing in it yet; it
!     can't have any misaligned bytes in that case.
! 2.  Update offsets to the end of this word.
! 3.  Fill up an integral number of words.
!     Note that the last word filled has to be treated as a partial word,
!     so that we don't fill to the end of the word as part of this field.
! 4.  Fill a partial word.
! Then compute the REAL field length.

    ELSE BEGIN		! Messy case: field does NOT end where it says it does
	byte_size = COMPUTE_BYTE_SIZE (.field_blk, .sys_org);
	length = .member_offset;
	bits_left = (DIU$K_O_WORD - (.member_offset MOD DIU$K_O_WORD))
	    MOD DIU$K_O_WORD;
	bytes_left = .field_blk [CRM$L_STRING_UNITS] - .bits_left / .byte_size;
	bytes_per_word = DIU$K_O_WORD / .byte_size;
	IF .bytes_left GTR 0
	    THEN BEGIN	! Field will not fit in current word
		member_offset = ((.member_offset + DIU$K_O_WORD-1)
		    / DIU$K_O_WORD) * DIU$K_O_WORD;
		integral_words = (.bytes_left-1) / .bytes_per_word;
	    END		! Field will not fit in current word
	    ELSE BEGIN	! Field will fit in current word
		integral_words = 0;
		bytes_left = .field_blk [CRM$L_STRING_UNITS];
	    END;	! Field will fit in current word
	member_offset = .member_offset + (.integral_words * DIU$K_O_WORD);
	bytes_left = .bytes_left - (.integral_words * .bytes_per_word);
	member_offset = .member_offset + (.bytes_left * .byte_size);
	length = .member_offset - .length;
	offset = .offset + .length;
	field_blk [CRM$L_LENGTH] = .length;
	field_blk [CRM$L_MEMBER_LENGTH] = .length;
    end;
! Handle SYNCHRONIZED LEFT:
! Change offsets to end on a word boundary.

IF (additional_blk NEQA NULL_PTR) AND
    (.additional_blk [CRA$V_SYNC_LEFT])
    THEN BEGIN
	length = .member_offset;
	member_offset = ((.member_offset + DIU$K_O_WORD-1) / DIU$K_O_WORD)
	    * DIU$K_O_WORD;
	length = .member_offset - .length;
	offset = .offset + .length;
	END;

END;
!++
!  COMPUTE_OFFSETS (CMTOFF)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine computes the offset and member_offset for a field based on
!	the field's datatype, any explicit alignment provided by an
!	ALIGNED clause, and alignment caused by SYNCHRONIZED.
!
!	NOTE: We let the ALIGNED clause take precedence over the default for the
!	datatype, on the assumption that the user asked for it.  Thus a user
!	can force a field which would normally be word-aligned on a 10/20 to
!	be byte-aligned (on some size byte), but the resulting data may be
!	difficult to access.
!
!  CALLING SEQUENCE:
!
!	COMPUTE_OFFSETS (current_offset, current_member_offset, field_blk,
!		sys_org);
!
!  PARAMETERS:
!
!	current_offset		Address of current offset of this field, updated
!	current_member_offset	Address of current member_offset of this
!					field, updated
!	field_blk		Address of the member block in question
!	sys_org			System of origin or destination for this
!					record (sys_lcg or sys_8bit/sys_pro)
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE COMPUTE_OFFSETS (current_offset, current_member_offset,
	field_blk, sys_org) : NOVALUE =
BEGIN

MAP
    field_blk:		REF crx_member;

BIND
    additional_blk	= .field_blk [CRM$A_FACILITY]: crx_additional,
    offset		= .current_offset,
    member_offset	= .current_member_offset;

LOCAL
    bits_left,
    bits_more,
    bytes_left,
    bytes_per_word,
    byte_size,
    integral_words,
    s_byte,
    s_word,
    s_longword,
    s_quadword,
    s_octaword;

! Pre-compute sizes to reduce size of generated code (common subexpression
! elimination isn't this smart).  This should prevent running out of heap
! space while compiling this module with BLISS36.

    s_byte = DIU$K_O_BYTE;
    s_word = DIU$K_O_WORD;
    s_longword = DIU$K_O_LONGWORD;
    s_quadword = DIU$K_O_QUADWORD;
    s_octaword = DIU$K_O_OCTAWORD;
! Explicit ALIGNED clause:

IF additional_blk NEQA NULL_PTR AND
    .additional_blk [CRA$V_ALIGNMENT_EXISTS]
    THEN SELECTONE .additional_blk [CRA$L_ALIGNMENT] OF
	SET

	[T_BIT]:	;		! No changes necessary

	[T_BYTE]: BEGIN
	    byte_size = COMPUTE_BYTE_SIZE (.field_blk, .sys_org);
	    integral_words = .member_offset / .s_word;
	    bits_left = .member_offset - (.integral_words * .s_word);
	    bits_more = (((.bits_left + .byte_size-1) / .byte_size)
		* .byte_size) - .bits_left;
	    offset = .offset + .bits_more;
	    member_offset = .member_offset + .bits_more;
	    END;

	[T_WORD]: BEGIN
	    bits_more = .member_offset;
	    member_offset = ((.member_offset + .s_word-1)
		/ .s_word) * .s_word;
	    bits_more = .member_offset - .bits_more;
	    offset = .offset + .bits_more;
	    END;

	[T_LONGWORD]: BEGIN
	    bits_more = .member_offset;
	    member_offset = ((.member_offset + .s_longword-1)
		/ .s_longword) * .s_longword;
	    bits_more = .member_offset - .bits_more;
	    offset = .offset + .bits_more;
	    END;

	[T_QUADWORD]: BEGIN
	    bits_more = .member_offset;
	    member_offset = ((.member_offset + .s_quadword-1)
		/ .s_quadword) * .s_quadword;
	    bits_more = .member_offset - .bits_more;
	    offset = .offset + .bits_more;
	    END;

	[T_OCTAWORD]: BEGIN
	    bits_more = .member_offset;
	    member_offset = ((.member_offset + .s_octaword-1)
		/ .s_octaword) * .s_octaword;
	    bits_more = .member_offset - .bits_more;
	    offset = .offset + .bits_more;
	    END;

	TES
! No explicit ALIGNED clause:

    ELSE IF (.sys_org EQL SYS_8BIT)
	OR (.sys_org EQL SYS_PRO) THEN BEGIN

!   VAX or PRO case:
!	bit field:		begins on next bit
!	any other field:	begins on next 8-bit byte

!	IF .field_blk [CRM$W_DATATYPE] EQL DIU$K_DTYPE_VU
!	    THEN RETURN
!	    ELSE BEGIN
		bits_more = .member_offset;
		member_offset = ((.member_offset + .s_byte-1)
		    / .s_byte) * .s_byte;
		bits_more = .member_offset - .bits_more;
		offset = .offset + .bits_more;
!	    END;

	END
!   TOPS-10/20 case:
!	fixed-point, floating-point, or pointer field:	next word
!	any other field:	next byte (of byte size of field, encompassing
!				structure, or record)

	ELSE BEGIN
	    LOCAL dattyp: data_type_sep;
	    dattyp = FIND_DATATYPE (.field_blk, .sys_org);
	    selectone .dattyp [DT_CLASS_SEP] OF SET
		[DT_FBIN, DT_FP]: BEGIN		! Word-aligned
		    bits_more = .member_offset;
		    member_offset = ((.member_offset + .s_word-1)
			/ .s_word) * .s_word;
		    bits_more = .member_offset - .bits_more;
		    offset = .offset + .bits_more;
		    END;
		[OTHERWISE]: BEGIN		! "Byte" aligned
		    byte_size = COMPUTE_BYTE_SIZE (.field_blk, .sys_org);
		    integral_words = .member_offset / .s_word;
		    bits_left = .member_offset -
			(.integral_words * .s_word);
		    IF (.s_word - .bits_left) LSS .byte_size
			THEN BEGIN	! No more bytes fit in this word
			    bits_more = .member_offset;
			    member_offset = ((.member_offset + .s_word-1)
				/ .s_word) * .s_word;
			    bits_more = .member_offset - .bits_more;
			    offset = .offset + .bits_more;
			END		! No more bytes fit in this word
			ELSE BEGIN	! Start string at right place in word
			    bits_more = (((.bits_left + .byte_size-1)
				/ .byte_size)	* .byte_size) - .bits_left;
			    offset = .offset + .bits_more;
			    member_offset = .member_offset + .bits_more;
			END;		! Start string at right place in word
		    END;
		TES;
    END;
! Handle synchronization:
! Synchronization of either sort causes word alignment.
! Right synchronization causes additional slack bytes so field will end on
!	a word boundary.
! Left synchronization only affects the ending offset of the field, once word
!	alignment has been done, so no more work is needed here.

IF additional_blk NEQA NULL_PTR AND
    (.additional_blk [CRA$V_SYNC_LEFT] OR .additional_blk [CRA$V_SYNC_RIGHT])
    THEN BEGIN		! Adjust for word alignment
	bits_more = .member_offset;
	member_offset = ((.member_offset + .s_word-1) / .s_word) * .s_word;
	bits_more = .member_offset - .bits_more;
	offset = .offset + .bits_more;
	END;

IF additional_blk NEQA NULL_PTR AND
    .additional_blk [CRA$V_SYNC_RIGHT]
    THEN BEGIN		! Right synchronized
	byte_size = COMPUTE_BYTE_SIZE (.field_blk, .sys_org);
	bytes_per_word = .s_word / .byte_size;
	bytes_left = .bytes_per_word -
	    (.field_blk [CRM$L_STRING_UNITS] MOD .bytes_per_word);
	offset = .offset + .bytes_left * .byte_size;
	member_offset = .member_offset + .bytes_left * .byte_size;
	END;

RETURN;

END;
!++
!  COMPUTE_STRIDES (CMTSTR)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine computes the strides for each dimension in an array.
!	The number of bits calculated will be correct as is if:
!	1.  This is a VAX or PRO, or
!	2.  The field is not a character string of any sort, or
!	3.  The field is aligned on something other than BIT or BYTE, or
!	4.  The field is synchronized.
!	Otherwise, see the calculation in COMPUTE_ARRAY_LENGTH, above.
!
!  CALLING SEQUENCE:
!
!	COMPUTE_STRIDES (dcb_ptr, stride_length, one_dimension_fl,
!		column_major_fl);
!
!  INPUT PARAMETERS:
!
!	dcb_ptr			is the address of the dimension node describing
!				the first array dimension.
!
!	stride_length		is the length of an element in the array plus
!				the fill area (if any) between elements.
!
!	one_dimension_fl	TRUE if array has one dimension
!
!	column_major_fl		TRUE if array is column_major
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	none
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
GLOBAL ROUTINE COMPUTE_STRIDES (DCB_PTR, STRIDE_LENGTH, ONE_DIMENSION_FL,
	COLUMN_MAJOR_FL) : NOVALUE =
BEGIN
    MAP
	DCB_PTR :	REF crx_dimension;

    LOCAL
	NO_ELEMENTS :	INITIAL (0),
	TEMP_PTR :	REF crx_dimension;

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called COMPUTE_STRIDES'));
!   Compute strides for last or only dimension:

    IF (.DCB_PTR [crd$a_next] EQLU NULL_PTR) OR .ONE_DIMENSION_FL
	THEN BEGIN
	    DCB_PTR [crd$l_stride] = .STRIDE_LENGTH;
	    DCB_PTR [crd$v_stride_fl] = TRUE;
	    RETURN;
	END;

!   Compute column-major strides:

    IF .COLUMN_MAJOR_FL
	THEN BEGIN
	    NO_ELEMENTS = 1;
	    WHILE .DCB_PTR NEQU NULL_PTR DO
		BEGIN
		    DCB_PTR [crd$l_stride] = .NO_ELEMENTS * .STRIDE_LENGTH;
		    DCB_PTR [crd$v_stride_fl] = TRUE;
		    NO_ELEMENTS = .NO_ELEMENTS * (.DCB_PTR [crd$l_upper_bound] -
			.DCB_PTR [crd$l_lower_bound] + 1);
		    DCB_PTR = .DCB_PTR [crd$a_next];
		END;
	    RETURN;
	END;

!   Compute row-major strides:

    WHILE .DCB_PTR NEQU NULL_PTR DO
	BEGIN
	    NO_ELEMENTS = 1;
	    TEMP_PTR = .DCB_PTR [crd$a_next];
	    WHILE .TEMP_PTR NEQU NULL_PTR DO
		BEGIN
		    NO_ELEMENTS = .NO_ELEMENTS *
			(.TEMP_PTR [crd$l_upper_bound] -
			.TEMP_PTR [crd$l_lower_bound] + 1);
		    TEMP_PTR = .TEMP_PTR [crd$a_next];
		END;
	    DCB_PTR [crd$l_stride] = .NO_ELEMENTS * .STRIDE_LENGTH;
	    DCB_PTR [crd$v_stride_fl] = TRUE;
	    DCB_PTR = .DCB_PTR [crd$a_next];
	END;

END;
!++
!  COPY_RECORD (CPYREC)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine copies a record template from the data dictionary.
!
!  CALLING SEQUENCE:
!
!	status = COPY_RECORD (field_blk, name);
!
!  INPUT PARAMETERS:
!
!	field_blk		Address of field block to be copied to
!	name			Address of string descriptor of name to copy
!
!  IMPLICIT INPUTS:
!
!	TBS
!
!  IMPLICIT OUTPUTS:
!
!	TBS
!
!  COMPLETION STATUS:
!
!	FALSE		Operation not implemented yet
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE COPY_RECORD (field_blk, name) =
BEGIN

MAP
    FIELD_BLK: REF crx_member,
    NAME: REF $STR_DESCRIPTOR ();

%IF %BLISS (BLISS32) %THEN

EXTERNAL ROUTINE
    CRX$EXTRACT_DESCRIPTION,
    LIB$GET_VM,
    CRX$SIGN_OFF;

LOCAL
    temp: REF crx_member,
    tree: REF crx_record initial (NULL_PTR),
    root: REF crx_member,
    fac: initial (FALSE),		! CDD facility-specific stuff not wanted
    comments: initial (FALSE);		! CDD descriptions not wanted

%FI

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called COPY_RECORD'));

!   The CRX code should be called here to retrieve the record template from
!   the CDD (on VMS) or from a DTR-20 dictionary (on TOPS-20), some day.

%IF %BLISS (BLISS36) %THEN

    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
	'COPY of Datatrieve descriptions not implemented');

    RETURN FALSE;

%ELSE

    tree = CRX$EXTRACT_DESCRIPTION (.name, %REF (LIB$GET_VM), fac, comments);

    root = .tree [CRX$A_ROOT];	! Root member node of COPY template

!   Move data from root of COPY template into COPY record:

    field_blk [CRM$W_REF_LENGTH] = .root [CRM$W_REF_LENGTH];
    field_blk [CRM$W_CHILDREN_CNT] = .root [CRM$W_CHILDREN_CNT];
    field_blk [CRM$B_TAG_VARIABLE_CNT] = .root [CRM$B_TAG_VARIABLE_CNT];
    field_blk [CRM$B_DIMENSIONS_CNT] = .root [CRM$B_DIMENSIONS_CNT];
!   Don't bother to copy CRM$A_DESCRIPTION - not used by DIU
    field_blk [CRM$A_REFERENCE] = .root [CRM$A_REFERENCE];
    temp = .root [CRM$A_REFERENCE];
    IF .temp NEQA NULL_PTR
	THEN temp [CRM$A_PREVIOUS] = .field_blk;
    field_blk [CRM$A_CHILDREN] = .root [CRM$A_CHILDREN];
    temp = .root [CRM$A_CHILDREN];
    IF .temp NEQA NULL_PTR
	THEN temp [CRM$A_PREVIOUS] = .field_blk;
    field_blk [CRM$A_TAG_VARIABLE] = .root [CRM$A_TAG_VARIABLE];
    temp = .root [CRM$A_TAG_VARIABLE];
    IF .temp NEQA NULL_PTR
	THEN temp [CRM$A_PREVIOUS] = .field_blk;
    field_blk [CRM$L_LENGTH] = .root [CRM$L_LENGTH];
    field_blk [CRM$L_OFFSET] = .root [CRM$L_OFFSET];	! May get changed
    field_blk [CRM$L_MEMBER_LENGTH] = .root [CRM$L_MEMBER_LENGTH];	! "
!   CRM$L_MEMBER_OFFSET will have to be recomputed.
    field_blk [CRM$L_STRING_UNITS] = .root [CRM$L_STRING_UNITS];
    field_blk [CRM$A_DIMENSIONS] = .root [CRM$A_DIMENSIONS];
    temp = .root [CRM$A_DIMENSIONS];
    IF .temp NEQA NULL_PTR
	THEN .temp [CRM$A_PREVIOUS] = .field_blk;
    field_blk [CRM$L_TOTAL_CELLS] = .root [CRM$L_TOTAL_CELLS];
!   No CRM$A_FACILITY needed
    field_blk [CRM$W_DATATYPE] = .root [CRM$W_DATATYPE];	! Must be mapped
    field_blk [CRM$W_DIGITS] = .root [CRM$W_DIGITS];
    field_blk [CRM$W_MAX_DIGITS] = .root [CRM$W_MAX_DIGITS];
    field_blk [CRM$W_SCALE] = .root [CRM$W_SCALE];
    field_blk [CRM$B_BASE] = .root [CRM$B_BASE];
    field_blk [CRM$V_COLUMN_MAJOR] = .root [CRM$V_COLUMN_MAJOR];
    field_blk [CRM$V_STRING_TYPE] = .root [CRM$V_STRING_TYPE];
    field_blk [CRM$V_COMPUTE_TYPE] = .root [CRM$V_COMPUTE_TYPE];
    field_blk [CRM$V_DEBUG_FLAG] = .root [CRM$V_DEBUG_FLAG];
!   CRM$V_FIRST_CHILD does not carry over from COPY template
    field_blk [CRM$V_BLANK_WHEN_ZERO] = .root [CRM$V_BLANK_WHEN_ZERO];
    field_blk [CRM$V_RIGHT_JUSTIFIED] = .root [CRM$V_RIGHT_JUSTIFIED];
    field_blk [CRM$V_SOURCE_TYPE_TRUNC] = .root [CRM$V_SOURCE_TYPE_TRUNC];
    field_blk [CRM$V_REFERENCE_TRUNC] = .root [CRM$V_REFERENCE_TRUNC];
    field_blk [CRM$V_INITIAL_VALUE_TRUNC] = .root [CRM$V_INITIAL_VALUE_TRUNC];
!   CRM$V_FACILITY_USE_n not carried over from COPY template
    field_blk [CRM$A_INITIAL_VALUE] = .root [CRM$A_INITIAL_VALUE];
    field_blk [CRM$W_INITIAL_LENGTH] = .root [CRM$W_INITIAL_LENGTH];

!   Delete the top (root) member node in the COPY template:

    $XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_member, .root, FULLWORDS));

!   Delete the record node in the COPY template:

    $XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_record, .tree, FULLWORDS));

    CRX$SIGN_OFF ();

    RETURN TRUE;

%FI

END;
!++
!  DEAL_WITH_TRANSFORM_NAMES (DWTNMS)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine deals with the field names involved in a transform.
!
!  CALLING SEQUENCE:
!
!	status = DEAL_WITH_TRANSFORM_NAMES (source_name, source_fqn,
!		dest_name, dest_fqn);
!
!  PARAMETERS:
!
!	source_name	String descriptor of source field name
!	source_fqn	Address to set to fully-qualified-name list of
!			source field name
!	dest_name	String descriptor of destination field name
!	dest_fqn	Address to set to fully-qualified-name list of
!			destination field name
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLIIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	TRUE if OK.
!	FALSE if not OK (error message has already been produced).
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE DEAL_WITH_TRANSFORM_NAMES (source_name, source_fqn,
	dest_name, dest_fqn) =
BEGIN

MAP
    source_name:	REF $STR_DESCRIPTOR (),
    source_fqn:		REF crx_stringlist,
    dest_name:		REF $STR_DESCRIPTOR (),
    dest_fqn:		REF crx_stringlist;

LOCAL
    status;			! Return status
status = PRODUCE_FQN (.source_name, .source_fqn);
IF NOT .status
    THEN BEGIN
	FREE_STRINGLIST (.source_fqn);
	RETURN FALSE;
    END;

status = PRODUCE_FQN (.dest_name, .dest_fqn);
IF NOT .status
    THEN BEGIN
	FREE_STRINGLIST (.dest_fqn);
	RETURN FALSE;
    END;

status = VALIDATE_FQN (.source_fqn);
IF NOT .status
    THEN BEGIN
	FREE_STRINGLIST (.source_fqn);
	RETURN FALSE;
    END;

status = VALIDATE_FQN (.dest_fqn);
IF NOT .status
    THEN FREE_STRINGLIST (.dest_fqn);
RETURN .status;

END;
!++
!  DUPLICATE_SUBTREE (DUPDSC)
!
!	This routine recursively makes a duplicate copy of a record description
!	tree or subtree.  It is called by DIU$COPY_DESCRIPTION in PATPOR.BLI,
!	which is used by the command driver to make a copy of a record
!	description tree.
!
!  CALLING SEQUENCE:
!
!	status = DUPLICATE_SUBTREE (root, copy, depth, previous);
!
!  PARAMETERS:
!
!	root		is the address of the head node of the record
!			description tree or subtree to be duplicated.
!	copy		is the address of a pointer to be set to the duplicate.
!	depth		is the recursion depth in this routine.  If the
!			recursion depth is zero, the routine does not iterate
!			on the siblings of the root node of the subtree it is
!			working on.
!	previous	is the address to be placed in the xxx$A_PREVIOUS field
!			of the root of the subtree being constructed, or a null
!			pointer if none.
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	TRUE if copy done, "copy" set
!	FALSE if copy failed, "copy" not set
!
!  SIDE EFFECTS:
!
!	Any previously-existing record description tree or subtree pointed
!	to by "copy" is disposed of before the copy is made.
!
!--

GLOBAL ROUTINE DUPLICATE_SUBTREE (root, copy, depth, previous) =
BEGIN

MAP
    root:		REF crx_record,		! Root of subtree to copy
    copy:		REF crx_record,		! Root of copy
    previous:		REF crx_member;		! xxx$A_PREVIOUS field for copy

LOCAL
    status:		INITIAL (TRUE);		! Return status
IF .root EQLA NULL_PTR
    THEN  BEGIN
    .copy = NULL_PTR;				! Make sure nothing in copy
    RETURN TRUE;				! Nothing to do here
    END;

SELECTONE .root [CRX$B_ID] OF
SET

[CRX$K_RECORD]:			! CRX_RECORD node
    BEGIN
    LOCAL
	c_member:	REF crx_member		! Copy of a crx_member node
			INITIAL (NULL_PTR),
	c_record:	REF crx_record		! Copy of a crx_record node
			INITIAL (NULL_PTR);
    IF ..copy NEQA NULL_PTR THEN FREE_RECORD (..copy);
    $XPO_GET_MEM (FULLWORDS = diu$s_crx_record, RESULT = c_record, FILL = 0);
    .copy = .c_record;		! Prepare to return address of structure
    status = DUPLICATE_SUBTREE (.root [CRX$A_ROOT], c_member, .depth+1,
	.c_record);
    c_record [CRX$A_ROOT] = .c_member;
!   c_member = NULL_PTR;
    c_record [CRX$B_ID] = CRX$K_RECORD;
    c_record [CRX$B_CORE_LEVEL] = 4;
    $STR_COPY (STRING = 'CDD$RECORD',
	TARGET = (10, ch$ptr (c_record [CRX$T_PROTOCOL])));
    ! CRX$W_FACILITY_CODE not used
    ! CRX$B_DESCRIPTION_CNT not used
    ! CRX$A_FACILITY not used
    c_record [CRX$L_FORMAT] = .root [CRX$L_FORMAT];
    ! CRX$A_DESCRIPTION not used
    END;			! CRX_RECORD node

[CRX$K_MEMBER]:			! CRX_MEMBER node
    BEGIN
    LOCAL
	c_dimension:	REF crx_dimension	! Copy of a crx_dimension node
			INITIAL (NULL_PTR),
	a_member:	REF crx_member		! A crx_member node
			INITIAL (NULL_PTR),
	c_member:	REF crx_member		! Copy of a crx_member node
			INITIAL (NULL_PTR),
	n_member:	REF crx_member		! New crx_member node
			INITIAL (NULL_PTR),
	p_member:	REF crx_member		! Previous crx_member node
			INITIAL (NULL_PTR),
	c_stringlist:	REF crx_stringlist	! Copy of a crx_stringlist node
			INITIAL (NULL_PTR);
    a_member = .root;		! Get field addressibility
    IF ..copy NEQA NULL_PTR THEN FREE_MEMBERS (..copy);
    p_member = .previous;
    DO BEGIN			! Iterate on CRX_MEMBER siblings
	$XPO_GET_MEM (FULLWORDS = diu$s_crx_member, RESULT = c_member,
	    FILL = 0);
	IF .a_member EQLA .root
	    THEN .copy = .c_member;	! Set root address of copy
	c_member [CRM$A_PREVIOUS] = .p_member;
	IF NOT .a_member [CRM$V_FIRST_CHILD] AND .depth NEQ 0
	    THEN p_member [CRM$A_NEXT] = .c_member;
	! Our CRM$A_NEXT set later
	c_member [CRM$B_ID] = CRX$K_MEMBER;
	! CRM$B_DESCRIPTION_CNT not used
	c_member [CRM$W_SOURCE_LENGTH] = .a_member [CRM$W_SOURCE_LENGTH];
	! CRM$W_REF_LENGTH not used
	c_member [CRM$W_CHILDREN_CNT] = .a_member [CRM$W_CHILDREN_CNT];
	c_member [CRM$B_TAG_VARIABLE_CNT] =
	    .a_member [CRM$B_TAG_VARIABLE_CNT];
	c_member [CRM$B_DIMENSIONS_CNT] = .a_member [CRM$B_DIMENSIONS_CNT];
	c_member [CRM$B_NAME_LENGTH] = .a_member [CRM$B_NAME_LENGTH];
	$STR_COPY (STRING = (.a_member [CRM$B_NAME_LENGTH],
	    ch$ptr (a_member [CRM$T_NAME])),
	    TARGET = (.c_member [CRM$B_NAME_LENGTH],
	    ch$ptr (c_member [CRM$T_NAME])) );
	! CRM$A_DESCRIPTION not used
	$XPO_GET_MEM (CHARACTERS = .c_member [CRM$W_SOURCE_LENGTH],
	    RESULT = c_member [CRM$A_SOURCE_TYPE]);
	$STR_COPY (STRING = (.a_member [CRM$W_SOURCE_LENGTH],
	    .a_member [CRM$A_SOURCE_TYPE]),
	    TARGET = (.c_member [CRM$W_SOURCE_LENGTH],
	    .c_member [CRM$A_SOURCE_TYPE]));
	! CRM$A_REFERENCE not used
	status = .status AND DUPLICATE_SUBTREE
	    (.a_member [CRM$A_CHILDREN], n_member, .depth+1, .c_member);
	c_member [CRM$A_CHILDREN] = .n_member;
	n_member = NULL_PTR;
	status = .status AND DUPLICATE_SUBTREE (.a_member [CRM$A_TAG_VARIABLE],
	    c_stringlist, .depth+1, .c_member);
	c_member [CRM$A_TAG_VARIABLE] = .c_stringlist;
	c_stringlist = NULL_PTR;
	c_member [CRM$L_LENGTH] = .a_member [CRM$L_LENGTH];
	c_member [CRM$L_OFFSET] = .a_member [CRM$L_OFFSET];
	c_member [CRM$L_MEMBER_LENGTH] = .a_member [CRM$L_MEMBER_LENGTH];
	c_member [CRM$L_MEMBER_OFFSET] = .a_member [CRM$L_MEMBER_OFFSET];
	c_member [CRM$L_STRING_UNITS] = .a_member [CRM$L_STRING_UNITS];
	status = .status AND DUPLICATE_SUBTREE (.a_member [CRM$A_DIMENSIONS],
	    c_dimension, .depth+1, .c_member);
	c_member [CRM$A_DIMENSIONS] = .c_dimension;
	c_dimension = NULL_PTR;
	c_member [CRM$L_TOTAL_CELLS] = .a_member [CRM$L_TOTAL_CELLS];
	IF .a_member [CRM$A_FACILITY] NEQA NULL_PTR
	    THEN BEGIN		! Copy CRM$A_FACILITY
	    LOCAL
		a_facility:	REF crx_additional	! A crx_additional node
				INITIAL (NULL_PTR),
		c_facility:	REF crx_additional	! Copy of crx_additional
				INITIAL (NULL_PTR);
	    a_facility = .a_member [CRM$A_FACILITY];	! Get addressability
	    $XPO_GET_MEM (FULLWORDS = cra$s_crx_additional, RESULT = c_facility,
		FILL = 0);
	    c_member [CRM$A_FACILITY] = .c_facility;
	    c_facility [CRA$L_LOCATOR] = .a_facility [CRA$L_LOCATOR];
	    c_facility [CRA$L_TYPE] = .a_facility [CRA$L_TYPE];
	    ! CRA$L_MAX_MEMBER_LENGTH not needed
	    c_facility [CRA$L_INITIAL_TYPE] = .a_facility [CRA$L_INITIAL_TYPE];
	    c_facility [CRA$L_INITIAL_TYPE_1] =
		.a_facility [CRA$L_INITIAL_TYPE_1];
	    c_facility [CRA$L_INITIAL_TYPE_2] =
		.a_facility [CRA$L_INITIAL_TYPE_2];
	    c_facility [CRA$L_INITIAL_LENGTH_1] =
		.a_facility [CRA$L_INITIAL_LENGTH_1];
	    c_facility [CRA$V_ALIGNMENT_EXISTS] =
		.a_facility [CRA$V_ALIGNMENT_EXISTS];
	    c_facility [CRA$V_LENGTH_SET] = .a_facility [CRA$V_LENGTH_SET];
	    c_facility [CRA$V_OFFSET_SET] = .a_facility [CRA$V_OFFSET_SET];
	    c_facility [CRA$V_DIMENSION] = .a_facility [CRA$V_DIMENSION];
	    c_facility [CRA$V_SYNC_LEFT] = .a_facility [CRA$V_SYNC_LEFT];
	    c_facility [CRA$V_SYNC_RIGHT] = .a_facility [CRA$V_SYNC_RIGHT];
	    END;			! Copy CRM$A_FACILITY
	c_member [CRM$W_DATATYPE] = .a_member [CRM$W_DATATYPE];
	c_member [CRM$W_DIGITS] = .a_member [CRM$W_DIGITS];
	c_member [CRM$W_MAX_DIGITS] = .a_member [CRM$W_MAX_DIGITS];
	c_member [CRM$W_SCALE] = .a_member [CRM$W_SCALE];
	c_member [CRM$B_BASE] = .a_member [CRM$B_BASE];
	c_member [CRM$V_COLUMN_MAJOR] = .a_member [CRM$V_COLUMN_MAJOR];
	c_member [CRM$V_STRING_TYPE] = .a_member [CRM$V_STRING_TYPE];
	c_member [CRM$V_COMPUTE_TYPE] = .a_member [CRM$V_COMPUTE_TYPE];
	c_member [CRM$V_DEBUG_FLAG] = .a_member [CRM$V_DEBUG_FLAG];
	c_member [CRM$V_FIRST_CHILD] = .a_member [CRM$V_FIRST_CHILD];
	! CRM$V_BLANK_WHEN_ZERO not used
	c_member [CRM$V_RIGHT_JUSTIFIED] = .a_member [CRM$V_RIGHT_JUSTIFIED];
	c_member [CRM$V_SOURCE_TYPE_TRUNC] =
	    .a_member [CRM$V_SOURCE_TYPE_TRUNC];
	! CRM$V_REFERENCE_TRUNC not used
	c_member [CRM$V_INITIAL_VALUE_TRUNC] =
	    .a_member [CRM$V_INITIAL_VALUE_TRUNC];
	! CRM$V_FACILITY_USE_1 not needed here
	! CRM$V_FACILITY_USE_2 not duplicated
	c_member [CRM$V_FACILITY_USE_3] = .a_member [CRM$V_FACILITY_USE_3];
	! CRM$V_FACILITY_USE_4 not used
	c_member [CRM$V_FACILITY_USE_5] = .a_member [CRM$V_FACILITY_USE_5];
	c_member [CRM$W_INITIAL_LENGTH] = .a_member [CRM$W_INITIAL_LENGTH];
	IF NOT .a_member [CRM$V_FACILITY_USE_3]
	    THEN BEGIN				! Initial value in characters
	    $XPO_GET_MEM (CHARACTERS = .c_member [CRM$W_INITIAL_LENGTH],
		RESULT = c_member [CRM$A_INITIAL_VALUE]);
	    $STR_COPY (STRING = (.a_member [CRM$W_INITIAL_LENGTH],
		.a_member [CRM$A_INITIAL_VALUE]),
		TARGET = (.c_member [CRM$W_INITIAL_LENGTH],
		.c_member [CRM$A_INITIAL_VALUE]));
	    END					! Initial value in characters
	    ELSE BEGIN				! In words - suspicious!
	    $XPO_GET_MEM (FULLWORDS = .c_member [CRM$W_INITIAL_LENGTH],
		RESULT = c_member [CRM$A_INITIAL_VALUE]);
	    CH$MOVE (.c_member [CRM$W_INITIAL_LENGTH] * %upval,
		CH$PTR (.a_member [CRM$A_INITIAL_VALUE], 0, %BPUNIT),
		CH$PTR (.c_member [CRM$A_INITIAL_VALUE], 0, %BPUNIT));
	    END;				! In words - suspicious!
	p_member = .c_member;
	a_member = .a_member [CRM$A_NEXT];
    END UNTIL (.a_member EQLA NULL_PTR OR .depth EQL 0)
    END;			! CRX_MEMBER node

[CRX$K_OVERLAY]:		! CRX_OVERLAY node
    BEGIN
    LOCAL
	c_literal_list:	REF crx_literal_list	! Copy of a crx_literal_list
			INITIAL (NULL_PTR),
	c_member:	REF crx_member		! Copy of a crx_member node
			INITIAL (NULL_PTR),
	a_overlay:	REF crx_overlay		! A crx_overlay node
			INITIAL (NULL_PTR),
	c_overlay:	REF crx_overlay		! Copy of a crx_overlay node
			INITIAL (NULL_PTR),
	p_overlay:	REF crx_overlay		! Previous crx_overlay node
			INITIAL (NULL_PTR),
	first:		INITIAL (TRUE);		! First child flag
    a_overlay = .root;		! Get field addressability
    IF ..copy NEQA NULL_PTR THEN FREE_MEMBERS (..copy);
    p_overlay = .previous;
    DO BEGIN			! Iterate on CRX_OVERLAY siblings
	$XPO_GET_MEM (FULLWORDS = diu$s_crx_overlay, RESULT = c_overlay,
	    FILL = 0);
	IF .a_overlay EQLA .root
	    THEN .copy = .c_overlay;	! Set root address of copy
	c_overlay [CRO$A_PREVIOUS] = .p_overlay;
	IF .first
	    THEN first = FALSE
	    ELSE p_overlay [CRO$A_NEXT] = .c_overlay;
	! Our CRO$A_NEXT set later
	c_overlay [CRO$B_ID] = CRX$K_OVERLAY;
	c_overlay [CRO$W_FIELDS_CNT] = .a_overlay [CRO$W_FIELDS_CNT];
	status = .status AND DUPLICATE_SUBTREE (.a_overlay [CRO$A_FIELDS],
	    c_member, .depth+1, .c_overlay);
	c_overlay [CRO$A_FIELDS] = .c_member;
	c_member = NULL_PTR;
	c_overlay [CRO$L_MAX_LENGTH] = .a_overlay [CRO$L_MAX_LENGTH];
	c_overlay [CRO$L_MIN_OFFSET] = .a_overlay [CRO$L_MIN_OFFSET];
	c_overlay [CRO$L_MAX_MEMBER_LENGTH] =
	    .a_overlay [CRO$L_MAX_MEMBER_LENGTH];
	c_overlay [CRO$L_MIN_MEMBER_OFFSET] =
	    .a_overlay [CRO$L_MIN_MEMBER_OFFSET];
	status = .status AND DUPLICATE_SUBTREE (.a_overlay [CRO$A_TAG_VALUES],
	    c_literal_list, .depth+1, .c_overlay);
	c_overlay [CRO$A_TAG_VALUES] = .c_literal_list;
	c_literal_list = NULL_PTR;
	c_overlay [CRO$W_TAG_VALUES_CNT] =
	    .a_overlay [CRO$W_TAG_VALUES_CNT];
	c_overlay [CRO$L_TOTAL_LENGTH] = .a_overlay [CRO$L_TOTAL_LENGTH];
	p_overlay = .c_overlay;
	a_overlay = .a_overlay [CRO$A_NEXT];
    END UNTIL (.a_overlay EQLA NULL_PTR OR .depth EQL 0)
    END;			! CRX_OVERLAY node

[CRX$K_DIMENSION]:		! CRX_DIMENSION node
    BEGIN
    LOCAL
	a_dimension:	REF crx_dimension	! A crx_dimension node
			INITIAL (NULL_PTR),
	c_dimension:	REF crx_dimension	! Copy of a crx_dimension node
			INITIAL (NULL_PTR),
	p_dimension:	REF crx_dimension	! Previous crx_dimension node
			INITIAL (NULL_PTR),
	c_stringlist:	REF crx_stringlist	! Copy of a crx_stringlist node
			INITIAL (NULL_PTR),
	first:		INITIAL (TRUE);		! First sibling flag
    a_dimension = .root;	! Get field addressability
    IF ..copy NEQA NULL_PTR THEN FREE_DIMENSIONS (..copy);
    p_dimension = .previous;
    DO BEGIN			! Iterate on CRX_DIMENSION siblings
	$XPO_GET_MEM (FULLWORDS = diu$s_crx_dimension, RESULT = c_dimension,
	    FILL = 0);
	IF .a_dimension EQLA .root
	    THEN .copy = .c_dimension;	! Set root address of copy
	c_dimension [CRD$A_PREVIOUS] = .p_dimension;
	IF .first
	    THEN first = FALSE
	    ELSE p_dimension [CRD$A_NEXT] = .c_dimension;
	! Our CRD$A_NEXT set later
	c_dimension [CRD$B_ID] = CRX$K_DIMENSION;
	c_dimension [CRD$B_DEPEND_ITEM_CNT] =
	    .a_dimension [CRD$B_DEPEND_ITEM_CNT];
	c_dimension [CRD$L_LOWER_BOUND] = .a_dimension [CRD$L_LOWER_BOUND];
	c_dimension [CRD$L_UPPER_BOUND] = .a_dimension [CRD$L_UPPER_BOUND];
	c_dimension [CRD$L_STRIDE] = .a_dimension [CRD$L_STRIDE];
	status = .status AND DUPLICATE_SUBTREE
	    (.a_dimension [CRD$A_DEPEND_ITEM],
	    c_stringlist, .depth+1, .c_dimension);
	c_dimension [CRD$A_DEPEND_ITEM] = .c_stringlist;
	c_stringlist = NULL_PTR;
	c_dimension [CRD$L_MIN_OCCURS] = .a_dimension [CRD$L_MIN_OCCURS];
	c_dimension [CRD$V_LOWER_BOUND_FL] =
	    .a_dimension [CRD$V_LOWER_BOUND_FL];
	c_dimension [CRD$V_UPPER_BOUND_FL] =
	    .a_dimension [CRD$V_UPPER_BOUND_FL];
	c_dimension [CRD$V_STRIDE_FL] = .a_dimension [CRD$V_STRIDE_FL];
	c_dimension [CRD$V_MIN_OCCURS_FL] =
	    .a_dimension [CRD$V_MIN_OCCURS_FL];
	p_dimension = .c_dimension;
	a_dimension = .a_dimension [CRD$A_NEXT];
    END UNTIL (.a_dimension EQLA NULL_PTR OR .depth EQL 0)
    END;			! CRX_DIMENSION node

[CRX$K_STRINGLIST]:		! CRX_STRINGLIST node
    BEGIN
    LOCAL
	a_stringlist:	REF crx_stringlist	! A crx_stringlist node
			INITIAL (NULL_PTR),
	c_stringlist:	REF crx_stringlist	! Copy of a crx_stringlist node
			INITIAL (NULL_PTR),
	p_stringlist:	REF crx_stringlist	! Previous crx_stringlist node
			INITIAL (NULL_PTR),
	first:		INITIAL (TRUE);		! First sibling flag
    a_stringlist = .root;	! Get field addressability
    IF ..copy NEQA NULL_PTR THEN FREE_STRINGLIST (..copy);
    p_stringlist = .previous;
    DO BEGIN			! Iterate on CRX_STRINGLIST siblings
	$XPO_GET_MEM (FULLWORDS = diu$s_crx_stringlist, RESULT = c_stringlist,
	    FILL = 0);
	IF .a_stringlist EQLA .root
	    THEN .copy = .c_stringlist;	! Set root address of copy
	c_stringlist [CRS$A_PREVIOUS] = .p_stringlist;
	IF .first
	    THEN first = FALSE
	    ELSE p_stringlist [CRS$A_NEXT] = .c_stringlist;
	! Our CRS$A_NEXT set later
	INIT_STRINGLIST (.c_stringlist);	! Sets CRS$B_ID
	c_stringlist [CRS$V_STRING_TRUNC] = .a_stringlist [CRS$V_STRING_TRUNC];
	c_stringlist [CRS$V_BINARY_STRING] =
	    .a_stringlist [CRS$V_BINARY_STRING];
	c_stringlist [CRS$W_STRING_LENGTH] =
	    .a_stringlist [CRS$W_STRING_LENGTH];
	$XPO_GET_MEM (CHARACTERS = .c_stringlist [CRS$W_STRING_LENGTH],
	    RESULT = c_stringlist [CRS$A_STRING]);
	$STR_COPY (STRING = (.a_stringlist [CRS$W_STRING_LENGTH],
	    .a_stringlist [CRS$A_STRING]),
	    TARGET = (.c_stringlist [CRS$W_STRING_LENGTH],
	    .c_stringlist [CRS$A_STRING]));
	p_stringlist = .c_stringlist;
	a_stringlist = .a_stringlist [CRS$A_NEXT];
    END UNTIL (.a_stringlist EQLA NULL_PTR OR .depth EQL 0)
    END;			! CRX_STRINGLIST node

[CRX$K_PLI_SPECIFIC]:;		! Not copied

[CRX$K_LITERAL_LIST]:		! CRX_LITERAL_LIST node
    BEGIN
    LOCAL
	a_literal_list:	REF crx_literal_list	! A crx_literal_list node
			INITIAL (NULL_PTR),
	c_literal_list:	REF crx_literal_list	! Copy of a crx_literal_list
			INITIAL (NULL_PTR),
	p_literal_list:	REF crx_literal_list	! Previous crx_literal_list node
			INITIAL (NULL_PTR),
	c_stringlist:	REF crx_stringlist	! Copy of a crx_stringlist node
			INITIAL (NULL_PTR),
	first:		INITIAL (TRUE);		! First sibling flag
    a_literal_list = .root;	! Get field addressability
    IF ..copy NEQA NULL_PTR THEN FREE_LITLIST (..copy);
    p_literal_list = .previous;
    DO BEGIN			! Iterate on CRX_LITERAL_LIST siblings
	$XPO_GET_MEM (FULLWORDS = diu$s_crx_literal_list,
	    RESULT = c_literal_list, FILL = 0);
	IF .a_literal_list EQLA .root
	    THEN .copy = .c_literal_list;	! Set root address of copy
	c_literal_list [CRL$A_PREVIOUS] = .p_literal_list;
	IF .first
	    THEN first = FALSE
	    ELSE p_literal_list [CRL$A_NEXT] = .c_literal_list;
	! Our CRL$A_NEXT set later
	INIT_LITERAL (.c_literal_list);	! Sets CRL$B_ID
	c_literal_list [CRL$W_LITERALS_CNT] =
	    .a_literal_list [CRL$W_LITERALS_CNT];
	status = .status AND DUPLICATE_SUBTREE
	    (.a_literal_list [CRL$A_LITERALS],
	    c_stringlist, .depth+1, .c_literal_list);
	c_literal_list [CRL$A_LITERALS] = .c_stringlist;
	c_stringlist = NULL_PTR;
	p_literal_list = .c_literal_list;
	a_literal_list = .a_literal_list [CRL$A_NEXT];
    END UNTIL (.a_literal_list EQLA NULL_PTR OR .depth EQL 0)
    END;			! CRX_LITERAL_LIST node

[CRX$K_TAG_FFD]:		! Tag FFD node
    BEGIN			! Copying one of these is VERY suspicious!!
    LOCAL
	a_tag_ffd:	REF crx_tag_ffd,	! A tag FFD node
	c_tag_ffd:	REF crx_tag_ffd;	! Copy of a tag FFD node
    a_tag_ffd = .root;		! Get field addressability
    IF ..copy NEQA NULL_PTR THEN FREE_STRINGLIST (..copy);
    $XPO_GET_MEM (FULLWORDS = diu$s_crx_tag_ffd, RESULT = c_tag_ffd,
	FILL = 0);
    .copy = .c_tag_ffd;
    c_tag_ffd [CRT$A_PREVIOUS] = .previous;
    ! CRT$A_NEXT always NULL_PTR
    c_tag_ffd [CRT$B_ID] = CRX$K_TAG_FFD;
    c_tag_ffd [CRT$V_SUSPICIOUS_TAG] = TRUE;	! VERY suspicious!!
    ! Leave the FFD blank; it can't be any good anyways!!
    END;			! Tag FFD node

TES;

RETURN .status;

END;
!++
!  FIND_DATATYPE (FNDTYP)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine returns the DIL datatype for a field.  If the field has
!	none (for example, a structure), it will return the datatype pf the
!	first child of the field found by a depth-first search which has a
!	datatype, the datatype of the	smallest encompassing structure that
!	has a datatype, or SIXBIT (TOPS-20) or ASCII_8 (VMS/PRO), if it reaches
!	the top record node without finding a datatype.
!
!  CALLING SEQUENCE:
!
!	data_type = FIND_DATATYPE (field_blk, sys_org);
!
!  PARAMETERS:
!
!	field_blk	Address of the member block in question
!	sys_org		System of origin code (sys_lcg or sys_8bit/sys_pro)
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	Returns the DIL datatype for the field.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE FIND_DATATYPE (field_blk, sys_org) =
BEGIN

MAP
    field_blk:		REF crx_member;

LOCAL
    current_member:	REF crx_member,
    current_parent:	REF crx_member,
    datatype;
! If field has a datatype, return it:

IF (.field_blk [CRM$W_DATATYPE] NEQ DIU$K_DT_OVERLAY) AND
    (.field_blk [CRM$W_DATATYPE] NEQ DIU$K_DT_STRUCTURE)
    THEN RETURN .field_blk [CRM$W_DATATYPE];

! Try a depth-first search of the field's children looking for a usable
! datatype:

datatype = FIND_DATATYPE_WALKER (.field_blk, 0);
IF .datatype NEQ 0
    THEN RETURN .datatype;

! Look for an encompassing structure with a datatype, and return that:

current_member = .field_blk;
current_parent = .field_blk [CRM$A_PREVIOUS];

WHILE TRUE DO BEGIN
    IF (.current_parent [CRM$B_ID] NEQ CRX$K_RECORD)
	THEN WHILE (.current_parent [CRM$A_CHILDREN] NEQ .current_member)
	    DO BEGIN	! Still in sibling group
	    current_member = .current_parent;
	    current_parent = .current_member [CRM$A_PREVIOUS];
	    END;

!   Found parent or the top record node:

    IF .current_parent [CRM$B_ID] EQL CRX$K_RECORD
	THEN IF .sys_org EQL sys_lcg
	    THEN RETURN DIX$K_DT_SIXBIT
	    ELSE RETURN DIX$K_DT_ASCII_8;

!   Not the record node yet.  If this structure has a datatype, return that.

    IF .current_parent [CRM$W_DATATYPE] NEQ 0
	THEN RETURN .current_parent [CRM$W_DATATYPE];

!   Try next higher encompassing structure.

    current_member = .current_parent;
    current_parent = .current_member [CRM$A_PREVIOUS];
    END

END;
!++
!  FIND_DATATYPE_WALKER  (FNDTYW)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine is called by FIND_DATATYPE to find the datatype of the
!	first child of the field in question found by a depth-first search,
!	if there is one.  Otherwise it will return 0.
!
!  CALLING SEQUENCE:
!
!	status = FIND_DATATYPE_WALKER (field_blk, depth);
!
!  PARAMETERS:
!
!	field_blk	Address of the member block in question
!	depth		Recursion depth
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	Returns the datatype if there is one.
!	Returns zero otherwise.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
ROUTINE FIND_DATATYPE_WALKER (field_blk, depth) =
BEGIN

MAP
    field_blk:		REF crx_member;	! Member block in question

LOCAL
    current_member:	REF crx_member,	! Current member block
    datatype;				! Datatype in recursive call, or zero
IF .field_blk [CRM$B_ID] NEQ CRX$K_MEMBER
    THEN RETURN 0;

current_member = .field_blk;

WHILE (.current_member NEQA NULL_PTR) DO
    BEGIN

    IF .current_member [CRM$W_DATATYPE] NEQ DIU$K_DT_OVERLAY
	AND .current_member [CRM$W_DATATYPE] NEQ DIU$K_DT_STRUCTURE
	THEN RETURN .current_member [CRM$W_DATATYPE];

    IF .current_member [CRM$A_ChILDREN] NEQA NULL_PTR
	THEN BEGIN
	datatype = FIND_DATATYPE_WALKER
	    (.current_member [CRM$A_CHILDREN], .depth+1);
	IF .datatype NEQ 0
	    THEN RETURN .datatype;
	END;

    IF (.depth NEQ 0)
	THEN current_member = .current_member [CRM$A_NEXT]
	ELSE RETURN 0;

    END;

RETURN 0;

END;
!++
!  DIU$FIND_FIELD (FNDFLD)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine finds a field's member block without collecting any
!	auxillary information.
!
!  CALLING SEQUENCE:
!
!	status = DIU$FIND_FIELD (fqn, root, member);
!
!  PARAMETERS:
!
!	fqn		Fully-qualified name list of field to find
!	root		Root of tree to look for matching member block in
!	member		Set to address of matching member block, if any
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	TRUE if OK, "member" is set up
!	FALSE if not OK, "member" is not set up
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE DIU$FIND_FIELD (fqn, root, member) =
BEGIN

MAP
    fqn:	REF crx_stringlist,	! Fully-qualified name to find
    root:	REF crx_member,		! Root of tree to look in
    member:	REF crx_member;		! Member block found

RETURN FIND_MATCHING_MEMBER (.fqn, .root, .member, 0);

END;
!++
!  FIND_MATCHING_MEMBER (FNDMTC)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine finds a member block matching a fully-qualified-name list.
!
!  CALLING SEQUENCE:
!
!	status = FIND_MATCHING_MEMBER (fqn, root, member, dim);
!
!  PARAMETERS:
!
!	fqn		Fully-qualified-name list of field to find
!	root		Root of tree to look for matching member block in
!	member		Set to address of matching member block, if any
!	dim		Set to address of dimension list for matching member
!			unless a null pointer is passed
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	True if OK, member and dim are set up.
!	False if not OK, member and dim are not set up.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE FIND_MATCHING_MEMBER (fqn, root, member, dim) =
BEGIN

MAP
    fqn:	REF crx_stringlist,	! Fully-qualified name to find
    root:	REF crx_member,		! Root of tree to look in
    member:	REF crx_member,		! Member block found
    dim:	REF dims;		! Dimension list

LOCAL
    last_dims:	REF dims
		INITIAL (NULL_PTR),	! Last dims node in list
    new_dims:	REF dims
		INITIAL (NULL_PTR),	! New dims node
    new_root:	REF crx_member,		! Sibling of 'root'
    status;				! Return status
! If the tree to search is null, this path has failed.

IF .root EQLA NULL_PTR
    THEN RETURN FALSE;

! Determine what to try based on what type of node is at the root.
! Legitimate roots here are records, members, and overlays.

SELECTONE .root [CRM$B_ID] OF
    SET

    [CRX$K_RECORD]:			! Record root:
	BEGIN				! Recurse on the subtree of members
	LOCAL record_node: REF crx_record;
	record_node = .root;
	status = FIND_MATCHING_MEMBER (.fqn, .record_node [CRX$A_ROOT],
	    .member, .dim);
	RETURN .status;
	END;				! Record root

    [CRX$K_OVERLAY]:			! Variant:
	BEGIN				! Recurse on the subtree of members
	LOCAL overlay_node: REF crx_overlay;
	overlay_node = .root;
	WHILE (.overlay_node NEQA NULL_PTR)
	    DO BEGIN			! Loop to try subtrees of overlays
	    status = FIND_MATCHING_MEMBER (.fqn, .overlay_node [CRO$A_FIELDS],
		.member, .dim);
	    IF .status
		THEN RETURN TRUE;	! Found it!
	    overlay_node = .overlay_node [CRO$A_NEXT];
	    END;			! Loop to try subtrees of overlays
	RETURN FALSE;			! Does not match here
	END;				! Variant

    [CRX$K_MEMBER]:			! Member node:
	BEGIN
	new_root = .root;
	WHILE (.new_root NEQA NULL_PTR)
	    DO BEGIN			! Try siblings at this level

!	    Save the dimension list, if any, in case this path obtains.
!	    If this path fails, back out the dimension list if necessary.

	    IF (.new_root [CRM$B_DIMENSIONS_CNT] GTR 0)
		AND (.DIM NEQA NULL_PTR)
		THEN BEGIN		! Has dimensions and we want them
		    MAKE_DIMS (new_dims, .new_root);
		    IF ..dim EQLA NULL_PTR
			THEN .dim = .new_dims
			ELSE BEGIN	! Add to list
			    last_dims = ..dim;
			    WHILE (.last_dims [DIMS$A_NEXT] NEQA NULL_PTR)
				DO last_dims = .last_dims [DIMS$A_NEXT];
			    last_dims [DIMS$A_NEXT] = .new_dims;
			    new_dims [DIMS$A_PREVIOUS] = .last_dims;
			    END;	! Add to list
		    END;		! Has dimensions

!	    See if we have a match so far:

	    IF (.new_root [CRM$B_NAME_LENGTH] EQL .fqn [CRS$W_STRING_LENGTH])
		AND CH$EQL (.new_root [CRM$B_NAME_LENGTH],
		CH$PTR (new_root [CRM$T_NAME]),
		.fqn [CRS$W_STRING_LENGTH], .fqn [CRS$A_STRING], %C' ')

		THEN			! Found a match so far
		IF .fqn [CRS$A_NEXT] NEQA NULL_PTR
		    THEN BEGIN		! More to go, recurse on children
		    status = FIND_MATCHING_MEMBER (.fqn [CRS$A_NEXT],
			.new_root [CRM$A_CHILDREN], .member, .dim);
		    RETURN .status;
		    END
		    ELSE BEGIN		! No more names, found it!
		    .member = .new_root;
		    RETURN TRUE;
		    END;

!	    Did not match so far.  Try children - incomplete name?
	    status = FIND_MATCHING_MEMBER (.fqn, .new_root [CRM$A_CHILDREN],
		    .member, .dim);
	    IF .status
		THEN RETURN TRUE;	! Found it

!	    Not below here in the tree, so try next sibling.

!	    Back out dims here, if necessary.

	    IF (.new_root [CRM$B_DIMENSIONS_CNT] NEQ 0) AND
		(.DIM NEQA NULL_PTR)
		THEN BEGIN		! Has dimensions and we want them
		    IF ..dim EQLA .new_dims
			THEN .dim = NULL_PTR
			ELSE BEGIN	! Find last dims node
			    last_dims = ..dim;
			    new_dims = .last_dims [DIMS$A_NEXT];
			    WHILE .new_dims [DIMS$A_NEXT] NEQA NULL_PTR
				DO BEGIN	! Walk dims nodes
				    last_dims = .new_dims;
				    new_dims = .new_dims [DIMS$A_NEXT];
				    END;	! Walk dims nodes
			    last_dims = .new_dims [DIMS$A_PREVIOUS];
			    last_dims [DIMS$A_NEXT] = NULL_PTR;
			    END;	! Find last dims node
		    DIU$DEL_DIMS (.new_dims);
		    END;		! Has dimensions

	    new_root = .new_root [CRM$A_NEXT];
	    END;			! Loop to try siblings at this level

	RETURN FALSE;			! No match anywhere
	END;				! Member node

    [OTHERWISE]:			! Something else?!
	RETURN FALSE;

    TES;

END;
!++
!  FIND_NAMES_IN_TREES (FNDNAM)
!
!  FUNCTIONAL DESCRIPTION:
!
!	Looks up source fully-qualified-name list in the source record
!	description tree and the destination fully-qualified-name list in the
!	destination record description tree and returns the addresses of the
!	member blocks thus found.
!
!  CALLING SEQUENCE:
!
!	status = FIND_NAMES_IN_TREES (source_fqn, source_root, dest_fqn,
!		dest_root, dest_root, source_member, dest_member,
!		source_dim, dest_dim);
!
!  PARAMETERS:
!
!	source_fqn	Source field fully-qualified-name list
!	source_root	Root of source record description tree
!	dest_fqn	Destination field fully-qualified-name list
!	dest_root	Root of destination record description tree
!	source_member	Set to address of the matching source member block
!	dest_member	Set to address of the matching destination member block
!	source_dim	Set to the source dimension list
!	dest_dim	Set to the destination dimension list
!
!  IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR	Pointer to current lexical token.
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	TRUE if OK.
!	FALSE if not OK.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE FIND_NAMES_IN_TREES (source_fqn, source_root, dest_fqn,
	dest_root, source_member, dest_member, source_dim, dest_dim) =
BEGIN

MAP
    source_root:	REF crx_member,		! Source tree
    dest_root:		REF crx_member,		! Destination tree
    source_member:	REF crx_member,		! Source member block
    dest_member:	REF crx_member;		! Destination member block

LOCAL
    status;					! Return status

status = FIND_MATCHING_MEMBER (.source_fqn, .source_root, .source_member,
	.source_dim);
IF NOT .status
    THEN BEGIN
    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
	'Field name not found in source record description');
    DIU$DEL_DIMS (..source_dim);
    FREE_STRINGLIST (..source_fqn);
    RETURN FALSE;
    END;

status = FIND_MATCHING_MEMBER (.dest_fqn, .dest_root, .dest_member, .dest_dim);
IF NOT .status
    THEN BEGIN
    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
	'Field name not found in destination record description');
    DIU$DEL_DIMS (..source_dim);
    DIU$DEL_DIMS (..dest_dim);
    FREE_STRINGLIST (..source_fqn);
    FREE_STRINGLIST (..dest_fqn);
    RETURN FALSE;
    END;

RETURN TRUE;

END;
!++
!  FIX_COPY_TEMPLATE (FIXCPY)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine maps the datatypes in a COPY template copied from CDD-32
!	to DIL datatypes.  It may need to be modified in order to map the
!	datatypes in a COPY template copied from DTR-20.
!
!  CALLING SEQUENCE:
!
!	FIX_COPY_TEMPLATE (member, level);
!
!  INPUT PARAMETERS:
!
!	member		Address of member block at root of COPY template
!	level		Level, measured from COPY template root, of member
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	The datatypes of "member" and all subordinate nodes are mapped from
!	CDD-32 (or DTR-20) to DIL datatypes.
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE FIX_COPY_TEMPLATE (member, level) : NOVALUE =

BEGIN

MAP
    member:	REF crx_member;

%IF %BLISS (BLISS32) %THEN
! Might as well not have this here for BLISS36 until we support DTR-20 templates

LOCAL
    current_member:	REF crx_member,
    current_overlay:	REF crx_overlay,
    new_datatype;

EXTERNAL ROUTINE
    DIU$MAP_DATATYPES;

LITERAL this_sys = %BLISS36 (sys_lcg)   %BLISS32 (sys_8bit);
LITERAL this_src = %BLISS36 (dtr20_src) %BLISS32 (cdd32_src);

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

IF .member [CRM$B_ID] EQL CRX$K_MEMBER
    THEN BEGIN	! Member node (may be at level 0)

    current_member = .member;

    DO BEGIN
	IF .current_member [CRM$W_DATATYPE] NEQ 0
	    THEN BEGIN	! It has a datatype, so map it
		new_datatype = DIU$MAP_DATATYPES (this_sys,
		    .current_member [CRM$W_DATATYPE], default_typ,
		    this_src, FALSE);
		current_member [CRM$W_DATATYPE] = .new_datatype;
	    END;

	! Indicate that we have mapped the datatype:

	current_member [CRM$V_FACILITY_USE_5] = DIL_SRC;

	FIX_COPY_TEMPLATE (.current_member [CRM$A_CHILDREN], .level+1);

	IF .level EQL 0		! Do NOT iterate on siblings of template root
	    THEN RETURN;

	current_member = .current_member [CRM$A_NEXT];		! Iterate

    END UNTIL .current_member EQLA NULL_PTR;

END

ELSE BEGIN	! Overlay node (cannot be at level 0)

    current_overlay = .member;

    DO BEGIN	! Do member nodes below each overlay
	FIX_COPY_TEMPLATE (.current_overlay [CRO$A_FIELDS], .level+1);
	current_overlay = .current_overlay [CRO$A_NEXT];
    END UNTIL .current_overlay EQLA NULL_PTR;

END;

%FI
RETURN;

END;
!++
!  FIX_VARIANTS (FIXVAR)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine converts fields marked as FLD$K_VARIANT into
!	crx_overlay nodes.
!	This cannot be done earlier because the facility_use_1 flag and the
!	additional_block are needed to create the tree structure (see code in
!	DEFINE_FIELD and END_SET).
!
!  CALLING SEQUENCE:
!
!	FIX_VARIANTS (member);
!
!  INPUT PARAMETERS:
!
!	member		Address of member node
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE FIX_VARIANTS (member: VOLATILE REF crx_member): NOVALUE =
BEGIN

!   Could already have an overlay node here as the result of a COPY.

    IF .member [CRM$B_ID] EQL CRX$K_OVERLAY
	THEN RETURN

	ELSE BEGIN	! A member node

    BIND
	ADDITIONAL_BLK = .MEMBER [crm$a_facility]: crx_additional;

    LOCAL
	TEMP_LITLIST	: REF crx_literal_list,
	OVERLAY_NODE	: REF crx_overlay,
	TEMP_NODE	: REF crx_member;

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called FIX_VARIANTS'));

    IF .MEMBER [crm$a_next] NEQA NULL_PTR
	THEN FIX_VARIANTS (.MEMBER [crm$a_next]);

    IF .MEMBER [crm$a_children] NEQA NULL_PTR
	THEN FIX_VARIANTS (.MEMBER [crm$a_children]);

    IF additional_blk eqla NULL_PTR	! Must have been a COPY template...
	THEN RETURN;			!  so nothing to do here

    IF .ADDITIONAL_BLK [cra$l_type] EQL FLD$K_VARIANT
	THEN BEGIN		! Member should become overlay
	    $XPO_GET_MEM (FULLWORDS = diu$s_crx_overlay, RESULT = OVERLAY_NODE,
		FILL = 0);
	    OVERLAY_NODE [cro$b_id] = CRX$K_OVERLAY;
	    OVERLAY_NODE [cro$a_previous] = .MEMBER [crm$a_previous];

	    TEMP_NODE = .MEMBER [crm$a_previous];
	    IF .TEMP_NODE NEQA NULL_PTR
		THEN IF .TEMP_NODE [crm$a_next] eqla .MEMBER
		    THEN TEMP_NODE [crm$a_next] = .OVERLAY_NODE;
	    IF .TEMP_NODE NEQA NULL_PTR
		THEN IF .TEMP_NODE [crm$a_children] EQLA .MEMBER
		    THEN TEMP_NODE [crm$a_children] = .OVERLAY_NODE;

	    OVERLAY_NODE [cro$a_next] = .MEMBER [crm$a_next];

	    TEMP_NODE = .MEMBER [crm$a_next];
	    IF .TEMP_NODE NEQA NULL_PTR
		THEN IF .TEMP_NODE [crm$a_previous] EQLA .MEMBER
		    THEN TEMP_NODE [crm$a_previous] = .OVERLAY_NODE;

	    OVERLAY_NODE [cro$w_fields_cnt] = .MEMBER [crm$w_children_cnt];
	    OVERLAY_NODE [cro$a_fields] = .MEMBER [crm$a_children];
	    TEMP_NODE = .MEMBER [crm$a_children];
	    IF .TEMP_NODE [crm$a_previous] EQLA .MEMBER
		THEN TEMP_NODE [crm$a_previous] = .OVERLAY_NODE;
	    OVERLAY_NODE [cro$l_max_length] = .MEMBER [crm$l_length];
	    OVERLAY_NODE [cro$l_min_offset] = .MEMBER [crm$l_offset];
	    OVERLAY_NODE [cro$l_max_member_length] =
		.ADDITIONAL_BLK [cra$l_max_member_length];
	    OVERLAY_NODE [cro$l_min_member_offset] =
		.MEMBER [crm$l_member_offset];
	    OVERLAY_NODE [cro$a_tag_values] = .MEMBER [crm$a_tag_variable];

	    TEMP_LITLIST = .MEMBER [crm$a_tag_variable];
	    IF .TEMP_LITLIST NEQA NULL_PTR
		THEN IF .TEMP_LITLIST [crl$a_previous] EQLA .MEMBER
		    THEN TEMP_LITLIST [crl$a_previous] = .OVERLAY_NODE;

	    IF .TEMP_LITLIST NEQA NULL_PTR
		THEN OVERLAY_NODE [cro$w_tag_values_cnt] = 1;
	    OVERLAY_NODE [cro$l_total_length] = .MEMBER [crm$l_member_length];
	    $XPO_FREE_MEM (BINARY_DATA =
		(cra$s_crx_additional, ADDITIONAL_BLK, FULLWORDS));
	    $XPO_FREE_MEM (BINARY_DATA =
		(diu$s_crx_member, .MEMBER, FULLWORDS));
	END;
END;		! Else clause for member nodes

END;
!++
!  FREE_DIMENSIONS (FREDIM)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine frees a list of dimension blocks.
!
!  CALLING SEQUENCE:
!
!	FREE_DIMENSIONS (dimension);
!
!  INPUT PARAMETERS:
!
!	dimension	Address of a list of crx_dimension nodes
!
!  IMPLICIT INPUTS:
!
!	none
!
!  IMPLICIT OUTPUTS:
!
!	none
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
GLOBAL ROUTINE FREE_DIMENSIONS (dimension) : NOVALUE =

BEGIN

    MAP
	DIMENSION: REF CRX_DIMENSION;

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called FREE_DIMENSIONS'));

    IF .DIMENSION [crd$a_next] NEQA NULL_PTR
	THEN FREE_DIMENSIONS (.DIMENSION [crd$a_next]);

    IF .DIMENSION [crd$a_depend_item] NEQA NULL_PTR
	THEN FREE_STRINGLIST (.DIMENSION [crd$a_depend_item]);

    $XPO_FREE_MEM (BINARY_DATA = (diu$S_CRX_DIMENSION, .DIMENSION, FULLWORDS));

END;
!++
!  FREE_LITLIST (FRELIT)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine frees a literal_list.
!
!  CALLING SEQUENCE:
!
!	FREE_LITLIST (litlist);
!
!  INPUT PARAMETERS:
!
!	litlist		Address of a list of literal_lists
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE FREE_LITLIST (litlist): NOVALUE =

BEGIN

    MAP
	litlist: REF crx_literal_list;

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called FREE_LITLIST'));

    IF .LITLIST [crl$a_next] NEQA NULL_PTR
	THEN FREE_LITLIST (.LITLIST [crl$a_next]);

    IF .LITLIST [crl$a_literals] NEQA NULL_PTR
	THEN FREE_STRINGLIST (.LITLIST [crl$a_literals]);

    $XPO_FREE_MEM (BINARY_DATA = (diu$S_CRX_LITERAL_LIST, .LITLIST, FULLWORDS));

END;
!++
!  FREE_MEMBERS (FREMEM)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine frees everything pointed to by a member block (crx_member)
!	or an overlay block (crx_overlay).
!
!  CALLING SEQUENCE:
!
!	FREE_MEMBERS (member);
!
!  INPUT PARAMETERS:
!
!	member		Address of a crx_member block
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE FREE_MEMBERS (member) : NOVALUE =

BEGIN

    MAP
	MEMBER: REF CRX_MEMBER;

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called FREE_MEMBERS'));

    IF .member [CRM$B_ID] EQL CRX$K_MEMBER
	THEN BEGIN		! A member node

!	No need to free a_descriptions, since we don't make any.

!	IF .MEMBER [crm$a_description] NEQA NULL_PTR
!	    THEN FREE_STRINGLIST (.MEMBER [crm$a_description]);

	IF .MEMBER [crm$a_next] NEQA NULL_PTR
	    THEN FREE_MEMBERS (.MEMBER [crm$a_next]);	! Siblings

	IF .MEMBER [crm$w_source_length] NEQ 0
	    THEN $XPO_FREE_MEM (STRING = (.MEMBER [crm$w_source_length],
		.MEMBER [crm$a_source_type]));

	IF .MEMBER [crm$a_children] NEQA NULL_PTR
	    THEN FREE_MEMBERS (.MEMBER [crm$a_children]);	! Children

!	We do not use crm$a_reference field

!	IF .MEMBER [crm$a_reference] NEQA NULL_PTR
!	    THEN FREE_STRINGLIST (.MEMBER [crm$a_reference]);

	IF .MEMBER [crm$a_tag_variable] NEQA NULL_PTR
	    THEN FREE_STRINGLIST (.MEMBER [crm$a_tag_variable]);

	IF .MEMBER [crm$a_dimensions] NEQA NULL_PTR
	    THEN FREE_DIMENSIONS (.MEMBER [crm$a_dimensions]);	! Dimensions

	IF .member [CRM$A_FACILITY] NEQA NULL_PTR
	    THEN $XPO_FREE_MEM		! Note: BINDing the additional block
	    (BINARY_DATA = (cra$s_crx_additional,! gives a compiler bug (binds
	    .member [CRM$A_FACILITY], FULLWORDS));! to member block instead)!

	IF .MEMBER [crm$a_initial_value] NEQA NULL_PTR
	    THEN IF NOT .MEMBER [crm$v_facility_use_3]
		THEN
		    $XPO_FREE_MEM (		! Characters
		    STRING = (.member [CRM$W_INITIAL_LENGTH],
		    .member [CRM$A_INITIAL_VALUE]))
		ELSE $XPO_FREE_MEM (		! Words
		    BINARY_DATA = (.member [CRM$W_INITIAL_LENGTH],
		    .member [CRM$A_INITIAL_VALUE], FULLWORDS));

	$XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_member, .member, FULLWORDS));

    END

    ELSE BEGIN				! An overlay node

	LOCAL overlay: REF crx_overlay;

	overlay = .member;

	IF .overlay [CRO$A_NEXT] NEQA NULL_PTR
	    THEN FREE_MEMBERS (.overlay [CRO$A_NEXT]);

	IF .overlay [CRO$A_FIELDS] NEQA NULL_PTR
	    THEN FREE_MEMBERS (.overlay [CRO$A_FIELDS]);

	IF .overlay [CRO$A_TAG_VALUES] NEQA NULL_PTR
	    THEN FREE_LITLIST (.overlay [CRO$A_TAG_VALUES]);

	$XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_overlay, .overlay, FULLWORDS));

	END;

END;
!++
!  FREE_RECORD (FREREC)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine frees a crx_record node and all subtrees.
!
!  CALLING SEQUENCE:
!
!	FREE_RECORD (record_ptr);
!
!  INPUT PARAMETERS:
!
!	record_ptr	Address of a crx_record node
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE FREE_RECORD (record_ptr) : NOVALUE =
BEGIN
    MAP record_ptr: REF crx_record;

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called FREE_RECORD'));

!   Free descriptions: (commented out because we make no descriptions)

!   IF .RECORD_PTR [crx$a_description] NEQA NULL_PTR
!	THEN FREE_STRINGLIST (.RECORD_PTR [crx$a_description]);

!   Free member tree, if any.

    IF .RECORD_PTR [CRX$A_ROOT] NEQU NULL_PTR
	THEN FREE_MEMBERS (.record_ptr [CRX$A_ROOt]);

!   crx$a_facility not used

    $XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_record, .record_ptr, FULLWORDS));

    RECORD_PTR = NULL_PTR;

END;
!++
!  FREE_STRINGLIST (FRESTR)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine frees a stringlist.
!
!  CALLING SEQUENCE:
!
!	FREE_STRINGLIST (stringlist);
!
!  INPUT PARAMETERS:
!
!	STRINGLIST	Address of a list of stringlists
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE FREE_STRINGLIST (stringlist): NOVALUE =

BEGIN

    MAP
	STRINGLIST: REF crx_stringlist;

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called FREE_STRINGLIST'));

    IF .stringlist EQL 0 THEN RETURN;

    IF .STRINGLIST [CRS$B_ID] EQL CRX$K_STRINGLIST
	THEN BEGIN		! A stringlist node

	IF .STRINGLIST [crs$a_next] NEQA NULL_PTR
	    THEN FREE_STRINGLIST (.STRINGLIST [crs$a_next]);

	$XPO_FREE_MEM (STRING = (.STRINGLIST [crs$w_string_length],
	    .STRINGLIST [crs$a_string]));

	$XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_stringlist, .STRINGLIST,
	    FULLWORDS));
	END			! A stringlist node

	ELSE			! A tag field FFD node
	    $XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_tag_ffd, .stringlist,
		FULLWORDS));

END;
!++
!  INIT_LITERAL (INTLIT)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine initializes a literal list block.  The block should be
!	zero-filled when it is allocated.
!
!  CALLING SEQUENCE:
!
!	INIT_LITERAL (literal_list);
!
!  INPUT PARAMETERS:
!
!	literal_list	Literal list to be initialized
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE INIT_LITERAL (literal_list) : NOVALUE =
BEGIN

    MAP
	LITERAL_LIST: REF crx_literal_list;

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called INIT_LITERAL'));

    LITERAL_LIST [crl$b_id] = crx$k_literal_list;

END;
!++
!  INIT_MEMBER (INTMEM)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine initializes a member block (crx_member).  The block
!	should be zero-filled when it is allocated.
!
!  CALLING SEQUENCE:
!
!	INIT_MEMBER (member, previous, name, source_loc);
!
!  INPUT PARAMETERS:
!
!	member		Address of crx_member node to initialize
!	previous	Address of previous node
!	name		String description of name of field
!	source_loc	Source locator
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
GLOBAL ROUTINE INIT_MEMBER (member, previous, name, source_loc) : NOVALUE =
BEGIN

    MAP
	MEMBER : REF crx_member,
	NAME: REF $STR_DESCRIPTOR (CLASS=DYNAMIC);

    LOCAL
	ADD_BLK : REF crx_additional;

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called INIT_MEMBER'));

    MEMBER [crm$a_previous] = .PREVIOUS;
    MEMBER [crm$b_id] = crx$k_member;
    MEMBER [crm$b_name_length] = .NAME [str$h_length];
    MEMBER [crm$l_total_cells] = 1;
    MEMBER [crm$v_facility_use_5] = DIL_SRC;
    ch$move ((if .NAME [str$h_length] LEQ 31
	THEN .NAME [str$h_length] ELSE 31),
	.NAME [str$a_pointer], ch$ptr (MEMBER [crm$t_name]));
    MEMBER [crm$w_datatype] = 0;

!   Create additional block and hook it in:

    $XPO_GET_MEM (FULLWORDS = cra$s_crx_additional, FILL = 0,
	RESULT = ADD_BLK);
    MEMBER [crm$a_facility] = .ADD_BLK;
    ADD_BLK [cra$l_locator] = .source_loc;

END;
!++
!  INIT_STRINGLIST (INTSTR)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine initializes a stringlist block.  The block should be
!	zero-filled when it is allocated.
!
!  CALLING SEQUENCE:
!
!	INIT_STRINGLIST (stringlist);
!
!  INPUT PARAMETERS:
!
!	stringlist	Stringlist to be initialized
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE INIT_STRINGLIST (stringlist) : NOVALUE =
BEGIN

    MAP
	STRINGLIST : REF crx_stringlist;

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called INIT_STRINGLIST'));

    STRINGLIST [crs$b_id] = crx$k_stringlist;

END;
!++
!  MAKE_DIMS  (MAKDIM)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine makes a dims node.  It should only be called for
!	member blocks which have dimensions.
!
!  CALLING SEQUENCE:
!
!	MAKE_DIMS (new_dims, member);
!
!  PARAMETERS:
!
!	new_dims	Set to address of the new dims node
!	member		Address of the member block
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE MAKE_DIMS (new_dims, p_node) : NOVALUE =
BEGIN

LOCAL
     member : REF crx_member,           ! if p_node is a member block
     dims_node : REF dims;              ! if p_node is a DIMS node

LOCAL
     my_dims : REF dims;                ! new DIMS node

! Make and fill a new DIMS node

member = .p_node;
dims_node = .p_node;

$XPO_GET_MEM (FULLWORDS = dims$k_size, RESULT = .new_dims, FILL = 0);
my_dims = ..new_dims;
my_dims [DIMS$B_ID] = DIU$K_DIMSNODE;

SELECTONE .member[CRM$B_ID] OF
SET
[CRX$K_MEMBER] :                        ! new DIMS being made from member info
       BEGIN
       my_dims [DIMS$B_DIMENSIONS_CNT] = .member [CRM$B_DIMENSIONS_CNT];
       my_dims [DIMS$A_LIST] = .member [CRM$A_DIMENSIONS];
       my_dims [DIMS$L_TOT_CELLS] = .member [CRM$L_TOTAL_CELLS];
       END;

[DIU$K_DIMSNODE] :                      ! DIMS is being copied to a new DIMS
       BEGIN
       my_dims [DIMS$B_DIMENSIONS_CNT] = .dims_node [DIMS$B_DIMENSIONS_CNT];
       my_dims [DIMS$A_LIST] = .dims_node [DIMS$A_LIST];
       my_dims [DIMS$L_TOT_CELLS] = .dims_node [DIMS$L_TOT_CELLS];
       END;

TES;
RETURN;
END;
!++
!  MAKE_FQN  (MAKFQN)
!
!  FUNCTIONAL DESCRIPTION:
!
!       This routine makes an FQN stringlist node.
!
!  CALLING SEQUENCE:
!
!       MAKE_FQN (new_fqn, node);
!
!  PARAMETERS:
!
!       new_fqn		Set to address of the new FQN stringlist node
!	node		Address of the member block from which the FQN
!                       information is to be extracted OR address of the
!                       old FQN which is being copied to this new FQN.
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it
!	calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE MAKE_FQN (new_fqn, p_node) : NOVALUE =
BEGIN

LOCAL
     member : REF crx_member,           ! if p_node is a member block
     fqn_node : REF crx_stringlist;     ! if p_node is an FQN stringlist

LOCAL
     my_fqn : REF crx_stringlist;       ! new FQN node

! Make and fill a new fqn node

member = .p_node;
fqn_node = .p_node;

$XPO_GET_MEM (FULLWORDS = diu$s_crx_stringlist, RESULT = .new_fqn, FILL = 0);
my_fqn = ..new_fqn;
my_fqn [CRS$B_ID] = CRX$K_STRINGLIST;

SELECTONE .member[CRM$B_ID] OF
SET
[CRX$K_MEMBER] :                        ! new FQN being made from member info
       BEGIN
       ! allocate memory for the name string
       $XPO_GET_MEM (CHARACTERS = .member [CRM$B_NAME_LENGTH],
                     RESULT = my_fqn [CRS$A_STRING],
                     FILL = ' ');

       ! copy member's name into new FQN string
       CH$MOVE (.member [CRM$B_NAME_LENGTH],
                CH$PTR (member [CRM$T_NAME]),
                .my_fqn [CRS$A_STRING]);

       ! save name length
       my_fqn [CRS$W_STRING_LENGTH] = .member [CRM$B_NAME_LENGTH];

       END;

[CRX$K_STRINGLIST] :                    ! an FQN is being copied to a new FQN
       BEGIN
       ! allocate memory for the name string
       $XPO_GET_MEM (CHARACTERS = .fqn_node [CRS$W_STRING_LENGTH],
                     RESULT = my_fqn [CRS$A_STRING],
                     FILL = ' ');

       ! copy old FQN's name into new FQN's name string
       CH$MOVE (.fqn_node [CRS$W_STRING_LENGTH],
                .fqn_node [CRS$A_STRING],
                .my_fqn [CRS$A_STRING]);
                 
       ! save name length
       my_fqn [CRS$W_STRING_LENGTH] = .fqn_node [CRS$W_STRING_LENGTH];

       END;

TES;
RETURN;
END;
!++
!  MAKE_TRANSFORM (MAKTRA)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine makes a transform node and marks the fields
!	involved as participants in a transform.
!
!  CALLING SEQUENCE:
!
!	MAKE_TRANSFORM (source_fqn, dest_fqn, source_member,
!		dest_member, source_dim, dest_dim, new_trans);
!
!  PARAMETERS:
!
!	source_fqn	Source fully-qualified name
!	dest_fqn	Destination fully-qualified name
!	source_member	Address of source member node
!	dest_member	Address of destination member node
!	source_dim	Address of source dimension node
!	dest_dim	Address of destination dimension node
!	new_trans	Set to address of newly-created transform
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE MAKE_TRANSFORM (source_fqn, dest_fqn, source_member, dest_member,
source_dim, dest_dim, new_trans): NOVALUE =
BEGIN

MAP
    source_fqn:		REF crx_stringlist,	! Source name
    dest_fqn:		REF crx_stringlist,	! Destination name
    source_member:	REF crx_member,		! Source member node
    dest_member:	REF crx_member,		! Destination member node
    source_dim:		REF dims,		! Source dimension list
    dest_dim:		REF dims;		! Destination dimension list

LOCAL
    my_trans:		REF transform_str;	! New transform
! Make and fill a new transform node:

$XPO_GET_MEM (FULLWORDS = TRA_SIZE, FILL = 0, RESULT = .new_trans);
my_trans = ..new_trans;
my_trans [TRA_ID] = DIU$K_TRANSFORM;
my_trans [TRA_SRC_ADDR] = .source_member;
my_trans [TRA_SRC_NAM] = .source_fqn;
my_trans [TRA_SRC_DIMS] = .source_dim;
my_trans [TRA_DST_ADDR] = .dest_member;
my_trans [TRA_DST_NAM] = .dest_fqn;
my_trans [TRA_DST_DIMS] = .dest_dim;

! Mark source and destination fields as "used" in case we get a
! MOVE OTHERS MATCHING.

IF .source_member NEQ 0
THEN source_member [CRM$V_FACILITY_USE_2] = TRUE;
IF .dest_member NEQ 0
THEN dest_member [CRM$V_FACILITY_USE_2] = TRUE;

RETURN;

END;
!++
!  NAME_SYNTAX (NAMSYN)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine checks that a field name has proper syntax.
!	The following make a field name illegal:
!	1.  It has 0 or more than 31 characters.
!	2.  It contains characers other than A-Z, 0-9, '$', and '_'.
!	3.  It begins with a character not in A-Z.
!	4.  It ends with a character not in A-Z or 0-9.
!	Note: '*' is legal for no-name fields.
!
!  CALLING SEQUENCE:
!
!	status = NAME_SYNTAX (length.rlu.v, ptr.ra.v, loc.rlu.v);
!
!  INPUT PARAMETERS:
!
!	length		Length of the target field name
!	ptr		Character pointer to the target field name
!	loc		Source locator for field
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	FALSE		Indicates an invalid field name
!	SS$_NORMAL	Indicates a valid field name
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE NAME_SYNTAX (length, ptr, loc) =
BEGIN

!   States for state machine:

    LITERAL
    S_ERROR		= 0,	! Error state
    S_ERROR_1		= 1,	! Invalid character
    S_ERROR_2		= 2,	! First character in name not A-Z
    S_ERROR_3		= 3,	! Last character in name not A-Z or 0-9
    S_ASTR		= 4,	! * (no-name field)
    S_START		= 5,	! Start state
    S_NORMAL		= 6,	! Last character was A-Z or 0-9
    S_SPEC		= 7,	! Last character was '$' or '_'
    S_END		= 8,	! Halt (not in state table)

!   Classes of characters that might appear in a field name:

    F_NULL		= 0,	! (an invalid character)
    F_ASTR		= 1,	! '*'
    F_CHAR		= 2,	! A-Z
    F_NUMB		= 3,	! 0-9
    F_SPEC		= 4,	! '$' and '_'
    F_END		= 5;	! (end of name)

    STRUCTURE
	TABLE [s, f] = [3*6] (TABLE+(S-S_START)*6 + (F-F_NULL))
	    %BLISS32 (<0, 8, 0>);	! In bytes on VAXen

!   State table:

    OWN
	STATE_TABLE:	TABLE PRESET (

	[S_START, F_NULL]	= S_ERROR_1,
	[S_START, F_ASTR]	= S_ASTR,
	[S_START, F_CHAR]	= S_NORMAL,
	[S_START, F_NUMB]	= S_ERROR_2,
	[S_START, F_SPEC]	= S_ERROR_2,
	[S_START, F_END]	= S_END,

	[S_NORMAL, F_NULL]	= S_ERROR_1,
	[S_NORMAL, F_ASTR]	= S_ERROR_1,
	[S_NORMAL, F_CHAR]	= S_NORMAL,
	[S_NORMAL, F_NUMB]	= S_NORMAL,
	[S_NORMAL, F_SPEC]	= S_SPEC,
	[S_NORMAL, F_END]	= S_END,

	[S_SPEC, F_NULL]	= S_ERROR_1,
	[S_SPEC, F_ASTR]	= S_ERROR_1,
	[S_SPEC, F_CHAR]	= S_NORMAL,
	[S_SPEC, F_NUMB]	= S_NORMAL,
	[S_SPEC, F_SPEC]	= S_SPEC,
	[S_SPEC, F_END]		= S_ERROR_3),
!   Character type table:

    CHAR_TABLE: VECTOR [%BLISS32 (256, BYTE)
			%BLISS36 (128)] PRESET (
	[%C'A']	= F_CHAR,
	[%C'B']	= F_CHAR,
	[%C'C']	= F_CHAR,
	[%C'D']	= F_CHAR,
	[%C'E']	= F_CHAR,
	[%C'F']	= F_CHAR,
	[%C'G']	= F_CHAR,
	[%C'H']	= F_CHAR,
	[%C'I']	= F_CHAR,
	[%C'J']	= F_CHAR,
	[%C'K']	= F_CHAR,
	[%C'L']	= F_CHAR,
	[%C'M']	= F_CHAR,
	[%C'N']	= F_CHAR,
	[%C'O']	= F_CHAR,
	[%C'P']	= F_CHAR,
	[%C'Q']	= F_CHAR,
	[%C'R']	= F_CHAR,
	[%C'S']	= F_CHAR,
	[%C'T']	= F_CHAR,
	[%C'U']	= F_CHAR,
	[%C'V']	= F_CHAR,
	[%C'W']	= F_CHAR,
	[%C'X']	= F_CHAR,
	[%C'Y']	= F_CHAR,
	[%C'Z'] = F_CHAR,
	[%C'1']	= F_NUMB,
	[%C'2']	= F_NUMB,
	[%C'3']	= F_NUMB,
	[%C'4']	= F_NUMB,
	[%C'5']	= F_NUMB,
	[%C'6']	= F_NUMB,
	[%C'7']	= F_NUMB,
	[%C'8']	= F_NUMB,
	[%C'9']	= F_NUMB,
	[%C'0']	= F_NUMB,
	[%C'$']	= F_SPEC,
	[%C'_']	= F_SPEC,
	[%C'*']	= F_ASTR);
    LOCAL
	CHAR,
	CHAR_CNT,
	FOUND,
	POINTER,
	STATE;

    CHAR_CNT = 0;
    POINTER = .PTR;
    STATE = S_START;

    INCR I FROM 1 TO .LENGTH DO		! Finite state machine
	BEGIN
	CHAR = CH$RCHAR_A (POINTER);
	FOUND = .CHAR_TABLE [.CHAR];
	STATE = .STATE_TABLE [.STATE, .FOUND];
	CASE .STATE FROM S_ERROR TO S_END OF SET
	    [S_ERROR]:
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM (.loc, 'Illegal field name');
		    RETURN FALSE;
		END;

	    [S_ERROR_1]:
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM
			(.loc, 'Illegal character in name');
		    RETURN FALSE;
		END;

	    [S_ERROR_2]:
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM
			(.loc, 'First character in name invalid');
		    RETURN FALSE;
		END;

	    [S_ERROR_3]:
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM
			(.loc, 'Invalid last character in name');
		    RETURN FALSE;
		END;

	    [S_START]: ;

	    [S_ASTR]:
		IF .LENGTH EQLU 1
		    THEN RETURN SS$_NORMAL
		    ELSE BEGIN
			LSLOCAL_SYNTAX_ERRORM
			    (.loc, 'Illegal character in name');
			RETURN FALSE;
			END;

	    [S_NORMAL]:
		BEGIN
		    CHAR_CNT = .CHAR_CNT + 1;
		    IF .CHAR_CNT GTRU 31
			THEN BEGIN
			    LSLOCAL_SYNTAX_ERRORM (.loc,
				'Field name must be from 1 to 31 characters');
			    RETURN FALSE;
			    END;
		END;

	    [S_SPEC]:
		BEGIN
		    CHAR_CNT = .CHAR_CNT + 1;
		    IF .CHAR_CNT GTRU 31
			THEN BEGIN
			    LSLOCAL_SYNTAX_ERRORM (.loc,
				'Field name must be from 1 to 31 characters');
			    RETURN FALSE;
			    END;
		END;

	    [INRANGE, OUTRANGE]:
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM
			(.loc, 'Illegal field name');
		    RETURN FALSE;
		END;

	    TES;
    END;			! Finite state machine

    IF .STATE_TABLE [.STATE, F_END] NEQU S_END
	THEN IF .STATE_TABLE [.STATE, F_END] EQLU S_ERROR_3
	    THEN BEGIN
		LSLOCAL_SYNTAX_ERRORM
		    (.loc, 'Invalid last character in name');
		RETURN FALSE;
	    END ELSE BEGIN
		LSLOCAL_SYNTAX_ERRORM
		    (.loc, 'Illegal field name');
		RETURN FALSE;
	    END;

    RETURN SS$_NORMAL;

END;
!++
!  PRODUCE_FQN (PRDFQN)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine makes a fully-qualified-name list (FQN) given a
!	descriptor containing a field name which may be partially qualified.
!
!  CALLING SEQUENCE:
!
!	status = PRODUCE_FQN (name, fqn);
!
!  PARAMETERS:
!
!	name		String descriptor of the field name
!	fqn		Address to set to fully-qualified-name list
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	TRUE if OK.
!	FALSE if not OK.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE PRODUCE_FQN (name, fqn) =
BEGIN

MAP
    name:	REF $STR_DESCRIPTOR (),	! Field name
    fqn:	REF crx_stringlist;	! Fully-qualified-name list

LOCAL
    latest_name:	REF crx_stringlist,
    name_end,
    name_start,
    new_name:		REF crx_stringlist,
    rem_length,
    str_length;
! Get rid of old fully-qualified-name, if any.

IF ..fqn NEQA NULL_PTR
    THEN FREE_STRINGLIST (.fqn);
.fqn = NULL_PTR;

! Get the individual names and place them in a list of stringlists.

name_start = .name [STR$A_POINTER];
name_end = .name_start;

WHILE (CH$DIFF (CH$PLUS (.name [STR$A_POINTER], .name [STR$H_LENGTH]),
    .name_end) NEQ 0)
    DO BEGIN				! Loop to get list of names
    $XPO_GET_MEM (FULLWORDS = diu$s_crx_stringlist, RESULT = new_name,
	FILL = 0);
    INIT_STRINGLIST (.new_name);
    IF (..fqn NEQA NULL_PTR)
	THEN BEGIN			! Attach to end of list
	    new_name [CRS$A_PREVIOUS] = .latest_name;
	    latest_name [CRS$A_NEXT] = .new_name;
	    latest_name = .new_name;
	END				! Attach to end of list
	ELSE BEGIN			! Start new list
	    .fqn = .new_name;
	    latest_name = .new_name;
	END;				! Start new list
    rem_length = CH$DIFF (CH$PLUS (.name [STR$A_POINTER],
	.name [STR$H_LENGTH]), .name_start);
    name_end = CH$FIND_CH (.rem_length, .name_start, %C'.');	! Find ending '.'
    IF CH$FAIL (.name_end)		! Goes up to last character
	THEN name_end = CH$PLUS (.name [STR$A_POINTER],
	    .name [STR$H_LENGTH]);
    str_length = CH$DIFF (.name_end, .name_start);
    new_name [CRS$W_STRING_LENGTH] = .str_length;
    $XPO_GET_MEM (CHARACTERS = .str_length, RESULT = new_name [CRS$A_STRING]);
    CH$MOVE (.str_length, .name_start, .new_name [CRS$A_STRING]);
    name_start = CH$PLUS (.name_end, 1);	! Skip over '.'
    END;				! Loop to get list of names

! Clear the name pointer block

$XPO_FREE_MEM (STRING = (.name [STR$H_LENGTH], .name [STR$A_POINTER]));
name [STR$H_LENGTH] = 0;

RETURN TRUE;

END;
!++
!  VALIDATE_FQN (VLDFQN)
!
!  FUNCTIONAL DSCRIPTION:
!
!	Validates each name in a fully-qualified-name list (FQN).
!
!  CALLING SEQUENCE:
!
!	status = VALIDATE_FQN (fqn);
!
!  PARAMETERS:
!
!	fqn		Head of fully-qualified-name list
!
!  IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR	Pointer to current lexical token
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	TRUE if OK.
!	FALSE if not OK.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
GLOBAL ROUTINE VALIDATE_FQN (fqn) =
BEGIN

MAP
    fqn:		REF crx_stringlist;	! Fully-qualified-name list

LOCAL
    current_fqn:	REF crx_stringlist,	! Current fully-qual.-name list
    status;					! Return status

! Walk the FQN calling NAME_SYNTAX for each name.

current_fqn = .fqn;

WHILE (.current_fqn NEQA NULL_PTR)
    DO BEGIN			! Check each name in list for validity
	status = NAME_SYNTAX (.current_fqn [CRS$W_STRING_LENGTH],
	    .current_fqn [CRS$A_STRING],
	    LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR));
	IF NOT .status THEN RETURN .status;
	current_fqn = .current_fqn [CRS$A_NEXT];
	END;

RETURN TRUE;			! Entire list was valid

END;

END
ELUDOM