Google
 

Trailing-Edge - PDP-10 Archives - tops20-v7-ft-dist1-clock - 7-sources/diuacn.bli
There are 4 other files named diuacn.bli in the archive. Click here to see a list.
MODULE DIUACN (%require ('DIUPATSWITCH')
			IDENT = '253') =
BEGIN
!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 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:  ACTION 			DDL and Transform Action Routines
!
!  FACILITY:  DIU
!
!  ABSTRACT:
!
!	This module contains the parser action routines necessary to build
!	the internal data structures.
!
!  ENVIRONMENT:
!
!	All routines run in user access mode.
!
!	These routines are NOT AST reentrant.
!
!  AUTHOR:  Colleen Deininger,	31-JUL-81
!
!++
!
! MODIFICATION HISTORY:
!
!  253  Rename file to DIUACT.BLI
!       Gregory A. Scott 1-Jul-86
!
!  241	In ACTION.BLI routine DEFINE_DTYPE (DEFTYP), add informational message
!	for unsupported datatypes.
!	Sandy Clemens  20-Jun-86
!
!  236  Change library of DIXLIB to DIUDIX.
!       Sandy Clemens  19-Jun-86
!
!	2	Allow debug compilation without debug printout.
!
!	1	Fix to compile with new, larger version of DIXLIB with Bliss36
!		Charlotte Richardson	17-July-85
!	4-Oct-84 (CLR) Convert to compatible Bliss and CRX structures for DIU.
!
!  Edits made to CDDL:
!
!   Version 3.0
!	 2-Apr-84 01732 (CGM) Change SIGNAL_STOPS to SIGNALs.
!	23-Mar-84 01728 (CGM) Allow the scale to be larger than the number of
!	                      digits in the DATATYPE clause.
!	12-Mar-84 01720 (CGM) Fix bug where the length of copied arrays is
!	                      incorrectly computed.
!	23-Feb-84 01694 (CGM) Change FULLY_QUALIFIED_NAME to check for illegal
!	                      version numbers in fully qualified field names.
!	23-Feb-84 01693 (CGM) Remove XPORT use from the CDDL.
!	 6-Jan-84 01473 (CDD) 
!	21-Dec-83 01263 (mrw) 
!	 9-Dec-83 01070 (mrw)  
!	29-Nov-83 01043 (KJM) Check facility of signal.  If CDDL, do not
!	                      output CDDL$_CDDERROR message
!	23-Nov-83 01036 (KJM) NIT
!	23-Nov-83 01034 (KJM) CDDL$_RECNOTCRE message not being printed
!	21-Nov-83 00835 (CDD) 
!	15-Nov-83 00815 (KJM) Move success messages to DDU$$C_CREATE_RECORD
!	 2-Nov-83 00793 (MAB) Take relative version numbers out of CDDL
!	 4-Oct-83 00771 (MRW) moved imbedded CDDL messages to message file
!	27-Sep-83 00770 (MAB) Make sure COPY_LIST gets the right version.
!	 1-Sep-83 00755 (CGM) Adding the INDEXED FOR COBOL BY clause.
!	26-Aug-83 00751 (CGM) Adding support for the DSC$K_DTYPE_VT
!	                      RTL datatype.
!	25-Jul-83 00728 (KJM) Added support for PL/I
!	22-Mar-83 00650 (MAB) Implement CDDL /COPY_LIST qualifier
!	17-Feb-83 00442 (CDD) Promote to a new version.
!
!--
!   Version 2.2
!	24-Jan-83 00258 (KJM) Change DSC$K_DTYPE_V to DSC$K_DTYPE_VU
!	12-Jan-83 00083 (CDD) Change the version number
!	10-Jan-83	(KJM) Flag errors for records without a field
!			      description and structures without a sub-field
!			      description.
!	 7-Dec-82 00044 (KJM) Validate field names
!	16-Sep-82 00022 (CDD) 
!	17-Sep-82	(MIZ)	Fixed bug in /RECOMPILE so the record being
!				recompiled is always put back in the same
!				place it was extracted from.
!--
!	29-Jul-82	(CGM)	Changed error severities, names and messages.
!	22-Jul-82	(CGM)	Added handling for the DBMS datatype synonyms.
!	23-Jun-82	(CGD)	Added FULLY_QUALIFIED_NAME to handle fully
!				qualified names of the form A.B.C where A
!				is at a higher level than C.
!	11-Mar-82	(CGD)	Fixed bug in global error recovery.  FIELD_NAME
!				was not being cleared during recovery.
!	3-Mar-82	(CGD)	Changed DTR MISSING_VALUE and DEFAULT_VALUE's
!				to append a " (for quoted strings) or D (for
!				numbers) to the beginning of the value string.
!	8-FEB-82	(CGD)	Fixed bug - BEGIN_RFA was not being initialized
!				correctly when the DEFINE token was synthetic.
!	13-JAN-82	(CGD)	Added /RECOMPILE option capabilities.
!	11-JAN-82	(CGD)	Added locator parameter to DDU$$C_CREATE_RECORD
!				routine call.
!	30-DEC-81	(CGD)	Added checks for internal semantics,
!				deleted message that tag values are not
!				supported.
!	22-DEC-81	(CGD)	Added DSC$K_DTYPE_ADT for dates.
!	15-DEC-81	(CGD)	Bug fix -- reinitialized STACK_TOP to 0, in
!				ACTION_RTN, when cleaning up a bad record.
!	11-DEC-81	(CGD)	Added check for length of BIT, TEXT,
!				UNSPECIFIED and VARYING STRING fields
!				such that (0 < length < 65536).
!
!--
! 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
    UNDECLARE %QUOTE TRUE, %QUOTE FALSE, 
              %QUOTE STS$K_SEVERE, %QUOTE STS$K_ERROR, %QUOTE STS$K_WARNING,
              %QUOTE STS$K_SUCCESS, %QUOTE SS$_NORMAL, %QUOTE STS$K_INFO;
    LIBRARY 'DIU';
%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 'DIUMLB';			! Datatype mapping library
%IF %BLISS (BLISS32) %THEN
    UNDECLARE %QUOTE $DESCRIPTOR;	! Yet again...
%FI
LIBRARY 'DIUTLB';			! Transform data structures
%IF %BLISS (BLISS32) %THEN
    UNDECLARE %QUOTE $DESCRIPTOR;	! Yet again...
    LIBRARY 'SYS$LIBRARY:STARLET';
%FI
! External routines for debugging:

%if PATBLSEXT_DEBUGGING %then
EXTERNAL ROUTINE TREE: NOVALUE;		! Dump a record description tree
%fi

! External routines (to be found in ACTUTL):

EXTERNAL ROUTINE
COMPUTE_ARRAY_LENGTH: NOVALUE,	! Compute array length
COMPUTE_BYTE_SIZE,		! Compute byte size of field
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 transform
FIND_MATCHING_MEMBER,		! Find matching member block
FIND_NAMES_IN_TREES,		! Look up names used in transform
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_TRANSFORM: NOVALUE,	! Make a transform node
NAME_SYNTAX,			! Check field name syntax
PRODUCE_FQN,			! Make fully-qualified name
VALIDATE_FQN;			! Validate fully-qualified name
! TABLE OF CONTENTS:

FORWARD ROUTINE

ACTION_RTN,			! Driver for semantic actions
CLEAR_ATTRIBUTE_FLAGS : NOVALUE,! Clears attribute flags
CREATE_STR_ATT,			! Creates string attribute structure
DEFINE_DIMENSION,		! Creates a dimension
DEFINE_DTYPE,			! Defines datatype and length
DEFINE_FIELD,			! Creates a field
DEFINE_GROUP_ATTS,		! Define group length and offsets
DEFINE_NUM_ATT,			! Defines numeric attributes
DEFINE_RECORD: NOVALUE,		! Defines record name and description
DEFINE_SCALE,			! Defines scale
DEFINE_TRANSFORM: NOVALUE,	! Complete a transform
END_SET,			! Cleans up at 'END' statement
EXTRACT_NAME: NOVALUE,		! Puts name from token into NAME_BLOCK
FULLY_QUALIFIED_NAME,		! Creates fully-qualified name
MM_STATEMENT,			! Process a MOVE MATCHING statement
MOM_STATEMENT,			! Process a MOVE OTHERS MATCHING
MOVE_STATEMENT,			! Process a MOVE statement
SAVE_COMPLEX_VALUE: NOVALUE,	! Stores part of complex number
SAVE_DEST: NOVALUE,		! Saves destination field name
SAVE_FIELDNAME: NOVALUE,	! Saves current field name
SAVE_LOWER_BOUND: NOVALUE,	! Saves lower bound for range
SAVE_SOURCE: NOVALUE,		! Saves source field name
SAVE_VALUES_LIST,		! Saves value list
SET_ATT,			! Sets some attributes
SET_CHARACTER_TYPE: NOVALUE,	! Sets the character type
SET_SYNCHRONIZED: NOVALUE,	! Handle SYNCHRONIZED clause
SETUP_VALUE_RANGE: NOVALUE;	! Saves a value
! OWN variables:

    OWN

!   DEST_NAME		is a descriptor pointing to the destination for a
!			transform.

	DEST_NAME: $STR_DESCRIPTOR (CLASS=DYNAMIC),

!   ERROR_CONDITION	is a (long)word flag that determines if an error
!			has been found.

	ERROR_CONDITION : %BLISS32 (LONG) INITIAL (FALSE),

!   FIELD_NAME		is a descriptor pointing to the last field name
!			that has been parsed.

	FIELD_NAME : $STR_DESCRIPTOR (CLASS=DYNAMIC),

!   NAME_BLOCK		is a descriptor pointing to the last name that has
!			been parsed. (i.e. given-name or path-name)

	NAME_BLOCK : $STR_DESCRIPTOR (CLASS=DYNAMIC),

!   RECORD_BLK		is a pointer to a record block containing information
!			about the current record.

	RECORD_BLK :	REF CRX_RECORD INITIAL (NULL_PTR),

!   SIGN_LOC		is a (long)word containing the location of the sign for
!			the most current numeric string parsed.  It is
!			used by DEFINE_DTYPE to determine the datatype.

	SIGN_LOC %BLISS32 (: LONG),

!   SIGN_STATUS		is a (long)word used to determine if the last datatype
!			parsed was signed, unsigned, or zoned.  It is
!			used by DEFINE_DTYPE to determine the datatype.

	SIGN_STATUS %BLISS32 (: LONG),

!   SOURCE_NAME		is a descriptor pointing to the source for a transform

	SOURCE_NAME : $STR_DESCRIPTOR (CLASS=DYNAMIC),

!   STACK_TOP		is the address of the lowest level incomplete field.
!			The first field is pointed to by RECORD_BLK and so can
!			always be located.

	STACK_TOP :	REF CRX_MEMBER INITIAL (NULL_PTR),
!   The following variables are used to store a field's or transform's
! attributes until the field or transform block is created:

ALIGNMENT:	INITIAL (0),	        ! ALIGNED datatype
COMPUTE_TYPE,			        ! TRUE if computational
COPY_NAME:	$STR_DESCRIPTOR 
		 (CLASS=DYNAMIC),	! COPY name
DATATYPE:	INITIAL (0),	        ! Datatype
DIGITS:		INITIAL (0),	        ! DIGITS value
FIELD_BASE:	INITIAL (0),	        ! BASE value
FIELD_LEN:	INITIAL (0),	        ! Bits in field
FIRST_DIMENSION:REF crx_dimension
		 INITIAL (NULL_PTR),	! Head of dimension list
FIRST_VALUE_LIST:REF crx_stringlist
		 INITIAL (NULL_PTR),	! Head of value list
INITIAL_LENGTH:	INITIAL (0),		! Characters in initial value
INITIAL_LENGTH_1: INITIAL (0),		! Length of real part
					! of complex initial value
INITIAL_TYPE:	INITIAL (0),		! Token type of initial value
INITIAL_TYPE_1:	INITIAL (0),		! Token type of real part
					! of complex initial value
INITIAL_TYPE_2:	INITIAL (0),		! Token type of imaginary part
					! of complex initial value
INITIAL_VALUE:	INITIAL (NULL_PTR),	! Pointer to initial value
LAST_DIMENSION:	REF crx_dimension
		 INITIAL (NULL_PTR),	! Most recent dimension
LAST_VALUE_LIST:REF crx_stringlist
		 INITIAL (NULL_PTR),	! Tail of value list
LOWER_TYPE	,		        ! Type of SAVED_LOWERn
LOWER_TYPE1:	INITIAL (0),		! Token type of SAVED_LOWER1
LOWER_TYPE2:	INITIAL (0),		! Token type of SAVED_LOWER2
MAX_DIGITS:	INITIAL (0),		! Maximum digits
OCCURS_MIN	,		        ! Number of occurrences
! Temporary attribute storage, continued:

QUAL_NAME:	REF crx_stringlist
		 INITIAL (NULL_PTR),	! Fully-qualified name
RECORD_NAME:	$STR_DESCRIPTOR
		 (CLASS=DYNAMIC),	! Record name
SAVED_LOWER1:	$STR_DESCRIPTOR
		 (CLASS=DYNAMIC),	! Saved lower bound
SAVED_LOWER2:	$STR_DESCRIPTOR
		 (CLASS=DYNAMIC),	! ...
SAVED_TYPE	,		        ! Type of SAVED_VALUEn
SAVED_TYPE1:	INITIAL (0),		! Token type of SAVED_VALUE1
SAVED_TYPE2:	INITIAL (0),		! Token type of SAVED_VALUE2
SAVED_VALUE1:	$STR_DESCRIPTOR
		 (CLASS=DYNAMIC),	! Real part of value
SAVED_VALUE2:	$STR_DESCRIPTOR
		 (CLASS=DYNAMIC),	! Imaginary part of value
SCALE:		INITIAL (0),        	! SCALE value
STRING_TYPE,			        ! TRUE if string data
STRING_UNITS,				! Characters in string
TAG_VALUES_LIST:REF crx_stringlist
		 INITIAL (NULL_PTR),	! Tag values list
TRANSFORM_HEAD:	REF transform_str
		 INITIAL (NULL_PTR),	! Head of transform list
TRANSFORM_TAIL:	REF transform_str
		 INITIAL (NULL_PTR),	! Tail of transform list
UPPER_BOUND:	REF crx_stringlist
		 INITIAL (NULL_PTR),	! Upper bound
VALUE_LIST:	REF crx_stringlist
		 INITIAL (NULL_PTR),	! Current value list
!  Attribute existence flags:

ALIGNMENT_FL,		! TRUE if an alignment has been seen
BASE_FL,		! TRUE if a BASE has been seen
COLUMN_MAJOR_FL,	! TRUE if array is column-major
COPY_FL,		! TRUE if a COPY has been seen
DATATYPE_FL,		! TRUE if a DATATYPE has been seen
DIGITS_FL,		! TRUE if DIGITS has been seen
DIMENSION_FL,		! TRUE if a dimension has been seen
INITIAL_FL,		! TRUE if an initial value has been seen
JUSTIFIED_RIGHT_FL,	! TRUE if JUSTIFIED_RIGHT has been seen
LENGTH_FL,		! TRUE if a length has been seen
MAX_DIGITS_FL,		! TRUE if maximum digits have been determined
ONE_DIMENSION_FL,	! TRUE if array has only one dimension
SCALE_FL,		! TRUE if a SCALE has been seen
STRING_TYPE_FL,		! TRUE if a string type has been seen
SYNC_LEFT_FL,		! TRUE if SYNCHRONIZED LEFT
SYNC_RIGHT_FL,		! TRUE if SYNCHRONIZED RIGHT
TAG_VALUES_FL;		! TRUE if tag values have been seen
! External symbols:

EXTERNAL

srcrt,			! Root of source description tree for transform
dstrt;			! Root of destination description tree for transform


! External routines for transform processing:

EXTERNAL ROUTINE
CHECK_DIMS,			! Check for compatible dimensions
DIU$DEL_DIMS: NOVALUE,		! Delete a dims list
DIU$DEL_TRANS_LIST: NOVALUE,	! Delete a transform list
DIU$MOVE_MAT: NOVALUE;		! MOVE OTHERS or MOVE OTHERS MATCHING transform
!++
!  ACTION_RTN
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine acts as a driver in deciding which action routines are
!	to be called.  It is called only via macro LS_REDUCE_ACTION in
!	PATLANGSP.REQ.
!
!  CALLING SEQUENCE:
!
!	ACTION_RTN (code, left, right, sloc, right_token_ptr, result);
!
!  INPUT PARAMETERS:
!
!	code 		- A code indicating which action is to be performed
!			  (the action specified in the input to LALRPAT).
!
!	left		- The index into the semantic stack corresponding
!			  to the left hand end of the "handle", that is,
!			  the string of terminals and non-terminals
!			  corresponding to the  right hand side of a production.
!
!			  Note that this stack index can be used to index a
!			  parallel semantics stack maintained by the semantics
!			  action routine.
!
!	right		- Similar to LEFT, but corresponding to the right hand
!			  end of the handle.
!
!	sloc		- Source locator (line and column).
!
!	right_token_ptr	- If the last symbol in the reduction is a terminal,
!			  this is a pointer to the token containing that
!			  symbol.  If it is a non-terminal then this value is
!			  undefined.
!
!	result		- Address where action routines should put root of tree
!			  (also in RECORD_BLK or TRANSFORM_HEAD).
!
!  IMPLICIT INPUTS:
!
!	All globals in this module, plus PAT$TOKEN_CURRENT_PTR
!
!  IMPLICIT OUTPUTS:
!
!	All globals in this module
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!
!	FALSE		indicated that there was some semantic error involved
!			during the execution of an action routine.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
GLOBAL ROUTINE ACTION_RTN (CODE, LEFT, RIGHT, SLOC, RIGHT_TOKEN_PTR, RESULT) =
BEGIN

    MAP
	CODE %BLISS32 (: LONG),
	LEFT %BLISS32 (: LONG),
	RIGHT %BLISS32 (: LONG),
	SLOC %BLISS32 (: LONG),
	RIGHT_TOKEN_PTR %BLISS32 (: LONG);

    LOCAL
	LOCATOR		: %BLISS32 (LONG)	VOLATILE,
	STATUS		%BLISS32 (: LONG);
    LOCATOR = .SLOC;
    STATUS = TRUE;
    IF .ERROR_CONDITION AND .CODE NEQU CREATE_THE_RECORD
	AND .CODE NEQU TRANSFORM
	THEN RETURN SS$_NORMAL;

    DEB_EVENT ('Semantics actions',
	PUT_MSG ('ACTION_RTN called with code = '),
%if PATBLSEXT_DEBUGGING %then
	PUT_STRING (PAT$DATA_SEMACT_TEXT (.CODE)),
%fi
	PUT_EOL ());

    STATUS = SS$_NORMAL;

! To determine where the semantic actions occur in the grammar, consult the
! grammar file, DDL.PAT.

    SELECTONE .CODE OF
	SET
	    [LOWER_BND, UPPER_BND]: 	SETUP_VALUE_RANGE (.CODE);

	    [SAVE_COMPLEX1, SAVE_COMPLEX2]: 
					SAVE_COMPLEX_VALUE (.CODE);

	    [TAG_VALUES]: 		STATUS = SAVE_VALUES_LIST (.CODE);

	    [STORE_NAME]: 		EXTRACT_NAME (.SLOC);

	    [DEFINE_END_NO_NAME, DEFINE_END_NAME,
	     END_NO_NAME, END_NAME]:	STATUS = END_SET (.CODE);

	    [DIGITS_ATT, ALIGNED_ATT]:	STATUS = DEFINE_NUM_ATT (.CODE);

	    [JUSTIFIED_R]:		STATUS = SET_ATT (.CODE);

	    [SAVE_FIELD_NAME]:		SAVE_FIELDNAME ();

	    [SAVE_VAL_TYPE]:		SAVE_LOWER_BOUND ();

	    [SET_LS]:			SIGN_LOC = DDU$K_LEFT_SEPARATE;

	    [SET_LO]:			SIGN_LOC = DDU$K_LEFT_OVERPNCH;

	    [SET_RS]:			SIGN_LOC = DDU$K_RIGHT_SEPARATE;

	    [SET_RO]:			SIGN_LOC = DDU$K_RIGHT_OVERPNCH;

	    [SET_UNSIGNED]:		SIGN_STATUS = DDU$K_UNSIGNED;

	    [SET_SIGNED]:		SIGN_STATUS = DDU$K_SIGNED;

	    [SET_ZONED]:
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM (.SLOC,
			'ZONED not implemented -- ignored');
		    SIGN_STATUS = DDU$K_ZONED;
		END;

	    [DEFINE_THE_RECORD]:	DEFINE_RECORD (.result);

	    [FULLY_QUAL]:		STATUS = FULLY_QUALIFIED_NAME ();

	    [NO_FIELD]:
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM (.SLOC, 'Empty record');
		    STATUS = FALSE;
		END;

	    [NO_SUB_FIELD]:
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM (.SLOC, 'Empty structure');
		    STATUS = FALSE;
		END;

	    [GROUP_SPECIFIED]:
		LSLOCAL_SYNTAX_ERRORM (.SLOC,
		    'GROUP should be replaced by STRUCTURE');

	    [TYPE_SPECIFIED]:
		LSLOCAL_SYNTAX_ERRORM (.SLOC,
		    'TYPE should be replaced by DATATYPE');

	    [ASSIGN_UPPER]:
		BEGIN
		    LAST_DIMENSION [crd$v_upper_bound_fl] = TRUE;
		    LAST_DIMENSION [crd$l_upper_bound] = .OCCURS_MIN;
		    IF .OCCURS_MIN LEQ 0
			THEN BEGIN
			    STATUS = FALSE;
			    LSLOCAL_SYNTAX_ERRORM
				(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
				'OCCURS must be greater than 0');
			END;
		END;

	    [ASSIGN_MIN]:
		BEGIN
		    LAST_DIMENSION [crd$v_min_occurs_fl] = TRUE;
		    LAST_DIMENSION [crd$l_min_occurs] = .OCCURS_MIN;
		    IF .LAST_DIMENSION [crd$l_upper_bound] LSS .OCCURS_MIN
			THEN BEGIN
			    STATUS = FALSE;
			    LSLOCAL_SYNTAX_ERRORM
				(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
				'Maximum OCCURS must be greater than or equal to minimum');
			END;
		END;

	    [ARRAY_LOWER, OCCURS_N]:
		STATUS = DEFINE_DIMENSION (.CODE, .SLOC);

	    [ROW_ARRAY]:
		COLUMN_MAJOR_FL = FALSE;

	    [COLUMN_ARRAY]:
		COLUMN_MAJOR_FL = TRUE;

	    [ARRAY_UPPER, OCCURS_UPPER]:
		BEGIN
		    LAST_DIMENSION [crd$v_upper_bound_fl] = TRUE;
		    LAST_DIMENSION [crd$l_upper_bound] =
			LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
		END;

	    [SET_DIMENSION]:
		DIMENSION_FL = TRUE;

	    [ARRAY_NO_LOWER]:	! Only one bound, so it is upper and lower is 1.
		BEGIN
		    LAST_DIMENSION [crd$l_upper_bound] =
			.LAST_DIMENSION [crd$l_lower_bound];
		    LAST_DIMENSION [crd$v_upper_bound_fl] = TRUE;
		    LAST_DIMENSION [crd$l_lower_bound] = 1;
		END;

	    [DEPEND_ITEM]: 
		BEGIN
		    LAST_DIMENSION [crd$a_depend_item] = .QUAL_NAME;
		    QUAL_NAME [crs$a_previous] = .LAST_DIMENSION;
		    LAST_DIMENSION [crd$b_depend_item_cnt] = 1;
		    WHILE ((QUAL_NAME = .QUAL_NAME [crs$a_next]) NEQA NULL_PTR)
			DO LAST_DIMENSION [crd$b_depend_item_cnt] =
			    .LAST_DIMENSION [crd$b_depend_item_cnt] + 1;
		END;		! Leave QUAL_NAME as a null pointer

	    [FIRST_VAL_LIST]:
		BEGIN
		    FIRST_VALUE_LIST = .VALUE_LIST;
		    LAST_VALUE_LIST = .VALUE_LIST;
		    VALUE_LIST = NULL_PTR;
		END;

	    [NEXT_VALUE_LIST]:
		BEGIN
		    LAST_VALUE_LIST [crs$a_next] = .VALUE_LIST;
		    LAST_VALUE_LIST = .VALUE_LIST;
		    VALUE_LIST = NULL_PTR;
		END;

	    [CREATE_THE_RECORD]:
		IF .ERROR_CONDITION
		    THEN BEGIN
			ERROR_CONDITION = FALSE;
			LSLOCAL_SYNTAX_ERRORM
			    (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
			    'Record description not created');
		    END
		    ELSE BEGIN
			FIX_VARIANTS (.RECORD_BLK [crx$a_root]);
			DEB_EVENT ('Semantics actions',
			    TREE (.RECORD_BLK));	! Display what we made
			RECORD_BLK = NULL_PTR;
		    END;

	    [SCALE_ATT]:
		STATUS = DEFINE_SCALE
		    (LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR));

	    [FRACTIONS_ATT]:
		BEGIN

!   Make sure the number of fractions is less or equal to the number of digits.

		    IF .DIGITS LSSU LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR)
			THEN BEGIN
			    LSLOCAL_SYNTAX_ERRORM
				(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
				'Number of FRACTIONS must be less than DIGITS');
			    STATUS = FALSE;
			END
		    ELSE
			STATUS = DEFINE_SCALE
			    (-LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR));
		END;

	    [DEFINE_ELEMENTARY, DEFINE_COPY,
	     DEFINE_STRUCTURE, DEFINE_VARIANT, DEFINE_VARIANTS]:
		STATUS = DEFINE_FIELD (.CODE, .SLOC);

	    [COPY_PATHNAME, INIT_VALUE]:
		STATUS = CREATE_STR_ATT (.CODE);

	    [BYTE_LENGTH, VARYING_LENGTH]:
		BEGIN
		    LENGTH_FL = TRUE;
		    IF (LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) LEQ 0) OR
			(LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) GEQ 65536)
			THEN BEGIN
			    LSLOCAL_SYNTAX_ERRORM
				(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
				'Field length must be between 0 and 65536');
			    STATUS = FALSE;
			END;
		    FIELD_LEN = (IF .CODE EQLU BYTE_LENGTH
			THEN (DIU$K_S_ASCII *
			    LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR))
			ELSE (DIU$K_S_ASCII *
			    (LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) + 2)));
		    STRING_UNITS = LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
		END;

	    [BASE_ATT]:
		BEGIN
		    BASE_FL = TRUE;
		    FIELD_BASE = LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
		END;

	    [GROUP_ATTS]:
		BEGIN
		    LOCAL
			TEMP_OFFSET %BLISS32 (: LONG),
			TOTAL_OFFSET %BLISS32 (: LONG),
			LENGTH %BLISS32 (: LONG);

		    TOTAL_OFFSET = 0;
		    TEMP_OFFSET = 0;
		    STATUS = DEFINE_GROUP_ATTS (.RECORD_BLK [CRX$A_ROOT],
			TEMP_OFFSET, TOTAL_OFFSET, LENGTH);
		END;

	    [BIT_DTYPE, BYTE_DTYPE, DATE_DTYPE, D_FLOAT_DTYPE, D_COMPLEX_DTYPE,
	     F_FLOAT_DTYPE, F_COMPLEX_DTYPE, G_FLOAT_DTYPE, G_COMPLEX_DTYPE,
	     H_FLOAT_DTYPE, H_COMPLEX_DTYPE, LONGWORD_DTYPE, NUMERIC_DTYPE,
	     OCTAWORD_DTYPE, PACKED_NUM_DTYPE, POINTER_DTYPE, QUADWORD_DTYPE,
	     TEXT_DTYPE, UNSPECIFIED_DTYPE, VARYING_STR_DTYPE, VIRTUAL_DTYPE,
	     WORD_DTYPE]:
		STATUS = DEFINE_DTYPE (.CODE);

	    [TRANSFORM]:
		BEGIN
		DEFINE_TRANSFORM (.result);
		IF .ERROR_CONDITION
		    THEN BEGIN
		    ERROR_CONDITION = FALSE;
		    LSLOCAL_SYNTAX_ERRORM
			(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
			'Transform not created');
		    END;
		END;

	    [TYPE_ASCII_7, TYPE_ASCII_8,
		TYPE_EBCDIC_8, TYPE_EBCDIC_9, TYPE_SIXBIT]:
		SET_CHARACTER_TYPE (.CODE);

	    [TYPE_ASCII_9]:
		LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		    'ASCII_9 not implemented - ignored');

	    [SYNC_LEFT, SYNC_RIGHT]:
		SET_SYNCHRONIZED (.CODE);

	    [MOVE_ST]:		STATUS = MOVE_STATEMENT ();

	    [MM_ST]:		STATUS = MM_STATEMENT ();

	    [MOM_ST]:		STATUS = MOM_STATEMENT ();

	    [ROUNDED]:	 	! Should set conversion-flag to ROUNDED
		LSLOCAL_SYNTAX_ERRORM (.SLOC,
		    'ROUNDED not implemented -- ignored');

	    [TRUNC]: 		! Should set conversion-flag to TRUNCATED
		LSLOCAL_SYNTAX_ERRORM (.SLOC,
		    'TRUNCATED not implemented -- ignored');

	    [SOURCE]:		SAVE_SOURCE ();

	    [DEST]:		SAVE_DEST ();

	    [OTHERWISE]:	SS$_NORMAL;

	TES;
    IF (.CODE EQLU ARRAY_NO_LOWER OR .CODE EQLU ARRAY_UPPER) AND
	.LAST_DIMENSION [crd$l_lower_bound]
	    GTR .LAST_DIMENSION [crd$l_upper_bound]
	THEN BEGIN
	    STATUS = FALSE;
	    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		'Improper array bounds');
	END;

    IF NOT .STATUS OR .CODE EQLU ERROR_MARK

!	Unrecoverable error - clean out everything.

	THEN BEGIN
	    IF .RECORD_BLK NEQA NULL_PTR
		THEN FREE_RECORD (.RECORD_BLK);
	    IF .TRANSFORM_HEAD NEQA NULL_PTR
		THEN DIU$DEL_TRANS_LIST (.TRANSFORM_HEAD);
	    TRANSFORM_HEAD = NULL_PTR;
	    TRANSFORM_TAIL = NULL_PTR;
	    IF .DEST_NAME [STR$H_LENGTH] NEQU 0
		THEN $XPO_FREE_MEM (STRING = DEST_NAME);
	    IF .SOURCE_NAME [STR$H_LENGTH] NEQU 0
		THEN $XPO_FREE_MEM (STRING = SOURCE_NAME);
	    .RESULT = NULL_PTR;
	    IF .FIELD_NAME [STR$H_LENGTH] NEQU 0
		THEN $XPO_FREE_MEM (STRING = FIELD_NAME);
	    FIELD_NAME [STR$H_LENGTH] = 0;
	    CLEAR_ATTRIBUTE_FLAGS ();
	    STRING_UNITS = 0;
	    COPY_NAME [STR$H_LENGTH] = 0;
	    IF .VALUE_LIST NEQA NULL_PTR
		THEN FREE_STRINGLIST (.VALUE_LIST);
	    VALUE_LIST = NULL_PTR;
	    IF .FIRST_VALUE_LIST NEQA NULL_PTR
		THEN FREE_STRINGLIST (.FIRST_VALUE_LIST);
	    FIRST_VALUE_LIST = NULL_PTR;
	    IF .FIRST_DIMENSION NEQA NULL_PTR
		THEN FREE_DIMENSIONS (.FIRST_DIMENSION);
	    FIRST_DIMENSION = NULL_PTR;
	    LAST_DIMENSION = NULL_PTR;
	    STACK_TOP = NULL_PTR;
	    IF .RECORD_NAME [STR$H_LENGTH] NEQU 0
		THEN $XPO_FREE_MEM (STRING = RECORD_NAME);
	    RECORD_NAME [STR$H_LENGTH] = 0;
	    IF .QUAL_NAME NEQA NULL_PTR
		THEN FREE_STRINGLIST (.QUAL_NAME);
	    QUAL_NAME = NULL_PTR;

	    IF .CODE NEQU CREATE_THE_RECORD
		AND .CODE NEQU TRANSFORM
		THEN ERROR_CONDITION = TRUE;
	END;

    RETURN .STATUS
END;
!++
!  CREATE_STR_ATT (CRESTR)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine stores an initial value or a copy pathname.
!	It is called for COPY_PATHNAME and INIT_VALUE.
!
!  CALLING SEQUENCE:
!
!	CREATE_STR_ATT (code.rlu.v);
!
!  INPUT PARAMETERS:
!
!	code		is a (long)word value that determines which attribute is
!			to be initialized.
!
!  IMPLICIT INPUTS:
!
!	COPY_FL			Copy-seen flag
!	INITIAL_FL		Initial-value-seen flag
!	NAME_BLOCK		Name for COPY
!	PAT$TOKEN_CURRENT_PTR	Current token
!
!  IMPLICIT OUTPUTS:
!
!	COPY_FL			Copy-seen flag, set if appropriate
!	COPY_NAME		Pointer to COPY stringlist
!	INITIAL_FL		Initial-value-seen flag, set if appropriate
!	INITIAL_LENGTH		Length of initial value
!	INITIAL_LENGTH_1	Length of real part of complex initial value
!	INITIAL_TYPE		Datatype of initial value
!	INITIAL_TYPE_1		Token type of real part of complex initial value
!	INITIAL_TYPE_2		Token type of imaginary part
!	INITIAL_VALUE		Pointer to initial value
!	NAME_BLOCK		Name for COPY, cleared if appropriate
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!	FALSE		indicates that the attribute was multiply-defined.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE CREATE_STR_ATT (CODE) =
BEGIN
%BLISS32 (    MAP
	CODE :	LONG;)

BIND
    TERM  = (LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR)),
    TOKEN = (LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR)) : $STR_DESCRIPTOR ();

!   Handle COPY pathname:

    IF .CODE EQLU COPY_PATHNAME
	THEN IF .COPY_FL
	    THEN BEGIN		! Duplicate copy pathnames
		LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		    'Multiple COPY templates - ignored');
		RETURN FALSE;
	    END ELSE BEGIN	! New copy pathname
		COPY_FL = TRUE;
		COPY_NAME [STR$H_LENGTH] = .NAME_BLOCK [STR$H_LENGTH];
		COPY_NAME [STR$A_POINTER] = .NAME_BLOCK [STR$A_POINTER];
		NAME_BLOCK [STR$H_LENGTH] = 0;
		RETURN SS$_NORMAL;
	    END;

!   Handle INIT_VALUE:

    IF .INITIAL_FL
	THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		'Multiple initial values - ignored');
	    RETURN FALSE;
	END ELSE BEGIN
	    INITIAL_FL = TRUE;
	    IF .SAVED_VALUE1 [STR$H_LENGTH] EQLU 0
		THEN		! Not complex initial value
		    BEGIN
		    INITIAL_TYPE = TERM;
		    INITIAL_LENGTH = .TOKEN [STR$H_LENGTH];
		    $XPO_GET_MEM (CHARACTERS = .INITIAL_LENGTH,
			RESULT = INITIAL_VALUE);
		    CH$MOVE (.INITIAL_LENGTH, .TOKEN [STR$A_POINTER],
			.INITIAL_VALUE);
		    END
		ELSE
		    BEGIN		! Complex initial value
		    INITIAL_TYPE = NT_COMPLEX_NUMBER;
		    INITIAL_LENGTH_1 = .SAVED_VALUE1 [STR$H_LENGTH];
		    INITIAL_LENGTH = .SAVED_VALUE1 [STR$H_LENGTH] +
			.SAVED_VALUE2 [STR$H_LENGTH] + 1;
		    INITIAL_TYPE_1 = .SAVED_TYPE1;
		    INITIAL_TYPE_2 = .SAVED_TYPE2;
		    $XPO_GET_MEM (CHARACTERS = .INITIAL_LENGTH,
			RESULT = INITIAL_VALUE);
		    CH$MOVE (.SAVED_VALUE1 [STR$H_LENGTH],
			.SAVED_VALUE1 [STR$A_POINTER], .INITIAL_VALUE);
		    CH$WCHAR (%C' ', CH$PLUS (.INITIAL_VALUE,
			.SAVED_VALUE1 [STR$H_LENGTH]));
		    CH$MOVE (.SAVED_VALUE2 [STR$H_LENGTH],
			.SAVED_VALUE2 [STR$A_POINTER],
			CH$PLUS (.INITIAL_VALUE,
			.SAVED_VALUE1 [STR$H_LENGTH] + 1));
		    SAVED_VALUE1 [STR$H_LENGTH] = 0;
		    SAVED_VALUE2 [STR$H_LENGTH] = 0;
		    END;
	RETURN SS$_NORMAL
	END;

END;
!++
!  DEFINE_DIMENSION (DEFDIM)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine creates a dimension block and defines the associated
!	numeric values (i.e. stride, lower bound, upper bound and min_occurs).
!	It is called for ARRAY_LOWER and OCCURS_N.
!
!  CALLING SEQUENCE:
!
!	DEFINE_DIMENSION (code.rlu.v, locator.rlu.v);
!
!  INPUT PARAMETERS:
!
!	code		is a (long)word value sent from the parser.  It is used
!			to determine numeric values to be defined.
!
!	locator		is the (long)word value of the source locator.
!
!  IMPLICIT INPUTS:
!
!	FIRST_DIMENSION	Head of list of dimension blocks
!	LAST_DIMENSION	Pointer to most recent dimension block
!	PAT$TOKEN_CURRENT_PTR Current token
!
!  IMPLICIT OUTPUTS:
!
!	FIRST_DIMENSION	Head of list of dimension blocks, updated
!	LAST_DIMENSION	Updated to point to new dimension block
!	OCCURS_MIN	Number of occurrences of one-dimensional array
!	ONE_DIMENSION_FL Set if array has only one dimension
!	DIMENSION_FL	Dimension-seen flag, set
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!	FALSE		Indicates that an arrary was multiply-dimensionned.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE DEFINE_DIMENSION (CODE, LOCATOR) =
BEGIN
%BLISS32 (    MAP
	CODE :		LONG,
	LOCATOR :	LONG;)

    LOCAL
	DCB_PTR :	REF	crx_dimension;

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

    DIMENSION_FL = TRUE;

    $XPO_GET_MEM (FULLWORDS = diu$s_crx_dimension, RESULT = DCB_PTR, FILL = 0);
    DCB_PTR [crd$b_id] = CRX$K_DIMENSION;

    IF .FIRST_DIMENSION EQLU NULL_PTR
	THEN FIRST_DIMENSION = .DCB_PTR;

!   Hook this dimension on to the end of the list of dimensions:

    IF .LAST_DIMENSION NEQA NULL_PTR
	THEN LAST_DIMENSION [crd$a_next] = .DCB_PTR;
    DCB_PTR [crd$a_previous] = .LAST_DIMENSION;
    LAST_DIMENSION = .DCB_PTR;

    IF .CODE EQLU OCCURS_N
	THEN BEGIN
	    ONE_DIMENSION_FL = TRUE;
	    OCCURS_MIN = LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
	END;

    DCB_PTR [crd$l_lower_bound] = (IF .CODE EQLU ARRAY_LOWER
	THEN LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) ELSE 1);
    DCB_PTR [crd$v_lower_bound_fl] = TRUE;

    RETURN SS$_NORMAL
END;
!++
!  DEFINE_DTYPE (DEFTYP)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine defines the datatype and length (except for packed and
!	numeric datatypes) for the field whose attributes are currently being
!	parsed.
!	It is called for BIT_DTYPE, BYTE_DTYPE, DATE_DTYPE, D_FLOAT_DTYPE,
!	D_COMPLEX_DTYPE, F_FLOAT_DTYPE, F_COMPLEX_DTYPE, G_FLOAT_DTYPE,
!	G_COMPLEX_DTYPE, H_FLOAT_DTYPE, H_COMPLEX_DTYPE, LONGWORD_DTYPE,
!	NUMERIC_DTYPE, OCTAWORD_DTYPE, PACKED_NUM_DTYPE, POINTER_DTYPE,
!	QUADWORD_DTYPE, TEXT_DTYPE, UNSPECIFIED_DTYPE, VARYING_STR_DTYPE,
!	VIRTUAL_DTYPE, and WORD_DTYPE.
!
!  CALLING SEQUENCE:
!
!	DEFINE_DTYPE (code.rlu.v);
!
!  INPUT PARAMETERS:
!
!	code		is a (long)word value sent from the parser.  It is used
!			to define the datatype of the field to be described.
!
!  IMPLICIT INPUTS:
!
!	DATATYPE_FL	Datatype-seen flag
!	PAT$TOKEN_CURRENT_PTR Current token
!	SIGN_LOC	Sign location
!	SIGN_STATUS	Sign status
!
!  IMPLICIT OUTPUTS:
!
!	BASE_FL		Base-seen flag, set if appropriate
!	COMPUTE_TYPE	Computational datatype flag, set if appropriate
!	DATATYPE	Datatype
!	DATATYPE_FL	Datatype-seen flag, set
!	DIGITS		DIGITS value, set if appropriate
!	DIGITS_FL	DIGITS-seen flag, set if appropriate
!	FIELD_BASE	BASE value, set if appropriate
!	FIELD_LEN	Field length
!	LENGTH_FL	Length-seen flag, set if appropriate
!	MAX_DIGITS	Maximum digits, set if appropriate
!	MAX_DIGITS_FL	Maximum-digits-computed flag, set if appropriate
!	SIGN_LOC	Sign location, set to unspecified
!	SIGN_STATUS	Sign status, set to unspecified
!	STRING_TYPE	String datatype flag, set if appropriate
!	STRING_UNITS	String units, set if appropriate
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!	FALSE		Indicates that the field had multiple datatypes or that
!			a bit string was not between 0 and 65536 bits long.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE DEFINE_DTYPE (CODE) =
BEGIN
%BLISS32 (    MAP
	CODE :		LONG;)

LOCAL
    s_ascii,		s_byte,		s_date,		s_d_float,
    s_d_complex,	s_f_float,	s_f_complex,	s_g_float,
    s_g_complex,	s_h_float,	s_h_complex,	s_longword,
    s_octaword,		s_packed,	s_pointer,	s_quadword,
    s_word,
    d_byte_s,		d_byte_u,	d_d_float,	d_d_complex,
    d_f_float,		d_f_complex,	d_g_float,	d_g_complex,
    d_h_float,		d_h_complex,	d_longword_s,	d_longword_u,
    d_octaword_s,	d_octaword_u,	d_quadword_s,	d_quadword_u,
    d_word_s,		d_word_u;

LOCAL error_desc : $STR_DESCRIPTOR(CLASS = DYNAMIC);    ! for error messages

    $STR_DESC_INIT (DESC = error_desc, CLASS = DYNAMIC);


!   Precompute sizes and digits 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_ascii = diu$k_S_ASCII;
    s_byte = DIU$K_S_BYTE;
    s_date = DIU$K_S_DATE;
    s_d_float = DIU$K_S_D_FLOAT;
    s_d_complex = DIU$K_S_D_COMPLEX;
    s_f_float = DIU$K_S_F_FLOAT;
    s_f_complex = DIU$K_S_F_COMPLEX;
    s_g_float = DIU$K_S_G_FLOAT;
    s_g_complex = DIU$K_S_G_COMPLEX;
    s_h_float = DIU$K_S_H_FLOAT;
    s_h_complex = DIU$K_S_H_COMPLEX;
    s_longword = DIU$K_S_LONGWORD;
    s_octaword = DIU$K_S_OCTAWORD;
    s_packed = DIU$K_S_PACKED;
    s_pointer = DIU$K_S_POINTER;
    s_quadword = DIU$K_S_QUADWORD;
    s_word = DIU$K_S_WORD;
    d_byte_s = DIU$K_D_BYTE_S;
    d_byte_u = DIU$K_D_BYTE_U;
    d_d_float = DIU$K_D_D_FLOAT;
    d_d_complex = DIU$K_D_D_COMPLEX;
    d_f_float = DIU$K_D_F_FLOAT;
    d_f_complex = DIU$K_D_F_COMPLEX;
    d_g_float = DIU$K_D_G_FLOAT;
    d_g_complex = DIU$K_D_G_COMPLEX;
    d_h_float = DIU$K_D_H_FLOAT;
    d_h_complex = DIU$K_D_H_COMPLEX;
    d_longword_s = DIU$K_D_LONGWORD_S;
    d_longword_u = DIU$K_D_LONGWORD_U;
    d_octaword_s = DIU$K_D_OCTAWORD_S;
    d_octaword_u = DIU$K_D_OCTAWORD_U;
    d_quadword_s = DIU$K_D_QUADWORD_S;
    d_quadword_u = DIU$K_D_QUADWORD_U;
    d_word_s = DIU$K_D_WORD_S;
    d_word_u = DIU$K_D_WORD_U;
    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_RTN called DEFINE_DTYPE'));

    IF .DATATYPE_FL
	THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		'Multiple data type');
	    RETURN FALSE;
	END;

    DATATYPE_FL = TRUE;

!   The datatype defines the length, except for text, unspecified,
!   and varying-string fields.

    IF .CODE NEQU TEXT_DTYPE AND .CODE NEQU UNSPECIFIED_DTYPE AND
	.CODE NEQU VARYING_STR_DTYPE
	THEN LENGTH_FL = TRUE;

!   Set text flag for the crx_member node, if appropriate:

    IF .CODE EQLU TEXT_DTYPE OR .CODE EQLU VARYING_STR_DTYPE
	OR .CODE EQLU NUMERIC_DTYPE OR .CODE EQLU PACKED_NUM_DTYPE
	THEN STRING_TYPE = TRUE;

!   Set the computational flag for the crx_member node, if appropriate:

    IF (.CODE NEQU BIT_DTYPE) AND (.CODE NEQU DATE_DTYPE) AND
	(.CODE NEQU POINTER_DTYPE) AND (.CODE NEQU UNSPECIFIED_DTYPE) AND
	(.CODE NEQU VIRTUAL_DTYPE) AND (.CODE NEQU TEXT_DTYPE)
	THEN COMPUTE_TYPE = TRUE;

!   For binary fields, set base to 2 by default, and indicate that base,
!   digits, and max_digits will all be set.

    IF (.CODE NEQU BIT_DTYPE) AND
	(.CODE NEQU DATE_DTYPE) AND
	(.CODE NEQU NUMERIC_DTYPE) AND
	(.CODE NEQU PACKED_NUM_DTYPE) AND
	(.CODE NEQU POINTER_DTYPE) AND
	(.CODE NEQU TEXT_DTYPE) AND
	(.CODE NEQU UNSPECIFIED_DTYPE) AND
	(.CODE NEQU VARYING_STR_DTYPE) AND
	(.CODE NEQU VIRTUAL_DTYPE)
	THEN BEGIN
	    FIELD_BASE = 2;
	    BASE_FL = TRUE;
	    DIGITS_FL = TRUE;
	    MAX_DIGITS_FL = TRUE;
	END;
!   Handle each datatype:

    SELECTONE .CODE OF
	SET

	    [BIT_DTYPE]:
		BEGIN
!		    DATATYPE = DIU$K_DTYPE_VU;
		    LSLOCAL_SYNTAX_ERRORM
			(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
			'Bit fields not implemented');
                    $STR_COPY(TARGET = error_desc,
                              STRING = 'Bit fields not implemented -- ignored');
                    SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
		    IF (LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) LEQ 0) OR
			(LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) GEQ 65536)
			THEN BEGIN
			    LSLOCAL_SYNTAX_ERRORM
				(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
				'Bit field length must be between 0 and 65536');
			    RETURN FALSE;
			END;
		    FIELD_LEN = LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
		END;

	    [BYTE_DTYPE]:
		BEGIN
		    IF .SIGN_STATUS EQLU DDU$K_SIGNED
			THEN BEGIN
			    DATATYPE = DIU$K_DTYPE_B;
			    DIGITS = .d_byte_s;
			    MAX_DIGITS = .d_byte_s;
			END
			ELSE BEGIN
			    DATATYPE = DIU$K_DTYPE_BU;
			    DIGITS = .d_byte_u;
			    MAX_DIGITS = .d_byte_u;
			END;
		    FIELD_LEN = .s_byte;
		END;

	    [DATE_DTYPE]:
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM
			(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
			'DATE datatype not implemented');
                    $STR_COPY(TARGET = error_desc,
                              STRING = 'DATE datatype not implemented -- ignored');
                    SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
!		    DATATYPE = DIU$K_DTYPE_ADT;
		    FIELD_LEN = .s_date;
		END;

	    [D_FLOAT_DTYPE]:
		BEGIN
		    DATATYPE = DIU$K_DTYPE_D;
		    FIELD_LEN = .s_d_float;
		    DIGITS = .d_d_float;
		    MAX_DIGITS = .d_d_float;
		END;

	    [D_COMPLEX_DTYPE]:
		BEGIN
		    DATATYPE = DIU$K_DTYPE_DC;
		    FIELD_LEN = .s_d_complex;
		    DIGITS = .d_d_complex;
		    MAX_DIGITS = .d_d_complex;
		END;

	    [F_FLOAT_DTYPE]:
		BEGIN
		    DATATYPE = DIU$K_DTYPE_F;
		    FIELD_LEN = .s_f_float;
		    DIGITS = .d_f_float;
		    MAX_DIGITS = .d_f_float;
		END;

	    [F_COMPLEX_DTYPE]:
		BEGIN
		    DATATYPE = DIU$K_DTYPE_FC;
		    FIELD_LEN = .s_f_complex;
		    DIGITS = .d_f_complex;
		    MAX_DIGITS = .d_f_complex;
		END;

	    [G_FLOAT_DTYPE]:
		BEGIN
		    DATATYPE = DIU$K_DTYPE_G;
		    FIELD_LEN = .s_g_float;
		    DIGITS = .d_g_float;
		    MAX_DIGITS = .d_g_float;
		END;

	    [G_COMPLEX_DTYPE]:
		BEGIN
		    DATATYPE = DIU$K_DTYPE_GC;
		    FIELD_LEN = .s_g_complex;
		    DIGITS = .d_g_complex;
		    MAX_DIGITS = .d_g_complex;
		END;

	    [H_FLOAT_DTYPE]:
		BEGIN
		    DATATYPE = DIU$K_DTYPE_H;
		    FIELD_LEN = .s_h_float;
		    DIGITS = .d_h_float;
		    MAX_DIGITS = .d_h_float;
		END;

	    [H_COMPLEX_DTYPE]:
		BEGIN
		    DATATYPE = DIU$K_DTYPE_HC;
		    FIELD_LEN = .s_h_complex;
		    DIGITS = .d_h_complex;
		    MAX_DIGITS = .d_h_complex;
		END;

	    [LONGWORD_DTYPE]:
		BEGIN
		    IF .SIGN_STATUS EQLU DDU$K_SIGNED
			THEN BEGIN
			    DATATYPE = DIU$K_DTYPE_L;
			    DIGITS = .d_longword_s;
			    MAX_DIGITS = .d_longword_s;
			END
			ELSE BEGIN
			    DATATYPE = DIU$K_DTYPE_LU;
			    DIGITS = .d_longword_u;
			    MAX_DIGITS = .d_longword_u;
			END;
		    FIELD_LEN = .s_longword;
		END;

	    [NUMERIC_DTYPE]:
		IF .SIGN_LOC EQLU DDU$K_UNSPECIFIED
		    THEN BEGIN
			DATATYPE =
			    (IF (.SIGN_STATUS EQLU DDU$K_SIGNED OR
				.SIGN_STATUS EQLU DDU$K_ZONED)
				THEN BEGIN
				    LSLOCAL_SYNTAX_ERRORM (
					LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
					'ZONED datatype not supported');
                                    $STR_COPY(TARGET = error_desc,
                                        STRING='ZONED datatype not supported -- ignored');
                                    SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
!				    DIU$K_DTYPE_NZ
				    0
				END
			    ELSE
				DIU$K_DTYPE_NU);
			FIELD_LEN = .DIGITS * .s_ascii;
			STRING_UNITS = .DIGITS;
		    END
		ELSE
		    BEGIN
			DATATYPE = (SELECTONE .SIGN_LOC OF
			    SET
			    [DDU$K_LEFT_SEPARATE]:     DIU$K_DTYPE_NL;
			    [DDU$K_LEFT_OVERPNCH]:     DIU$K_DTYPE_NLO;
			    [DDU$K_RIGHT_SEPARATE]:    DIU$K_DTYPE_NR;
			    [DDU$K_RIGHT_OVERPNCH]:    DIU$K_DTYPE_NRO;
			    TES);
			SELECTONE .SIGN_LOC OF
			    SET
			    [DDU$K_LEFT_SEPARATE,DDU$K_RIGHT_SEPARATE]:
				BEGIN
				    FIELD_LEN = (.DIGITS + 1) *
					DIU$K_S_ASCII;
				    STRING_UNITS = .DIGITS + 1;
				END;
			    [DDU$K_LEFT_OVERPNCH,DDU$K_RIGHT_OVERPNCH]:
				BEGIN
				    FIELD_LEN = .DIGITS * .s_ascii;
				    STRING_UNITS = .DIGITS;
				END;
			    TES;
		    END;

	    [OCTAWORD_DTYPE]:
		BEGIN
		    IF .SIGN_STATUS EQLU DDU$K_SIGNED
			THEN BEGIN
			    DATATYPE = DIU$K_DTYPE_O;
			    DIGITS = .d_octaword_s;
			    MAX_DIGITS = .d_octaword_s;
			END
			ELSE BEGIN
			    DATATYPE = DIU$K_DTYPE_OU;
			    DIGITS = .d_octaword_u;
			    MAX_DIGITS = .d_octaword_u;
			END;
		    FIELD_LEN = .s_octaword;
		END;

	    [PACKED_NUM_DTYPE]:
		BEGIN
		    DATATYPE = DIU$K_DTYPE_P;
		    FIELD_LEN = ((.DIGITS / 2) + 1) * .s_packed;
		    STRING_UNITS = (.DIGITS/2) + 1;
		END;

	    [POINTER_DTYPE]:
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM
			(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
			'POINTER datatype not supported');
                    $STR_COPY(TARGET = error_desc,
                              STRING = 'POINTER datatype not supported -- ignored');
                    SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
!		    DATATYPE = CDD$K_DTYPE_PTR;
		    FIELD_LEN = .s_pointer;
		END;

	    [QUADWORD_DTYPE]:
		BEGIN
		    IF .SIGN_STATUS EQLU DDU$K_SIGNED
			THEN BEGIN
			    DATATYPE = DIU$K_DTYPE_Q;
			    DIGITS = .d_quadword_s;
			    MAX_DIGITS = .d_quadword_s;
			END
			ELSE BEGIN
			    DATATYPE = DIU$K_DTYPE_QU;
			    DIGITS = .d_quadword_u;
			    MAX_DIGITS = .d_quadword_u;
			END;
		    FIELD_LEN = .s_quadword;
		END;

	    [TEXT_DTYPE]:
		DATATYPE = DIU$K_DTYPE_T;

	    [UNSPECIFIED_DTYPE]:
		BEGIN
!               DATATYPE = DIU$K_DTYPE_Z;
                LSLOCAL_SYNTAX_ERRORM
                        (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
			'Unspecified datatype not implemented');
                $STR_COPY(TARGET = error_desc,
                          STRING = 'Unspecified datatype not implemented -- ignored');
                SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
		END;

	    [VARYING_STR_DTYPE]:
		BEGIN
!		DATATYPE = DIU$K_DTYPE_VT;
		LSLOCAL_SYNTAX_ERRORM
		    (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		     'VARYING STRING datatype not implemented');
                $STR_COPY(TARGET = error_desc,
                          STRING = 'VARYING STRING datatype not implemented -- ignored');
                SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
		END;

	    [VIRTUAL_DTYPE]:
		BEGIN
!		    DATATYPE = CDD$K_DTYPE_VRT;
		    FIELD_LEN = 0;
		END;

	    [WORD_DTYPE]:
		BEGIN
		    IF .SIGN_STATUS EQLU DDU$K_SIGNED
			THEN BEGIN
			    DATATYPE = DIU$K_DTYPE_W;
			    DIGITS = .d_word_s;
			    MAX_DIGITS = .d_word_s;
			END
			ELSE BEGIN
			    DATATYPE = DIU$K_DTYPE_WU;
			    DIGITS = .d_word_u;
			    MAX_DIGITS = .d_word_u;
			END;
		    FIELD_LEN = .s_word;
		END;

	    [OTHERWISE]:
                SIGNAL(DIU$_INVDATTYP, 1, .code, 0);
	TES;

    $XPO_FREE_MEM(STRING = error_desc);

!   Clear sign location and sign status.

    SIGN_LOC = DDU$K_UNSPECIFIED;
    SIGN_STATUS = DDU$K_UNSPECIFIED;
    RETURN SS$_NORMAL
END;
!++
!  DEFINE_FIELD (DEFFLD)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine creates and initializes the field block for the current
!	field and places it into the block structure.
!
!	The PARENT_PTR is used to keep track of the field blocks (which are
!	missing pointers to children, attributes, etc.) until their missing
!	values are initialized.  The END_FLAG is used to determine if a
!	field's children have all been parsed (which helps differentiate
!	between siblings and children).
!
!	This routine is called for DEFINE_ELEMENTARY, DEFINE_COPY,
!	DEFINE_STRUCTURE, DEFINE_VARIANT, and DEFINE_VARIANTS.
!
!  CALLING SEQUENCE:
!
!	DEFINE_FIELD (code.rlu.v, source_loc.rlu.v);
!
!  INPUT PARAMETERS:
!
!	code		is a (long)word value sent from the parser.  It is used
!			to define the type of field to be described.
!
!	source_loc	is a (long)word containing the locator to the source for
!			the field being defined.
!
!  IMPLICIT INPUTS:
!
!	BASE_FL		Base-seen flag
!	COLUMN_MAJOR_FL	Column-major-array flag
!	COMPUTE_TYPE	Computational datatype flag
!	COPY_NAME	COPY stringlist
!	DATATYPE	DATATYPE setting
!	DATATYPE_FL	Datatype-seen flag
!	DIGITS		DIGITS setting
!	DIGITS_FL	Digits-seen flag
!	DIMENSION_FL	Dimension-seen flag
!	FIELD_BASE	BASE setting
!	FIELD_LEN	Length of field in bits
!	FIELD_NAME	Field name
!	INITIAL_FL	Initial-value-seen flag
!	INITIAL_LENGTH	Length of initial value
!	INITIAL_LENGTH_1 Length of real part of complex initial value
!	INITIAL_TYPE	Token type of initial value
!	INITIAL_TYPE_1	Token type of real part of complex initial value
!	INITIAL_TYPE_2	Token type of imaginary part of complex initial value
!	INITIAL_VALUE	Pointer to initial value
!	JUSTIFIED_RIGHT_FL Justified-righted-seen flag
!	LENGTH_FL	Length-seen flag
!	MAX_DIGITS	Maximum digits
!	MAX_DIGITS_FL	Maximum-digits-seen flag
!	SCALE		SCALE setting
!	SCALE_FL	Scale-seen flag
!	STACK_TOP	Current rx_member
!	STRING_TYPE	String datatype flag
!	STRING_UNITS	Characters in string
!	SYNC_LEFT_FL	Synchronized-left flag
!	SYNC_RIGHT_FL	Synchronized-right flag
!	TAG_VALUES_FL	Tag-values-seen flag
!	TAG_VALUES_LIST	Tag values list
!
!  IMPLICIT OUTPUTS:
!
!	COMPUTE_TYPE	Computational datatype flag, cleared
!	COPY_NAME	COPY stringlist, cleared
!	FIELD_NAME	Field name, cleared
!	STACK_TOP	Updated
!	STRING_TYPE	String datatype flag, cleared
!	STRING_UNITS	Characters in string, cleared
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	Indicates that the routine completed successfully
!	FALSE		Indicates that the field name has invalid syntax
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE DEFINE_FIELD (CODE, SOURCE_LOC) =
BEGIN
%BLISS32 (    MAP
	CODE :		LONG,
	SOURCE_LOC :	LONG;)

    LOCAL
	PARENT_PTR:	REF CRX_MEMBER,
	CHILD_PTR:	REF CRX_MEMBER,
	FIELD_PTR:	REF CRX_MEMBER,
	DIM_PTR:	REF CRX_DIMENSION,
	STATUS %BLISS32 (: LONG),
	ADDITIONAL_BLK : REF crx_additional;

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

!   Create new crx_member node.

    $XPO_GET_MEM (FULLWORDS = diu$s_crx_member, fill = 0, result = FIELD_PTR);
    INIT_MEMBER (.field_ptr, NULL_PTR, FIELD_NAME, .SOURCE_LOC);
    ADDITIONAL_BLK = .FIELD_PTR [crm$a_facility];
!   Store collected information:

    IF .COLUMN_MAJOR_FL
	THEN FIELD_PTR [crm$v_column_major] = TRUE;
    IF .SCALE_FL
	THEN FIELD_PTR [crm$w_scale] = .SCALE;
    IF .DATATYPE_FL
	THEN FIELD_PTR [crm$w_datatype] = .DATATYPE;
    IF .LENGTH_FL
	THEN BEGIN
	FIELD_PTR [crm$l_length] = .FIELD_LEN;
	ADDITIONAL_BLK [cra$v_length_set] = TRUE;
!	COMPUTE_ARRAY_LENGTH may change member length, but set up the default:
	FIELD_PTR [crm$l_member_length] = .FIELD_LEN;
	FIELD_PTR [crm$l_string_units] = .STRING_UNITS;
	END;
    IF .DIGITS_FL
	THEN FIELD_PTR [crm$w_digits] = .DIGITS;
    IF .BASE_FL
	THEN FIELD_PTR [crm$b_base] = .FIELD_BASE;
    IF .MAX_DIGITS_FL
	THEN FIELD_PTR [crm$w_max_digits] = .MAX_DIGITS;
    IF .COPY_FL
	THEN BEGIN
	    FIELD_PTR [crm$a_source_type] = .COPY_NAME [str$a_pointer];
	    FIELD_PTR [crm$w_source_length] = .COPY_NAME [str$h_length];
	    COPY_NAME [str$h_length] = 0;
	END;
    IF .INITIAL_FL
	THEN BEGIN
	    FIELD_PTR [crm$a_initial_value] = .INITIAL_VALUE;
	    FIELD_PTR [crm$w_initial_length] = .INITIAL_LENGTH;
	    INITIAL_VALUE = NULL_PTR;
	    ADDITIONAL_BLK [cra$l_initial_type] = .INITIAL_TYPE;
	    ADDITIONAL_BLK [cra$l_initial_type_1] = .INITIAL_TYPE_1;
	    ADDITIONAL_BLK [cra$l_initial_type_2] = .INITIAL_TYPE_2;
	    ADDITIONAL_BLK [cra$l_initial_length_1] = .INITIAL_LENGTH_1;
	END;
    FIELD_PTR [crm$v_string_type] = .STRING_TYPE;
    FIELD_PTR [crm$v_compute_type] = .COMPUTE_TYPE;
    IF .ALIGNMENT_FL
	THEN BEGIN
	    ADDITIONAL_BLK [cra$l_alignment] = .ALIGNMENT;
	    ADDITIONAL_BLK [cra$v_alignment_exists] = TRUE;
	END;
    IF .JUSTIFIED_RIGHT_FL
	THEN FIELD_PTR [crm$v_right_justified] = TRUE;
    IF .DIMENSION_FL
	THEN BEGIN
	FIELD_PTR [crm$a_dimensions] = .FIRST_DIMENSION;
	FIRST_DIMENSION [crd$a_previous] = .FIELD_PTR;
	ADDITIONAL_BLK [cra$v_dimension] = TRUE;
	FIRST_DIMENSION = NULL_PTR;
!	Count number of dimensions:
	FIELD_PTR [crm$b_dimensions_cnt] = 1;
	DIM_PTR = .FIELD_PTR [crm$a_dimensions];
	WHILE ((DIM_PTR = .DIM_PTR [crd$a_next]) NEQA NULL_PTR)
	    DO FIELD_PTR [crm$b_dimensions_cnt] =
		.FIELD_PTR [crm$b_dimensions_cnt] + 1;
	END;
    IF .TAG_VALUES_FL
	THEN BEGIN
	LOCAL
	    TAG_LITLIST: REF crx_literal_list;
	$XPO_GET_MEM (FULLWORDS = diu$s_crx_literal_list, RESULT = TAG_LITLIST,
	    FILL = 0);
	INIT_LITERAL (.TAG_LITLIST);
	FIELD_PTR [crm$a_tag_variable] = .TAG_LITLIST;
	TAG_LITLIST [crl$a_previous] = .FIELD_PTR;
	TAG_LITLIST [crl$a_literals] = .TAG_VALUES_LIST;
	TAG_VALUES_LIST [crs$a_previous] = .TAG_LITLIST;
	IF .TAG_VALUES_LIST [crs$a_next] NEQA NULL_PTR
	    THEN TAG_LITLIST [crl$w_literals_cnt] = 2	! A range
	    ELSE TAG_LITLIST [crl$w_literals_cnt] = 1;	! A value
	END;
!   Set up field type and fully-qualified name:

    SELECTONE .CODE OF SET
	[DEFINE_COPY]:
	    ADDITIONAL_BLK [cra$l_type] = FLD$K_COPY;
	[DEFINE_ELEMENTARY]:
	    ADDITIONAL_BLK [cra$l_type] = FLD$K_ELEMENTARY;
	[DEFINE_STRUCTURE]:
	    BEGIN
	    FIELD_PTR [crm$w_datatype] = DIU$K_DT_STRUCTURE;
	    ADDITIONAL_BLK [cra$l_type] = FLD$K_STRUCTURE;
	    END;
	[DEFINE_VARIANT]:
	    ADDITIONAL_BLK [cra$l_type] = FLD$K_VARIANT;
	[DEFINE_VARIANTS]:
	    BEGIN
		ADDITIONAL_BLK [cra$l_type] = FLD$K_VARIANTS;
		FIELD_PTR [crm$w_datatype] = DIU$K_DT_OVERLAY;
		FIELD_PTR [crm$a_tag_variable] = .QUAL_NAME;
		IF .QUAL_NAME NEQA NULL_PTR
		    THEN BEGIN		! VARIANTS OF has a tag here
			QUAL_NAME [crs$a_previous] = .FIELD_PTR;
			FIELD_PTR [crm$b_tag_variable_cnt] = 1;
			WHILE ((QUAL_NAME = .QUAL_NAME [crs$a_next])
			    NEQA NULL_PTR)
			    DO FIELD_PTR [crm$b_tag_variable_cnt] =
				.FIELD_PTR [crm$b_tag_variable_cnt] + 1;
		    END;	! VARIANTS has no tag - nothing to do
	    END;		! Leave QUAL_NAME a null pointer
    TES;

!   Check syntax of field name:

    IF .CODE NEQU DEFINE_VARIANT AND .CODE NEQU DEFINE_VARIANTS
	THEN BEGIN		! VARIANTS and each VARIANT have no names
	    STATUS = NAME_SYNTAX (.FIELD_NAME [STR$H_LENGTH],
		.FIELD_NAME [STR$A_POINTER],
		.ADDITIONAL_BLK [cra$l_locator]);
	    IF NOT .STATUS
		THEN RETURN FALSE;
	END;

!   Put in field name and clear out FIELD_NAME:

    IF .FIELD_NAME [str$h_length] NEQ 0
	THEN BEGIN		! VARIANTS and each VARIANT have no names
	    FIELD_PTR [crm$b_name_length] = .FIELD_NAME [str$h_length];
	    ch$move ((IF .FIELD_NAME [str$h_length] leq 31
		THEN .FIELD_NAME [str$h_length] ELSE 31),
		.FIELD_NAME [str$a_pointer], ch$ptr (FIELD_PTR [crm$t_name]));
	    $XPO_FREE_MEM (string = FIELD_NAME);
	END;
!   Verify SYNCHRONIZED clause, if any:
!   1.  SYNCHRONIZED applies only to elementary fields.
!   2.  BIT and BYTE alignment are ignored for SYNCHRONIZED fields.
!   3.  SYNCHRONIZED applies only to string types: character string, display
!       numeric, packed decimal, and zoned fields.

    IF .SYNC_LEFT_FL OR .SYNC_RIGHT_FL
	THEN BEGIN
	LOCAL
	    OK_SYNC: INITIAL (TRUE);
	IF .ADDITIONAL_BLK [cra$l_type] NEQ FLD$K_ELEMENTARY
	    THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
		'SYNCHRONIZED ignored for non-elementary fields');
	    OK_SYNC = FALSE;
	    END;
	IF .ADDITIONAL_BLK [cra$v_alignment_exists]
	    AND (.ADDITIONAL_BLK [cra$l_alignment] EQL T_BIT)
	    THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
		'Bit alignment ignored for SYNCHRONIZED field');
	    ADDITIONAL_BLK [cra$v_alignment_exists] = FALSE;
	    END;
	IF .ADDITIONAL_BLK [cra$v_alignment_exists]
	    AND (.ADDITIONAL_BLK [cra$l_alignment] EQL T_BYTE)
	    THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
		'Byte alignment ignored for SYNCHRONIZED field');
	    ADDITIONAL_BLK [cra$v_alignment_exists] = FALSE;
	    END;
	IF NOT .FIELD_PTR [crm$v_string_type]
	    THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
		'SYNCHRONIZED does not apply to this datatype - ignored');
	    OK_SYNC = FALSE;
	    END;
	IF .OK_SYNC
	    THEN BEGIN
	    ADDITIONAL_BLK [cra$v_sync_left] = .SYNC_LEFT_FL;
	    ADDITIONAL_BLK [cra$v_sync_right] = .SYNC_RIGHT_FL;
	    END;
	END;
!   Clean up temporary storage for field attributes.

    CLEAR_ATTRIBUTE_FLAGS ();
    STRING_UNITS = 0;
    COPY_NAME [STR$H_LENGTH] = 0;
    IF .VALUE_LIST NEQA NULL_PTR
	THEN FREE_STRINGLIST (.VALUE_LIST);
    VALUE_LIST = NULL_PTR;
    IF .FIRST_VALUE_LIST NEQA NULL_PTR
	THEN FREE_STRINGLIST (.FIRST_VALUE_LIST);
    FIRST_VALUE_LIST = NULL_PTR;
    IF .FIRST_DIMENSION NEQA NULL_PTR
	THEN FREE_DIMENSIONS (.FIRST_DIMENSION);
    FIRST_DIMENSION = NULL_PTR;
    LAST_DIMENSION = NULL_PTR;
    FIELD_NAME [STR$H_LENGTH] = 0;
    IF .QUAL_NAME NEQA NULL_PTR
	THEN FREE_STRINGLIST (.QUAL_NAME);
    QUAL_NAME = NULL_PTR;
    TAG_VALUES_LIST = NULL_PTR;
!   Figure out where to hook this field into the structure.

!   If this is the first member in a record, point to/from the record node:

    IF .STACK_TOP EQLA NULL_PTR
	THEN BEGIN
	    FIELD_PTR [crm$v_first_child] = TRUE;
	    RECORD_BLK [crx$a_root] = .FIELD_PTR;
	    FIELD_PTR [crm$a_previous] = .RECORD_BLK;
	END
    ELSE

!   If the current top node is a leaf, then the new node is a sibling.
!   If the current top node is an aggregate, then the new one is a child.
!   When we are through processing an aggregate, we set its leaf flag.
!   See the code in END_SET, below.

    IF .STACK_TOP [crm$v_facility_use_1]	! A sibling of the top field
	THEN BEGIN
	    FIELD_PTR [crm$a_previous] = .STACK_TOP;
	    STACK_TOP [crm$a_next] = .FIELD_PTR;

!	    Find parent of sibling group and increment its child count.

	    CHILD_PTR = .STACK_TOP;
	    PARENT_PTR = .STACK_TOP [crm$a_previous];
	    WHILE (.PARENT_PTR [crm$a_children] NEQA .CHILD_PTR)
		DO BEGIN
		    CHILD_PTR = .PARENT_PTR;
		    PARENT_PTR = .CHILD_PTR [crm$a_previous];
		END;
	    PARENT_PTR [crm$w_children_cnt] =
		.PARENT_PTR [crm$w_children_cnt] + 1;
	END
    ELSE					! First child of the top node
	BEGIN
	    FIELD_PTR [crm$a_previous] = .STACK_TOP;
	    STACK_TOP [crm$a_children] = .FIELD_PTR;
	    STACK_TOP [crm$w_children_cnt] = 1;
	    FIELD_PTR [crm$v_first_child] = TRUE;
	END;

!   This is now the top field.

    STACK_TOP = .FIELD_PTR;

!   Set flag if this is a leaf.  Clear flag if it is an aggregate.
!   A COPY field counts as a leaf because it is already a completed aggregate.

    IF .CODE EQLU DEFINE_ELEMENTARY OR .CODE EQLU DEFINE_COPY
	THEN FIELD_PTR [crm$v_facility_use_1] = TRUE
	ELSE FIELD_PTR [crm$v_facility_use_1] = FALSE;

    RETURN SS$_NORMAL
END;
!++
!  DEFINE_GROUP_ATTS (DEFGRP)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine defines the length attribute for the group level fields
!	and the offset attribute for all fields for the record currently being
!	parsed.
!	It also materializes the fields of a COPY template.
!	It is called for GROUP_ATTS.
!
!  CALLING SEQUENCE:
!
!	DEFINE_GROUP_ATTS (field_blk.ra.v, field_offset.mlu.a,
!		total_offset.mlu.a, fld_length.mlu.a);
!
!  INPUT PARAMETERS:
!
!	field_blk	is the address of the field block whose attributes
!			are to be defined.
!
!	field_offset	is the address of a (long)word containing the offset
!			from the beginning of the parent field where the
!			prior field ended.
!
!	total_offset	is the address of a (long)word containing the offset
!			from the beginning of the record to where the prior
!			field ended.
!
!  OUTPUT PARAMETERS:
!
!	field_offset	is the address of a (long)word to be set to the offset
!			of the end of the current field from the beginning
!			of the parent field.
!
!	total_offset	is the address of a (long)word to be set to the offset
!			of the end of the current field from the beginning of
!			the record.
!
!	fld_length	is the address of a (long)word to be set to the length
!			of the current field.
!
!  IMPLICIT INPUTS:
!
!	none
!
!  IMPLICIT OUTPUTS:
!
!	none
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!	FALSE		indicates an undefined group attribute, invalid group
!			attributes of a variants or structure field, or length
!			of a structure or variants was invalid.
!	Status of COPY_RECORD, if this is a copy field.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE DEFINE_GROUP_ATTS (FIELD_BLK, FIELD_OFFSET, TOTAL_OFFSET, FLD_LENGTH) =
BEGIN
    MAP
	FIELD_BLK :		REF	CRX_MEMBER;

    BIND
	ADDITIONAL_BLK = .FIELD_BLK [crm$a_facility]: crx_additional,
	OFFSET = .FIELD_OFFSET %BLISS32 (: LONG),
	MEMBER_OFFSET = .TOTAL_OFFSET %BLISS32 (: LONG),
	TOTAL_LENGTH = .FLD_LENGTH %BLISS32 (: LONG);

    LOCAL
	CHILD_BLK :	REF	CRX_MEMBER,
	CHILD_OFFSET %BLISS32 (: LONG),
	CHILD_MEMBER_OFFSET %BLISS32 (: LONG),
	CHILD_LENGTH %BLISS32 (: LONG),
	COPY_NAME: $STR_DESCRIPTOR (CLASS = DYNAMIC),
	COPY_FIELD %BLISS32 (: LONG),
	MAX_CHILD_LENGTH %BLISS32 (: LONG),
	MAX_CHILD_MEMBER_LENGTH %BLISS32 (: LONG),
	LENGTH %BLISS32 (: LONG),
	STATUS %BLISS32 (: LONG);

    LITERAL
	THIS_SYS = %BLISS32 (SYS_8BIT) %BLISS36 (SYS_LCG);

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

!   Handle a COPY template.

    COPY_FIELD = FALSE;
    IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_COPY
	THEN BEGIN
	    $STR_DESC_INIT (DESCRIPTOR = COPY_NAME, CLASS = DYNAMIC);
	    $STR_COPY (STRING = (.field_blk [crm$w_source_length],
		.field_blk [crm$a_source_type]),
		TARGET = COPY_NAME);
	    STATUS = COPY_RECORD (.FIELD_BLK, COPY_NAME);
	    IF NOT .STATUS
		THEN RETURN .STATUS;
	    COPY_FIELD = TRUE;
	    FIX_COPY_TEMPLATE (.FIELD_BLK, 0);
	END;

    COMPUTE_OFFSETS (offset, member_offset, .field_blk, this_sys);
!   Figure out offsets.

    FIELD_BLK [crm$l_offset] = .OFFSET;
    FIELD_BLK [crm$l_member_offset] = .MEMBER_OFFSET;
    ADDITIONAL_BLK [cra$v_offset_set] = TRUE;
    IF .COPY_FIELD
	THEN BEGIN	! Offsets here only work if COPY is from CDD
	    OFFSET = .OFFSET + .FIELD_BLK [crm$l_length];
	    MEMBER_OFFSET = .MEMBER_OFFSET + .FIELD_BLK [crm$l_member_length];
	    IF .ADDITIONAL_BLK [cra$v_dimension]
		THEN COMPUTE_ARRAY_LENGTH (OFFSET, MEMBER_OFFSET, .FIELD_BLK,
		    this_sys);
	    TOTAL_LENGTH = .FIELD_BLK [crm$l_length];
	    RETURN SS$_NORMAL;
	END;

!   Elementary fields must have lengths.

    IF (.ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_ELEMENTARY) AND
	(NOT .ADDITIONAL_BLK [cra$v_length_set])
	THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
		'Field length not determined');
	    RETURN FALSE;
	END;
!   Handle VARIANTS field.
!   The length of a VARIANTS field is the length of the longest VARIANT.

    IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_VARIANTS
	THEN BEGIN
	    CHILD_BLK = .FIELD_BLK [crm$a_children];
	    WHILE .CHILD_BLK NEQA NULL_PTR DO
		BEGIN
		    CHILD_OFFSET = .OFFSET;
		    CHILD_MEMBER_OFFSET = .MEMBER_OFFSET;
		    STATUS = DEFINE_GROUP_ATTS (.CHILD_BLK, CHILD_OFFSET,
			CHILD_MEMBER_OFFSET, CHILD_LENGTH);
		    IF NOT .STATUS
			THEN RETURN FALSE;
		    IF .CHILD_LENGTH GTRU .FIELD_BLK [crm$l_length]
			THEN FIELD_BLK [crm$l_length] = .CHILD_LENGTH;
		    CHILD_BLK = .CHILD_BLK [crm$a_next];
		END;
	    ADDITIONAL_BLK [cra$v_length_set] = TRUE;
	    FIELD_BLK [crm$l_member_length] = .FIELD_BLK [crm$l_length];
	END;
!   For VARIANT and STRUCTURE, walk the children:

    IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_VARIANT OR
	.ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_STRUCTURE
	THEN BEGIN
	    IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_STRUCTURE
		THEN CHILD_OFFSET = 0		! Start new structure
		ELSE CHILD_OFFSET = .OFFSET;	! The VARIANT is not a structure
	    CHILD_MEMBER_OFFSET = .MEMBER_OFFSET;
	    CHILD_BLK = .FIELD_BLK [crm$a_children];
	    MAX_CHILD_LENGTH = 0;
	    MAX_CHILD_MEMBER_LENGTH = 0;
	    WHILE .CHILD_BLK NEQA NULL_PTR DO
		BEGIN
		    STATUS = DEFINE_GROUP_ATTS (.CHILD_BLK, CHILD_OFFSET,
			CHILD_MEMBER_OFFSET, CHILD_LENGTH);
		    IF NOT .STATUS
			THEN RETURN FALSE;
		    IF .CHILD_BLK [crm$l_length] GTR
			.MAX_CHILD_LENGTH
			THEN MAX_CHILD_LENGTH = .CHILD_BLK [crm$l_length];
		    IF .CHILD_BLK [crm$l_member_length] GTR
			.MAX_CHILD_MEMBER_LENGTH
			THEN MAX_CHILD_MEMBER_LENGTH =
			    .CHILD_BLK [crm$l_member_length];
		    LENGTH = .CHILD_BLK [crm$l_offset] +
			.CHILD_BLK [crm$l_member_length];
		    CHILD_BLK = .CHILD_BLK [crm$a_next];
		END;
	    IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_VARIANT
		THEN LENGTH = .LENGTH - .OFFSET;
	    IF NOT .ADDITIONAL_BLK [cra$v_length_set]
		THEN BEGIN
		    FIELD_BLK [crm$l_member_length] = .LENGTH;
		    IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_STRUCTURE
			THEN FIELD_BLK [crm$l_length] = .LENGTH
			ELSE BEGIN
			    FIELD_BLK [crm$l_length] = .MAX_CHILD_LENGTH;
			    ADDITIONAL_BLK [cra$l_max_member_length] =
				.MAX_CHILD_MEMBER_LENGTH;
			    END;
		    ADDITIONAL_BLK [cra$v_length_set] = TRUE;
		END
	    ELSE
		IF .FIELD_BLK [crm$l_length] LSSU .LENGTH
		    THEN BEGIN
			LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
			    'Invalid length');
			RETURN FALSE;
		    END;
	END;
!   Update offsets to those of end of field for return from this routine:

    COMPUTE_END_OFFSETS (OFFSET, MEMBER_OFFSET, .FIELD_BLK, THIS_SYS);

!   Update offsets to add additional length caused by dimensions:

    IF .ADDITIONAL_BLK [cra$v_dimension]
	THEN COMPUTE_ARRAY_LENGTH (OFFSET, MEMBER_OFFSET, .FIELD_BLK, THIS_SYS);

!   Compute total length of field:

    TOTAL_LENGTH = .FIELD_BLK [crm$l_length];
    RETURN SS$_NORMAL
END;
!++
!  DEFINE_NUM_ATT (DEFNUM)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine defines the aligned or digits attributes for the field
!	whose attributes are currently being parsed.
!	It is called for DIGITS_ATT and ALIGNED_ATT.
!
!  CALLING SEQUENCE:
!
!	DEFINE_NUM_ATT (code.rlu.v);
!
!  INPUT PARAMETERS:
!
!	code		is a (long)word value sent from the parser.  It is used
!			to define the type of attribute to be described.
!
!  IMPLICIT INPUTS:
!
!	ALIGNMENT_FL	Alignment-seen flag
!	DIGITS_FL	Digits-seen flag
!	PAT$TOKEN_CURRENT_PTR Current token
!
!  IMPLICIT OUTPUTS:
!
!	ALIGNMENT	ALIGNED value
!	ALIGNMENT_FL	Alignment-seen flag, set
!	BASE_FL		Base-seen flag, set
!	DIGITS		DIGITS value
!	DIGITS_FL	Digits-seen flag, set
!	FIELD_BASE	Base value, set to 10 by default
!	MAX_DIGITS	Maximum-digits value
!	MAX_DIGITS_FL	Maximum-digits-seen flag
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!	FALSE		Indicates a multiply-defined attribute.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE DEFINE_NUM_ATT (CODE) =
BEGIN
%BLISS32 (    MAP
	CODE :		LONG;)

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

!   Handle ALIGNED_ATT:

    IF .CODE EQLU ALIGNED_ATT
	THEN IF .ALIGNMENT_FL
	    THEN BEGIN
		LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		    'Multiple ALIGNED attributes');
		RETURN FALSE;
	    END
	    ELSE BEGIN
		ALIGNMENT_FL = TRUE;
		ALIGNMENT = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);
	    END

!   Handle DIGITS_ATT:

	ELSE IF .DIGITS_FL
	    THEN BEGIN
		LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		    'Multiple DIGITS attributes');
		RETURN FALSE;
	    END
	    ELSE BEGIN
		DIGITS_FL = TRUE;
		DIGITS = LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
		MAX_DIGITS_FL = TRUE;
		MAX_DIGITS = .DIGITS;
		BASE_FL = TRUE;
		FIELD_BASE = 10;
	    END;

    RETURN SS$_NORMAL
END;
!++
!  DEFINE_RECORD (DEFREC)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine defines the name and description for the record being
!	described.  It initializes the crx_record RECORD_BLK.
!	It is called for DEFINE_THE_RECORD when the end of the DEFINE
!	RECORD clause is seen.
!
!  CALLING SEQUENCE:
!
!	DEFINE_RECORD (root);
!
!  INPUT PARAMETERS:
!
!	root		Address where caller wants root of record tree
!			(also in RECORD_BLK)
!
!  IMPLICIT INPUTS:
!
!	RECORD_BLK	Current (old) record block, if any
!
!  IMPLICIT OUTPUTS:
!
!	NAME_BLOCK	Name of record, cleared
!	RECORD_BLK	Initialized
!	RECORD_NAME	Name of record
!	STACK_TOP	Reset to a null pointer
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--

ROUTINE DEFINE_RECORD (root) : NOVALUE =
BEGIN

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

!   If there was a record block already, get rid of it and anything it
!   points to.

    IF ..ROOT NEQA NULL_PTR
	THEN FREE_RECORD (..ROOT);

!   Reset STACK_TOP, in case there is some old address in there:

    STACK_TOP = NULL_PTR;

!   Set up record block:

    $XPO_GET_MEM (FULLWORDS = diu$S_CRX_RECORD, FILL = 0, RESULT = RECORD_BLK);

!   Set record root where caller wants it:

    .root = .record_blk;

!   Initialize the new record block:

    RECORD_BLK [crx$l_mbz] = NULL_PTR;			! Must be zero
    RECORD_BLK [crx$b_id] = crx$k_record;		! Block id
    RECORD_BLK [crx$b_core_level] = 4;			! Core level (must be 4)
    ch$move (10, ch$ptr (uplit ('CDD$RECORD')),
	ch$ptr (RECORD_BLK [crx$t_protocol]));		! Protocol name
    RECORD_BLK [crx$w_facility_code] = 0;		! Facility code
    RECORD_BLK [crx$b_description_cnt] = 0;		! Description count
    RECORD_BLK [crx$a_facility] = NULL_PTR;		! Facility code
    RECORD_BLK [crx$l_format] = CDD$K_REC_FIXED;	! Fixed or Variable
    RECORD_BLK [crx$a_description] = NULL_PTR;		! Pointer to description

!   Save record name:

    $STR_DESC_INIT (DESCRIPTOR = RECORD_NAME, CLASS = DYNAMIC);
    RECORD_NAME [str$a_pointer] = .NAME_BLOCK [str$a_pointer];
    RECORD_NAME [str$h_length] = .NAME_BLOCK [str$h_length];
    NAME_BLOCK [STR$H_LENGTH] = 0;

!   Clean up attribute flags.

    CLEAR_ATTRIBUTE_FLAGS ();

END;
!++
!  DEFINE_SCALE (DEFSCL)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine defines the scale attribute for the field currently being
!	defined.
!	For fractions, the scale value is the negative of the number of
!	fractional digits.
!	It is called for SCALE_ATT and FRACTIONS_ATT.
!
!  CALLING SEQUENCE:
!
!	DEFINE_SCALE (scale_value.rlu.v);
!
!  INPUT PARAMETERS:
!
!	scale_value	is a (long)word value representing the scale.
!
!  IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR Current token
!	SCALE_FL	Scale-seen flag
!
!  IMPLICIT OUTPUTS:
!
!	BASE_FL		Base-seen flag, set
!	FIELD_BASE	Base value, set to 10 by default
!	SCALE		Scale value
!	SCALE_FL	Scale-seen flag, updated
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!	FALSE		Indicates multiple scale factors.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE DEFINE_SCALE (SCALE_VALUE) =
BEGIN

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

    IF NOT .SCALE_FL
	THEN BEGIN
	    SCALE = .SCALE_VALUE;
	    SCALE_FL = TRUE;
	    BASE_FL = TRUE;
	    FIELD_BASE = 10;
	    RETURN SS$_NORMAL;
	END;

    IF .SCALE NEQU .SCALE_VALUE
	THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		'Inconsistent scale factors not allowed');
	    RETURN FALSE;
	END;

    RETURN SS$_NORMAL
END;
!++
!  END_SET (ENDSET)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine does the necessary flag setting in the field block when
!	an end statement has been encountered.  It also verifies that the name
!	used in an end statement matches the corresponding defined name, if one
!	was specified.
!	It is called for DEFINE_END_NO_NAME, DEFINE_END_NAME, END_NO_NAME,
!	and END_NAME.
!
!  CALLING SEQUENCE:
!
!	END_SET (code.rlu.v);
!
!  INPUT PARAMETERS:
!
!	code		is a (long)word value that determines if a name was
!			supplied in the end statement.
!
!  IMPLICIT INPUTS:
!
!	NAME_BLOCK	Descriptor to name in END clause, if any
!	PAT$TOKEN_CURRENT_PTR Current token
!	STACK_TOP	Current crx_member
!
!  IMPLICIT OUTPUTS:
!
!	STACK_TOP	Reset to top crx_member in structure
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!	FALSE		Indicates that the name in the END statement does
!			not match.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE END_SET (CODE) =
BEGIN
%BLISS32 (    MAP
	CODE :	LONG;)

    LITERAL
	L_PAREN	=	%C'(',
	R_PAREN =	%C')',
	DOT = 		%C'.';

    LOCAL
	CURRENT: REF CRX_MEMBER,
	REF_CHAR %BLISS32 (: LONG),
	LAST_CHAR %BLISS32 (: LONG);

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

!   Reset the stack top if it was pointing to the field's child.

    IF .STACK_TOP NEQA NULL_PTR AND .STACK_TOP [crm$v_facility_use_1]
	AND .STACK_TOP NEQA .RECORD_BLK [crx$a_root]	! Not the only field
	THEN BEGIN	! Look for field who is parent rather than sibling
	    CURRENT = .STACK_TOP [crm$a_previous];
	    WHILE (.CURRENT [crm$a_children] NEQA .STACK_TOP)
		DO BEGIN
		    STACK_TOP = .CURRENT;
		    CURRENT = .STACK_TOP [crm$a_previous];
		END;
	    STACK_TOP = .CURRENT;
	END;

!   Close off the aggregate.  After this, treat it as a leaf.
!   See the code in DEFINE_FIELD for uses of this flag.

    IF .STACK_TOP NEQA NULL_PTR
	THEN STACK_TOP [crm$v_facility_use_1] = TRUE;

!   Check if a structure name was specified.  If not, then return.

    IF (.CODE EQLU END_NO_NAME) OR (.CODE EQLU DEFINE_END_NO_NAME)
	OR (.CODE EQLU DEFINE_END_NAME)
	THEN RETURN SS$_NORMAL;

    IF .STACK_TOP NEQA NULL_PTR
	THEN BEGIN
	    IF CH$EQL (.STACK_TOP [crm$b_name_length],
		ch$ptr (STACK_TOP [crm$t_name]),
		.NAME_BLOCK [str$h_length],
		.NAME_BLOCK [STR$A_POINTER], %C' ')
	    THEN RETURN SS$_NORMAL
	    ELSE
		BEGIN
		    LSLOCAL_SYNTAX_ERRORM
			(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
			'Structure names do not match');
		    RETURN FALSE;
		END;
	END;
!   If the defined name is a path-name, then extract the given name for
!   comparison.  (i.e. Trim any password and preceding node names.)

    REF_CHAR = ch$plus (.RECORD_NAME [str$a_pointer],
	.RECORD_NAME [str$h_length]);
    IF CH$RCHAR (.REF_CHAR) EQLU R_PAREN
	THEN BEGIN
	    WHILE CH$RCHAR (.REF_CHAR) NEQU L_PAREN DO
		REF_CHAR = ch$plus (.REF_CHAR, -1);
	    REF_CHAR = ch$plus (.REF_CHAR, -1);
	END;

    LAST_CHAR = .REF_CHAR;
    WHILE (CH$DIFF (.REF_CHAR, .RECORD_NAME [str$a_pointer]) GTR 0)
	AND CH$RCHAR (ch$plus (.REF_CHAR, -1)) NEQU DOT
    DO
	REF_CHAR = ch$plus (.REF_CHAR, -1);

    IF CH$EQL (ch$diff (.LAST_CHAR, .REF_CHAR) + 1, .REF_CHAR,
	.NAME_BLOCK [STR$H_LENGTH], .NAME_BLOCK [STR$A_POINTER], %C' ')
	THEN RETURN SS$_NORMAL;

    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
	'Record name mismatch');
    RETURN FALSE
END;
!++
!  EXTRACT_NAME (EXTNAM)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine extracts a path name or CDD name from the present token
!	block and places it in the NAME_BLOCK.  If a pathname contains a
!	relative version number, the semicolon and version number are
!	stripped off the pathname before it is placed in the NAME_BLOCK,
!	and a warning is issued.
!	This routine is called for STORE_NAME.
!
!  CALLING SEQUENCE:
!
!	EXTRACT_NAME (locator.rlu.v);
!
!  INPUT PARAMETERS:
!
!	locator		is the (long)word value of the source locator.
!
!  IMPLICIT INPUTS:
!
!	NAME_BLOCK		Old name block, if any (freed)
!	PAT$TOKEN_CURRENT_PTR	Pointer to the most recently read lexical token.
!
!  IMPLICIT OUTPUTS:
!
!	NAME_BLOCK		Name block, created
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--

ROUTINE EXTRACT_NAME (LOCATOR) : NOVALUE =
BEGIN
%BLISS32 (    MAP
	LOCATOR :	LONG;)

    LITERAL
	SEMI =	  %C';',
	MINUS =	  %C'-',
	ZERO =    %C'0',
	L_PAREN = %C'(';

    LOCAL
	SEMI_PTR %BLISS32 (: LONG),
	VERNUM_PTR %BLISS32 (: LONG),
	L_PAREN_PTR %BLISS32 (: LONG),
	LAST_CHAR_PTR %BLISS32 (: LONG),
	NEXT_CHAR %BLISS32 (: BYTE),
	REL_VER_NUM %BLISS32 (: BYTE),
	PASSWORD_LENG %BLISS32 (: WORD),
	PATHNAME_LENG %BLISS32 (: WORD),
	LENGTH %BLISS32 (: WORD);

    BIND TOKEN = (LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR)): $STR_DESCRIPTOR ();

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

!   See if the name in PAT$TOKEN_CURRENT_PTR contains a relative version number.

    SEMI_PTR = CH$FIND_CH (.TOKEN [STR$H_LENGTH],
	.TOKEN [STR$A_POINTER], SEMI);
    REL_VER_NUM = FALSE;
    IF NOT CH$FAIL (.SEMI_PTR)
	THEN BEGIN
	    LAST_CHAR_PTR = ch$plus (.TOKEN [STR$A_POINTER],
		.TOKEN [STR$H_LENGTH] - 1);
	    PATHNAME_LENG = ch$diff (.SEMI_PTR, .TOKEN [STR$A_POINTER]);

	    VERNUM_PTR = .SEMI_PTR;
	    NEXT_CHAR = CH$A_RCHAR (VERNUM_PTR);
	    REL_VER_NUM = FALSE;
	    IF .NEXT_CHAR EQLU MINUS 
		THEN REL_VER_NUM = TRUE
	    ELSE IF .NEXT_CHAR EQLU ZERO
		THEN BEGIN
		    REL_VER_NUM = TRUE;
		    WHILE (.NEXT_CHAR NEQU L_PAREN) AND 
			  (ch$diff (.LAST_CHAR_PTR, .VERNUM_PTR) GTR 0)
			   AND .REL_VER_NUM DO BEGIN
			    NEXT_CHAR = CH$A_RCHAR (VERNUM_PTR);
			    IF .NEXT_CHAR NEQU ZERO
				THEN REL_VER_NUM = FALSE;
			END;
		END;
	END;

!   If the name contains a relative version number, see if it also contains
!   a password.

    IF .REL_VER_NUM
	THEN BEGIN
	    L_PAREN_PTR = CH$FIND_CH (.TOKEN [STR$H_LENGTH],
		.TOKEN [STR$A_POINTER], L_PAREN);
	    IF NOT CH$FAIL (.L_PAREN_PTR)
		THEN PASSWORD_LENG = ch$diff (.LAST_CHAR_PTR, .L_PAREN_PTR) + 1
		ELSE PASSWORD_LENG = 0;
	END;

!   Set up NAME_BLOCK.

    IF .REL_VER_NUM
	THEN LENGTH = .PATHNAME_LENG + .PASSWORD_LENG
	ELSE LENGTH = .TOKEN [STR$H_LENGTH];

    IF .NAME_BLOCK [STR$H_LENGTH] NEQU 0
	THEN $XPO_FREE_MEM (STRING = NAME_BLOCK);
    NAME_BLOCK [STR$H_LENGTH] = .LENGTH;
    $STR_DESC_INIT (DESCRIPTOR = NAME_BLOCK, CLASS = DYNAMIC);
    $XPO_GET_MEM (CHARACTERS = .LENGTH,
	DESCRIPTOR = NAME_BLOCK);

!   Move the name to NAME_BLOCK, without the version number if it is relative.
!   And don't forget the password!

    IF .REL_VER_NUM
	THEN BEGIN
	    LAST_CHAR_PTR = CH$MOVE (.PATHNAME_LENG, 
		.TOKEN [STR$A_POINTER], .NAME_BLOCK [STR$A_POINTER]);
	    IF .PASSWORD_LENG NEQU 0
		THEN CH$MOVE (.PASSWORD_LENG, .L_PAREN_PTR, .LAST_CHAR_PTR);
	END
    ELSE 
    	CH$MOVE (.LENGTH, .TOKEN [STR$A_POINTER],
	    .NAME_BLOCK [STR$A_POINTER]);

END;
!++
!  FULLY_QUALIFIED_NAME (FULQUL)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine creates and initializes the stringlist blocks for a fully
!	qualified name.
!	QUAL_NAME is set to point to the resulting stringlists.
!	It is called for FULLY_QUAL.
!	The fully-qualified name is either the variable name in an OCCURS
!	DEPENDING or the tag name in VARIANTS OF.
!
!  CALLING SEQUENCE:
!
!	FULLY_QUALIFIED_NAME ();
!
!  INPUT PARAMETERS:
!
!	none
!
!  IMPLICIT INPUTS:
!
!	NAME_BLOCK	Current name
!
!  IMPLICIT OUTPUTS:
!
!	NAME_BLOCK	Current name, cleared
!	QUAL_NAME	Pointer to stringlist of fully-qualified name
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!	FALSE		Indicates that the name contained passwords or a
!			version number
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE FULLY_QUALIFIED_NAME =
BEGIN

    LOCAL
	NEW_NAME	: REF	crx_stringlist,
	LATEST_NAME	: REF	crx_stringlist,
	STR_LENGTH	%BLISS32 (: WORD),
	REM_LENGTH	%BLISS32 (: WORD),
	NAME_START	%BLISS32 (: LONG),
	NAME_END	%BLISS32 (: LONG);

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

    IF .NAME_BLOCK [STR$H_LENGTH] EQLU 0
	THEN RETURN SS$_NORMAL;

!   Make sure that no passwords are in the pathname.  Print an error and return
!   if it contains passwords.

    NAME_END = CH$FIND_CH (
	.NAME_BLOCK [STR$H_LENGTH], .NAME_BLOCK [STR$A_POINTER], %C'(');
    IF NOT CH$FAIL (.NAME_END)
	THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		'Illegal fully qualified name');
	    RETURN FALSE;
	END;

!   Make sure that no version number is in the pathname.  Print an error
!   and return if it contains a version number.

    NAME_END = CH$FIND_CH (
	.NAME_BLOCK [STR$H_LENGTH], .NAME_BLOCK [STR$A_POINTER], %C';');
    IF NOT CH$FAIL (.NAME_END)
	THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		'Illegal fully qualified name');
	    RETURN FALSE;
	END;

    NAME_START = .NAME_BLOCK [STR$A_POINTER];
    NAME_END = .NAME_START;

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

    WHILE (ch$diff (
	ch$plus (.NAME_BLOCK [STR$A_POINTER], .NAME_BLOCK [STR$H_LENGTH]),
	    .NAME_END)
	NEQ 0)
	DO BEGIN
	    $XPO_GET_MEM (FULLWORDS = diu$s_crx_stringlist, RESULT = NEW_NAME,
		FILL = 0);
	    INIT_STRINGLIST (.NEW_NAME);
	    IF (.QUAL_NAME NEQA NULL_PTR)
		THEN BEGIN	! Attach new piece to end of list
		    NEW_NAME [crs$a_previous] = .LATEST_NAME;
		    LATEST_NAME [crs$a_next] = .NEW_NAME;
		    LATEST_NAME = .NEW_NAME;
		END
		ELSE BEGIN	! Start list of stringlists
		    QUAL_NAME = .NEW_NAME;
		    LATEST_NAME = .NEW_NAME;
		END;
	    REM_LENGTH = ch$diff
		(ch$plus (.NAME_BLOCK [STR$A_POINTER],
		.NAME_BLOCK [STR$H_LENGTH]),
		.NAME_START);
	    NAME_END = CH$FIND_CH (.REM_LENGTH, .NAME_START, %C'.');
	    IF CH$FAIL (.NAME_END)	! Point to last char. in name string
		THEN NAME_END = ch$plus (.NAME_BLOCK [STR$A_POINTER],
		    .NAME_BLOCK [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 the '.'.
	END;

!   Clear the name pointer block.

    $XPO_FREE_MEM (STRING = NAME_BLOCK);
    NAME_BLOCK [STR$H_LENGTH] = 0;
    RETURN SS$_NORMAL
END;
!++
!  SAVE_COMPLEX_VALUE (SAVCPX)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine stores part of a complex number in SAVED_VALUE1 (real part)
!	or SAVED_VALUE2 (imaginary part) for future use.
!	It is called for SAVE_COMPLEX1 and SAVE_COMPLEX2.
!	The complex value is either an initial value (see CREATE_STR_ATT)
!	or a tag value in a VARIANT (see SETUP_VALUE_RANGE, SAVE_LOWER_BOUND,
!	and SAVE_VALUES_LIST).
!
!  CALLING SEQUENCE:
!
!	SAVE_COMPLEX_VALUE (code.rlu.v);
!
!  INPUT PARAMETERS:
!
!	code		is a (long)word flag used to determine whether the
!			first or second half of the complex number is being
!			defined.
!
!  IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR	Current lexical token
!
!  IMPLICIT OUTPUTS:
!
!	SAVED_TYPE		Datatype of SAVED_VALUE
!	SAVED_TYPE1		Token type of real part of complex value
!	SAVED_TYPE2		Token type of imaginary part
!	SAVED_VALUE1		Real part of complex value
!	SAVED_VALUE2		Imaginary part of complex value
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE SAVE_COMPLEX_VALUE (CODE) : NOVALUE =
BEGIN
%BLISS32 (    MAP
	CODE :	LONG;)

    LOCAL
	VALUE :		REF	$STR_DESCRIPTOR (CLASS=DYNAMIC);

    BIND
	TOKEN = (LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR)): $STR_DESCRIPTOR (),
	TERM = (LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR));

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

    VALUE = (IF .CODE EQLU SAVE_COMPLEX1 THEN SAVED_VALUE1 ELSE SAVED_VALUE2);
    IF .CODE EQL SAVE_COMPLEX1
	THEN SAVED_TYPE1 = TERM
	ELSE SAVED_TYPE2 = TERM;
    SAVED_TYPE = NT_COMPLEX_NUMBER;
    VALUE [STR$H_LENGTH] = .TOKEN [STR$H_LENGTH];
    $STR_DESC_INIT (DESCRIPTOR = .VALUE, CLASS = DYNAMIC);
    $XPO_GET_MEM (CHARACTERS = .TOKEN [STR$H_LENGTH], DESCRIPTOR = .VALUE);
    CH$MOVE (.TOKEN [STR$H_LENGTH], .TOKEN [STR$A_POINTER],
	.VALUE [STR$A_POINTER]);

END;
!++
!  SAVE_FIELDNAME (SAVFLD)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine saves the current field name.
!	The field name is in NAME_BLOCK.  The data is moved to FIELD_NAME
!	and NAME_BLOCK is cleared.
!	Ths routine is called for SAVE_FIELD_NAME.
!
!  CALLING SEQUENCE:
!
!	SAVE_FIELDNAME ();
!
!  INPUT PARAMETERS:
!
!	none
!
!  IMPLICIT INPUTS:
!
!	NAME_BLOCK:	Descriptor for the name
!
!  IMPLICIT OUTPUTS:
!
!	FIELD_NAME:	Descriptor for the field name
!	NAME_BLOCK:	Cleared
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE SAVE_FIELDNAME : NOVALUE =
BEGIN

    DEB_EVENT ('Semantics actions',
	PUT_MSG_EOL ('ACTION_ROUTINE called SAVE_FIELDNAME'));

    IF .FIELD_NAME [STR$H_LENGTH] NEQU 0
	THEN RETURN;
    $STR_DESC_INIT (DESCRIPTOR = FIELD_NAME, CLASS = DYNAMIC);
    FIELD_NAME [STR$H_LENGTH] = .NAME_BLOCK [STR$H_LENGTH];
    FIELD_NAME [STR$A_POINTER] = .NAME_BLOCK [STR$A_POINTER];
    NAME_BLOCK [STR$H_LENGTH] = 0;
END;
!++
!  SAVE_SOURCE (SAVSRC)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine saves the current name as the source field name.  The
!	current field name is in NAME_BLOCK.  The data is moved to
!	SOURCE_NAME and NAME_BLOCK is cleared.
!	This routine is called for SOURCE.
!
!  CALLING SEQUENCE:
!
!	SAVE_SOURCE ();
!
!  INPUT PARAMETERS:
!
!	none
!
!  IMPLICIT INPUTS:
!
!	NAME_BLOCK:	Descriptor for the name
!
!  IMPLICIT OUTPUTS:
!
!	SOURCE_NAME:	Descriptor for the source name
!	NAME_BLOCK:	Cleared
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE SAVE_SOURCE : NOVALUE =
BEGIN

    DEB_EVENT ('Semantic actions',
	PUT_MSG_EOL ('ACTION_RTN called SAVE_SOURCE'));

    IF .SOURCE_NAME [STR$H_LENGTH] NEQU 0
	THEN RETURN;
    $STR_DESC_INIT (DESCRIPTOR = SOURCE_NAME, CLASS = DYNAMIC);
    SOURCE_NAME [STR$H_LENGTH] = .NAME_BLOCK [STR$H_LENGTH];
    SOURCE_NAME [STR$A_POINTER] = .NAME_BLOCK [STR$A_POINTER];
    NAME_BLOCK [STR$H_LENGTH] = 0;
END;
!++
!  SAVE_DEST (SAVDST)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine saves the current name as the destination field name.
!	The current name is in NAME_BLOCK.  The data is moved to DEST_NAME
!	and NAME_BLOCK is cleared.
!	This routine is called for DEST.
!
!  CALLING SEQUENCE:
!
!	SAVE_DEST ();
!
!  INPUT PARAMETERS:
!
!	none
!
!  IMPLICIT INPUTS:
!
!	NAME_BLOCK:	descriptor for the name
!
!  IMPLICIT OUTPUTS:
!
!	DEST_NAME:	Descriptor for the destination name
!	NAME_BLOCK:	Cleared
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  COMPLETION STATUS:
!
!	none
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE SAVE_DEST : NOVALUE =
BEGIN

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

    IF .DEST_NAME [STR$H_LENGTH] NEQU 0
	THEN RETURN;
    $STR_DESC_INIT (DESCRIPTOR = DEST_NAME, CLASS = DYNAMIC);
    DEST_NAME [STR$H_LENGTH] = .NAME_BLOCK [STR$H_LENGTH];
    DEST_NAME [STR$A_POINTER] = .NAME_BLOCK [STR$A_POINTER];
    NAME_BLOCK [STR$H_LENGTH] = 0;

END;
!++
!  SAVE_LOWER_BOUND (SAVLWR)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine saves the current lower bound of a range of values in
!	SAVED_LOWERn.
!	It is called for SAVE_VAL_TYPE.
!
!  CALLING SEQUENCE:
!
!	SAVE_LOWER_BOUND ();
!
!  INPUT PARAMETERS:
!
!	none
!
!  IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR Current token
!	SAVED_TYPE	Datatype of SAVED_VALUEn
!	SAVED_TYPE1	Token type of SAVED_VALUE1
!	SAVED_TYPE2	Token type of SAVED_VALUE2
!	SAVED_VALUE1	Saved value
!	SAVED_VALUE2	...
!
!  IMPLICIT OUTPUTS:
!
!	LOWER_TYPE	Datatype of SAVED_LOWER
!	LOWER_TYPE1	Token type of SAVED_LOWER1
!	LOWER_TYPE2	Token type of SAVED_LOWER2
!	SAVED_LOWER1	Saved lower bound, cleared
!	SAVED_LOWER2	...
!	SAVED_VALUE1	Saved value
!	SAVED_VALUE2	...
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE SAVE_LOWER_BOUND : NOVALUE =
BEGIN

    BIND TOKEN = (LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR)): $STR_DESCRIPTOR ();

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

    IF .SAVED_VALUE1 [STR$H_LENGTH] NEQU 0	! Complex value
	THEN BEGIN
	    $STR_DESC_INIT (DESCRIPTOR = SAVED_LOWER1, CLASS = DYNAMIC);
	    SAVED_LOWER1 [STR$H_LENGTH] = .SAVED_VALUE1 [STR$H_LENGTH];
	    SAVED_LOWER1 [STR$A_POINTER] = .SAVED_VALUE1 [STR$A_POINTER];
	    $STR_DESC_INIT (DESCRIPTOR = SAVED_LOWER2, CLASS = DYNAMIC);
	    SAVED_LOWER2 [STR$H_LENGTH] = .SAVED_VALUE2 [STR$H_LENGTH];
	    SAVED_LOWER2 [STR$A_POINTER] = .SAVED_VALUE2 [STR$A_POINTER];
	    LOWER_TYPE = .SAVED_TYPE;
	    LOWER_TYPE1 = .SAVED_TYPE1;
	    LOWER_TYPE2 = .SAVED_TYPE2;
	    SAVED_VALUE1 [STR$H_LENGTH] = 0;
	    SAVED_VALUE2 [STR$H_LENGTH] = 0;
	END
    ELSE					! Not complex value
	BEGIN
	    SAVED_LOWER1 [STR$H_LENGTH] = .TOKEN [STR$H_LENGTH];
	    $STR_DESC_INIT (DESCRIPTOR = SAVED_LOWER1, CLASS = DYNAMIC);
	    $XPO_GET_MEM (CHARACTERS = .TOKEN [STR$H_LENGTH],
		DESCRIPTOR = SAVED_LOWER1);
	    CH$MOVE (.TOKEN [STR$H_LENGTH], .TOKEN [STR$A_POINTER],
		.SAVED_LOWER1 [STR$A_POINTER]);
	    LOWER_TYPE = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);
	END;

END;
!++
!  SAVE_VALUES_LIST (SAVVAL)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine puts the tag values list into TAG_VALUES_LIST.
!	It is called for TAG_VALUES.
!
!  CALLING SEQUENCE:
!
!	SAVE_VALUES_LIST (code.rlu.v);
!
!  INPUT PARAMETERS:
!
!	code		is a (long)word value that determines which value list
!			is to be initialized.
!
!  IMPLICIT INPUTS:
!
!	FIRST_VALUE_LIST	Head of values list
!	PAT$TOKEN_CURRENT_PTR	Current token
!	TAG_VALUES_FL		Tag-values-seen flag
!
!  IMPLICIT OUTPUTS:
!
!	FIRST_VALUE_LIST	Head of values list, cleared
!	LAST_VALUE_LIST		Tail of values list, cleared
!	TAG_VALUES_FL		Tag-values-seen flag, updated
!	TAG_VALUES_LIST		Tag values list pointer
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!	FALSE		Indicates that there were multiple value lists.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE SAVE_VALUES_LIST (CODE) =
BEGIN
%BLISS32 (    MAP
	CODE :	LONG;)

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

    IF .TAG_VALUES_FL
	THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		'Multiple tag value lists');
	    RETURN FALSE;
	END
	ELSE TAG_VALUES_FL = TRUE;

    TAG_VALUES_LIST = .FIRST_VALUE_LIST;
    FIRST_VALUE_LIST = NULL_PTR;
    LAST_VALUE_LIST = NULL_PTR;

    RETURN SS$_NORMAL
END;
!++
!  SET_SYNCHRONIZED (SETSYN)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine handles the SYNCHRONIZED clause.
!
!  CALLING SEQUENCE:
!
!	SET_SYNCHRONIZED (code);
!
!  INPUT PARAMETERS:
!
!	code		Value indicating which flag to set
!
!  IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR	Current lexical token
!	SYNC_LEFT_FL		Synchronized-left flag
!	SYNC_RIGHT_FL		Synchronized-right flag
!
!   IMPLICIT OUTPUTS:
!
!	SYNC_LEFT_FL		Synchronized-left flag, set if appropriate
!	SYNC_RIGHT_FL		Synchronized-right flag, set if appropriate
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
ROUTINE SET_SYNCHRONIZED (CODE): NOVALUE =
BEGIN

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

IF .SYNC_LEFT_FL OR .SYNC_RIGHT_FL
    THEN BEGIN
	LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
	    'Multiple SYNCHRONIZED clauses - ignored');
	RETURN;
	END;

IF .CODE EQL SYNC_LEFT
    THEN SYNC_LEFT_FL = TRUE
    ELSE SYNC_RIGHT_FL = TRUE;

RETURN;

END;
!++
!  SET_ATT (SETATT)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine is called for JUSTIFIED_R.
!
!  CALLING SEQUENCE:
!
!	SET_ATT (code.rlu.v);
!
!  INPUT PARAMETERS:
!
!	code		is a (long)word value used to determine the flag to
!			be set.
!
!  IMPLICIT INPUTS:
!
!	JUSTIFIED_RIGHT_FL	Justified-right-seen flag
!	PAT$TOKEN_CURRENT_PTR	Current token
!
!  IMPLICIT OUTPUTS:
!
!	JUSTIFIED_RIGHT_FL	Justified-right-seen flag, set
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL	indicates that the routine completed successfully.
!	FALSE		if the attribute was multiply-defined.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE SET_ATT (CODE) =
BEGIN
%BLISS32 (    MAP
	CODE :		LONG;)

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

    IF .JUSTIFIED_RIGHT_FL
	THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		'Multiple JUSTIFIED_RIGHT clauses');
	    RETURN FALSE;
	END;

    JUSTIFIED_RIGHT_FL = TRUE;

    RETURN SS$_NORMAL
END;
!++
!  SETUP_VALUE_RANGE (SETRNG)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine creates and initializes a SAB block for the next value in
!	the value list for the current attribute.
!	It is called for LOWER_BND and UPPER_BND.
!
!  CALLING SEQUENCE:
!
!	SETUP_VALUE_RANGE (code.rlu.v);
!
!  INPUT PARAMETERS:
!
!	code		is a (long)word value that determines which value is to
!			be initialized.
!
!  IMPLICIT INPUTS:
!
!	LOWER_TYPE		Datatype of SAVED_LOWERn
!	PAT$TOKEN_CURRENT_PTR	Pointer to current token
!	SAVED_LOWER1		Saved lower bound
!	SAVED_LOWER2		...
!	SAVED_TYPE		Datatype of SAVED_VALUEn
!	SAVED_VALUE1		Saved value
!	SAVED_VALUE2		...
!	UPPER_BOUND		Upper bound
!
!  IMPLICIT OUTPUTS:
!
!	SAVED_LOWER1		Saved lower bound, cleared
!	SAVED_LOWER2		...
!	SAVED_VALUE1		Saved value, cleared
!	SAVED_VALUE2		...
!	UPPER_BOUND		Upper bound
!	VALUE_LIST		Pointer to value list
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE SETUP_VALUE_RANGE (CODE) : NOVALUE =
BEGIN
%BLISS32 (    MAP
	CODE :	LONG;)

    BIND TOKEN = (LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR)): $STR_DESCRIPTOR ();

    LOCAL
	LENGTH %BLISS32 (: WORD),
	SAB_PTR :	REF	crx_stringlist;

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

    LENGTH = diu$s_crx_stringlist;
    $XPO_GET_MEM (FULLWORDS = .LENGTH, RESULT = SAB_PTR, FILL = 0);
    INIT_STRINGLIST (.SAB_PTR);

!   Set binary string flag:

    SAB_PTR [crs$v_binary_string] = TRUE;

!   Upper bound (complex):

    IF .CODE EQLU UPPER_BND AND .SAVED_VALUE1 [STR$H_LENGTH] EQLU 0
	THEN BEGIN
	    LENGTH = .TOKEN [STR$H_LENGTH];
	    SAB_PTR [crs$w_string_length] = .LENGTH;
	    $XPO_GET_MEM (CHARACTERS = .LENGTH,
		RESULT = SAB_PTR [crs$a_string]);
	    CH$MOVE (.LENGTH, .TOKEN [STR$A_POINTER],
		.SAB_PTR [crs$a_string]);
	    UPPER_BOUND = .SAB_PTR;
	    RETURN;
	END;

!   Upper bound (not complex):

    IF .CODE EQLU UPPER_BND
	THEN BEGIN
	    SAB_PTR [crs$w_string_length] = .SAVED_VALUE1 [STR$H_LENGTH];
	    SAB_PTR [crs$a_string] = .SAVED_VALUE1 [STR$A_POINTER];
	    UPPER_BOUND = .SAB_PTR;
	    SAVED_VALUE1 [STR$H_LENGTH] = 0;
	    SAVED_VALUE2 [STR$H_LENGTH] = 0;
	END

!   Lower bound:

    ELSE
	BEGIN
	    SAB_PTR [crs$w_string_length] = .SAVED_LOWER1 [STR$H_LENGTH];
	    SAB_PTR [crs$a_string] = .SAVED_LOWER1 [STR$A_POINTER];
	    VALUE_LIST = .SAB_PTR;
	    SAB_PTR [crs$a_next] = .UPPER_BOUND;
	    UPPER_BOUND = NULL_PTR;
	    SAVED_LOWER1 [STR$H_LENGTH] = 0;
	    SAVED_LOWER2 [STR$H_LENGTH] = 0;
	END;

END;
!++
!  MOVE_STATEMENT (MOVEST)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine creates a transform for a MOVE statement.
!	It is called for MOVE_ST.
!
!  CALLING SEQUENCE:
!
!	STATUS = MOVE_STATEMENT ();
!
!  INPUT PARAMETERS:
!
!	none
!
!  IMPLICIT INPUTS:
!
!	DEST_NAME:		Destination field name
!	DSTRT			Root of destination record description tree
!	SOURCE_NAME:		Source field name
!	SRCRT			Root of source record description tree
!	TRANSFORM_HEAD		Head of transform list
!	TRANSFORM_TAIL		Tail of transform list
!
!  IMPLICIT OUTPUTS:
!
!	TRANSFORM_HEAD		Head of transform list
!	TRANSFORM_TAIL		Tail of transorm list
!
!  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
!
!--
ROUTINE MOVE_STATEMENT =
BEGIN

LOCAL
    source_fqn:		REF crx_stringlist
		INITIAL (NULL_PTR),	! Fully-qualified name of source field
    dest_fqn:		REF crx_stringlist
		INITIAL (NULL_PTR),	! Fully-qualified name of destination
    status,				! Return status
    source_member:	REF crx_member
		INITIAL (NULL_PTR),	! Source field's member block
    dest_member:	REF crx_member
		INITIAL (NULL_PTR),	! Destination field's member block
    source_dim:		REF dims
		INITIAL (NULL_PTR),	! Source field's dimension list
    dest_dim:		REF dims
		INITIAL (NULL_PTR),	! Destination field's dimension list
    new_trans:		REF transform_str
		INITIAL (NULL_PTR);	! New transform

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

status = DEAL_WITH_TRANSFORM_NAMES (source_name, source_fqn, dest_name,
    dest_fqn);
IF NOT .status THEN RETURN .status;

status = FIND_NAMES_IN_TREES (.source_fqn, .srcrt, .dest_fqn, .dstrt,
    source_member, dest_member, source_dim, dest_dim);
IF NOT .status THEN RETURN .status;

IF CHECK_DIMS (.source_dim, .dest_dim)
    THEN RETURN FALSE;			! Dimensions do not match

MAKE_TRANSFORM (.source_fqn, .dest_fqn, .source_member, .dest_member,
    .source_dim, .dest_dim, new_trans);

! Hook in transform:

! NOTE: A MOVE statement will only make one transform node, so there is no
! need to walk the list to find the transform tail.

IF .transform_head EQLA NULL_PTR
    THEN BEGIN				! First transform in list
	transform_head = .new_trans;
	transform_tail = .transform_head;
    END
    ELSE BEGIN				! Add transform to list
	transform_tail [TRA_NEXT] = .new_trans;
	transform_tail = .new_trans;
    END;

RETURN TRUE;

END;
!++
!  MM_STATEMENT (MMST)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine creates transforms for a MOVE MATCHING statement.
!	It is called for MM_ST.
!
!  CALLING SEQUENCE:
!
!	STATUS = MM_STATEMENT ();
!
!  INPUT PARAMETERS:
!
!	None
!
!  IMPLICIT INPUTS:
!
!	DEST_NAME:		Destination field name
!	DSTRT			Root of destination record description tree
!	SOURCE_NAME:		Source field name
!	SRCRT			Root of source record description tree
!	TRANSFORM_HEAD		Head of transform list
!	TRANSFORM_TAIL		Tail of transform list
!
!  IMPLICIT OUTPUTS:
!
!	TRANSFORM_HEAD		Head of transform list
!	TRANSFORM_TAIL		Tail of transform list
!
!  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
!
!--
ROUTINE MM_STATEMENT =
BEGIN

LOCAL
    status,				! Return status
    new_trans:		REF transform_str
		INITIAL (NULL_PTR),	! New transform
    source_fqn:		REF crx_stringlist
		INITIAL (NULL_PTR),	! Fully-qualified name for source field
    dest_fqn:		REF crx_stringlist
		INITIAL (NULL_PTR),	! Fully-qualified name for destination
    source_member:	REF crx_member
		INITIAL (NULL_PTR),	! Source field's member block
    dest_member:	REF crx_member
		INITIAL (NULL_PTR),	! Destination field's member block
    source_dim:		REF dims
		INITIAL (NULL_PTR),	! Source field's dimension list
    dest_dim:		REF dims
		INITIAL (NULL_PTR);	! Destination field's dimension list

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

status = DEAL_WITH_TRANSFORM_NAMES (source_name, source_fqn, dest_name,
    dest_fqn);
IF NOT .status THEN RETURN .status;
status = FIND_NAMES_IN_TREES (.source_fqn, .srcrt, .dest_fqn, .dstrt,
    source_member, dest_member, source_dim, dest_dim);
IF NOT .status THEN RETURN .status;

IF CHECK_DIMS (.source_dim, .dest_dim)
    THEN RETURN FALSE;		! Dimensions do not match

DIU$MOVE_MAT (DIU$K_MOV_MAT, source_member, dest_member, new_trans,
    .source_dim, .dest_dim);

! Hook the result into the transform list:
! NOTE: A MOVE MATCHING may generate several nodes, so the list must be walked
! after the new piece or pieces has/have been added to find the tail.

IF .transform_head EQLA NULL_PTR
    THEN			! First transform(s) in list
	transform_head = .new_trans
    ELSE			! Add transform(s) to end of list
	transform_tail [TRA_NEXT] = .new_trans;

WHILE (.new_trans NEQA NULL_PTR)
    DO BEGIN			! Walk the new part looking for the tail of list
	transform_tail = .new_trans;
	new_trans = .new_trans [TRA_NEXT];
    END;

RETURN TRUE;

END;
!++
!  MOM_STATEMENT (MOMST)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine creates transforms for MOVE OTHERS MATCHING.
!	It is called for MOM_ST.
!
!  CALLING SEQUENCE:
!
!	STATUS = MOM_STATEMENT ();
!
!  INPUT PARAMETERS:
!
!	None
!
!  IMPLICIT INPUTS:
!
!	DEST_NAME		Destination field name, if any
!	DSTRT			Root of destination record description tree
!	PAT$TOKEN_CURRENT_PTR	Current lexical token
!	SOURCE_NAME		Source field name, if any
!	SRCRT			Root of source record description tree
!	TRANSFORM_HEAD		Head of transform list
!	TRANSFORM_TAIL		Tail of transform list
!
!  IMPLICIT OUTPUTS:
!
!	TRANSFORM_HEAD		Head of transform list
!	TRANSFORM_TAIL		Tail of transform list
!
!  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
!
!--
ROUTINE MOM_STATEMENT =
BEGIN

LOCAL
    source_member:	REF crx_member
		INITIAL (NULL_PTR),	! Source member at root, if any
    dest_member:	REF crx_member
		INITIAL (NULL_PTR),	! Destination member at root, if any
    source_fqn:	REF crx_stringlist
		INITIAL (NULL_PTR),	! Source name, if any
    dest_fqn:	REF crx_stringlist
		INITIAL (NULL_PTR),	! Destination name, if any
    source_dim:	REF dims
		INITIAL (NULL_PTR),	! Source dimensions, if any
    dest_dim:	REF dims
		INITIAL (NULL_PTR),	! Destination dimensions, if any
    source,				! Source root
    dest,				! Destination root
    new_trans:	REF transform_str
		INITIAL (NULL_PTR),	! New transform
    status;				! Completion status

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

! Check for explicit source name.

IF .source_name [STR$H_LENGTH] NEQ 0
    THEN BEGIN				! Source name exists
    status = PRODUCE_FQN (source_name, source_fqn);
    IF NOT .status
	THEN BEGIN
	FREE_STRINGLIST (.source_fqn);
	RETURN FALSE;
	END;
    status = VALIDATE_FQN (.source_fqn);
    IF NOT.status
	THEN BEGIN
	FREE_STRINGLIST (.source_fqn);
	RETURN FALSE;
	END;
    status = FIND_MATCHING_MEMBER (.source_fqn, .srcrt, 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;
    source = source_member;
    END					! Explicit source given
    ELSE source = srcrt;		! No explicit source given

! Check for explicit destination name.

IF .dest_name [STR$H_LENGTH] NEQ 0
    THEN BEGIN				! Destination name exists
    status = PRODUCE_FQN (dest_name, dest_fqn);
    IF NOT .status
	THEN BEGIN
	FREE_STRINGLIST (.dest_fqn);
	RETURN FALSE;
	END;
    status = VALIDATE_FQN (.dest_fqn);
    IF NOT.status
	THEN BEGIN
	FREE_STRINGLIST (.dest_fqn);
	RETURN FALSE;
	END;
    status = FIND_MATCHING_MEMBER (.dest_fqn, .dstrt, 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 (.dest_dim);
	FREE_STRINGLIST (.dest_fqn);
	RETURN FALSE;
	END;
    dest = dest_member;
    END					! Explicit destination given
    ELSE dest = dstrt;			! No explicit destination given

 IF CHECK_DIMS (.source_dim, .dest_dim)
    THEN RETURN FALSE;			! Dimensions do not match

! Generate list of transforms.

DIU$MOVE_MAT (DIU$K_MOV_OTHERS, .source, .dest, new_trans,
    .source_dim, .dest_dim);

! Hook the result on the transform list:
! NOTE: A MOVE OTHERS MATCHING may generate several nodes, so the transform
! list must be walked after the new piece or pieces has/have been added to
! find the tail.

IF .transform_head EQLA NULL_PTR
    THEN				! First transform(s) in list
	transform_head = .new_trans
    ELSE				! Add transform(s) to end of list
	transform_tail [TRA_NEXT] = .new_trans;

WHILE (.new_trans NEQA NULL_PTR)
    DO BEGIN				! Walk the new part of the list to end
	transform_tail = .new_trans;
	new_trans = .new_trans [TRA_NEXT];
    END;

RETURN TRUE;

END;
!++
!  DEFINE_TRANSFORM (DEFTRN)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine finishes a completed transform.
!	It is called for TRANSFORM.
!
!  CALLING SEQUENCE:
!
!	DEFINE_TRANSFORM (root);
!
!  INPUT PARAMETERS:
!
!	root		Address where caller wants root of transform list
!			(currently located in TRANSFORM_HEAD)
!
!  IMPLICIT INPUTS:
!
!	TRANSFORM_HEAD	Head of transform list
!
!  IMPLICIT OUTPUTS:
!
!	TRANSFORM_HEAD	Head of transform list, cleared
!	TRANSFORM_TAIL	Tail of transform list, cleared
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
ROUTINE DEFINE_TRANSFORM (root) : NOVALUE =
BEGIN

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

! If there was a transform list already, get rid of it.

IF ..root NEQA NULL_PTR
    THEN DIU$DEL_TRANS_LIST (..root);

! Set transform root where the caller wants it.

.root = .transform_head;

! Clear transform information.

transform_head = NULL_PTR;
transform_tail = NULL_PTR;

RETURN;

END;
!++
!  CLEAR_ATTRIBUTE_FLAGS (CLRATT)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine clears all the attribute-existence flags.
!
!  CALLING SEQUENCE:
!
!	CLEAR_ATTRIBUTE_FLAGS ();
!
!  INPUT PARAMETERS:
!
!	none
!
!  IMPLICIT INPUTS:
!
!	none
!
!  IMPLICIT OUTPUTS:
!
!	ALIGNMENT_FL		Alignment-seen flag, cleared
!	BASE_FL			Base-seen flag, cleared
!	COLUMN_MAJOR_FL		Column-major-array flag, cleared
!	COMPUTE_TYPE		Computational datatype flag, cleared
!	COPY_FL			Copy-seen flag, cleared
!	DATATYPE_FL		Datatype-seen flag, cleared
!	DIGITS_FL		Digits-seen flag, cleared
!	DIMENSION_FL		Dimension-seen flag, cleared
!	INITIAL_FL		Initial-value seen flag, cleared
!	JUSTIFIED_RIGHT_FL	Justified-right-seen flag, cleared
!	LENGTH_FL		Length-seen flag, cleared
!	MAX_DIGITS_FL		Maximum-digits-computed flag, cleared
!	ONE_DIMENSION_FL	One-dimensional-array flag, cleared
!	SCALE_FL		Scale-seen flag, cleared
!	STRING_TYPE		String datatype flag, cleared
!	STRING_TYPE_FL		String-type-seen flag, cleared
!	SYNC_LEFT_FL		Synchronized-left flag, cleared
!	SYNC_RIGHT_FL		Synchronized-right flag, cleared
!	TAG_VALUES_FL		Tag-values-seen flag, cleared
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE CLEAR_ATTRIBUTE_FLAGS: NOVALUE =

BEGIN

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

    ALIGNMENT_FL = FALSE;
    BASE_FL = FALSE;
    COLUMN_MAJOR_FL = FALSE;
    COMPUTE_TYPE = FALSE;
    COPY_FL = FALSE;
    DATATYPE_FL = FALSE;
    DIGITS_FL = FALSE;
    DIMENSION_FL = FALSE;
    INITIAL_FL = FALSE;
    JUSTIFIED_RIGHT_FL = FALSE;
    LENGTH_FL = FALSE;
    MAX_DIGITS_FL = FALSE;
    ONE_DIMENSION_FL = FALSE;
    SCALE_FL = FALSE;
    STRING_TYPE = FALSE;
    STRING_TYPE_FL = FALSE;
    SYNC_LEFT_FL = FALSE;
    SYNC_RIGHT_FL = FALSE;
    TAG_VALUES_FL = FALSE;

END;
!++
!  SET_CHARACTER_TYPE (SETCHR)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine sets the character type of a string item and fixes up its
!	length to reflect the new character type.
!	It is called for TYPE_ASCII_7, TYPE_ASCII_8, TYPE_EBCDIC_8,
!	TYPE_EBCDIC_9, TYPE_SIXBIT.
!
!  CALLING SEQUENCE:
!
!	SET_CHARACTER_TYPE (.code);
!
!  INPUT PARAMETERS:
!
!	code		Value of semantics action code
!
!  IMPLICIT INPUTS:
!
!	DATATYPE		Current datatype
!	FIELD_LEN		Current field length
!	PAT$TOKEN_CURRENT_PTR	Current token
!	STRING_TYPE_FL		String-type-seen flag
!
!  IMPLICIT OUTPUTS:
!
!	DATATYPE		New datatype
!	FIELD_LEN		New field length
!	STRING_TYPE_FL		String-type-seen flag, set
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	none
!
!--
ROUTINE SET_CHARACTER_TYPE (code): NOVALUE =
BEGIN

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

    IF .STRING_TYPE_FL
	THEN BEGIN
	    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		'Multiple character types ignored');
	    RETURN;
	END;

    SELECTONE .DATATYPE OF SET

	[DIU$K_DTYPE_NU]:		! Numeric unsigned
	    SELECTONE .CODE OF SET
		[TYPE_ASCII_7]:		DATATYPE = DIX$K_DT_DN7U;
		[TYPE_ASCII_8]:		DATATYPE = DIX$K_DT_DN8U;
!		[TYPE_ASCII_9]:		?
		[TYPE_EBCDIC_8]:	DATATYPE = DIX$K_DT_EBCDIC_8;
		[TYPE_EBCDIC_9]:	DATATYPE = DIX$K_DT_EBCDIC_9;
		[TYPE_SIXBIT]:		DATATYPE = DIX$K_DT_DN6U;
		TES;

	[DIU$K_DTYPE_NL]:		! Signed left separate
	    SELECTONE .CODE OF SET
		[TYPE_ASCII_7]:		DATATYPE = DIX$K_DT_DN7LS;
		[TYPE_ASCII_8]:		DATATYPE = DIX$K_DT_DN8LS;
!		[TYPE_ASCII_9]:		?
		[TYPE_EBCDIC_8]:	DATATYPE = DIX$K_DT_EBCDIC_8;
		[TYPE_EBCDIC_9]:	DATATYPE = DIX$K_DT_EBCDIC_9;
		[TYPE_SIXBIT]:		DATATYPE = DIX$K_DT_DN6LS;
		TES;

	[DIU$K_DTYPE_NLO]:		! Signed left overpunched
	    SELECTONE .CODE OF SET
		[TYPE_ASCII_7]:		DATATYPE = DIX$K_DT_DN7LO;
		[TYPE_ASCII_8]:		DATATYPE = DIX$K_DT_DN8LO;
!		[TYPE_ASCII_9]:		?
		[TYPE_EBCDIC_8]:	DATATYPE = DIX$K_DT_EBCDIC_8;
		[TYPE_EBCDIC_9]:	DATATYPE = DIX$K_DT_EBCDIC_9;
		[TYPE_SIXBIT]:		DATATYPE = DIX$K_DT_DN6LO;
		TES;

	[DIU$K_DTYPE_NR]:		! Signed right separate
	    SELECTONE .CODE OF SET
		[TYPE_ASCII_7]:		DATATYPE = DIX$K_DT_DN7TS;
		[TYPE_ASCII_8]:		DATATYPE = DIX$K_DT_DN8TS;
!		[TYPE_ASCII_9]:		?
		[TYPE_EBCDIC_8]:	DATATYPE = DIX$K_DT_EBCDIC_8;
		[TYPE_EBCDIC_9]:	DATATYPE = DIX$K_DT_EBCDIC_9;
		[TYPE_SIXBIT]:		DATATYPE = DIX$K_DT_DN6TS;
		TES;

	[DIU$K_DTYPE_NRO]:		! Signed right overpunched
	    SELECTONE .CODE OF SET
		[TYPE_ASCII_7]:		DATATYPE = DIX$K_DT_DN7TO;
		[TYPE_ASCII_8]:		DATATYPE = DIX$K_DT_DN8TO;
!		[TYPE_ASCII_9]:		?
		[TYPE_EBCDIC_8]:	DATATYPE = DIX$K_DT_EBCDIC_8;
		[TYPE_EBCDIC_9]:	DATATYPE = DIX$K_DT_EBCDIC_9;
		[TYPE_SIXBIT]:		DATATYPE = DIX$K_DT_DN6LO;
		TES;

	[DIU$K_DTYPE_P]:		! Packed
	    SELECTONE .CODE OF SET
		[TYPE_ASCII_8]:		DATATYPE = DIX$K_DT_PD8;
		[TYPE_EBCDIC_8]:	DATATYPE = DIX$K_DT_PD8;
		[TYPE_EBCDIC_9]:	DATATYPE = DIX$K_DT_PD9;
		[TYPE_ASCII_7,
		 TYPE_ASCII_9,
		 TYPE_SIXBIT]:
		    BEGIN
		    LSLOCAL_SYNTAX_ERRORM
			(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
			'Character type not valid for PACKED -- ignored');
		    RETURN;
		    END;
		TES;

	[DIU$K_DTYPE_T]:		! Text
	    SELECTONE .CODE OF SET
		[TYPE_ASCII_7]:		DATATYPE = DIX$K_DT_ASCII_7;
		[TYPE_ASCII_8]:		DATATYPE = DIX$K_DT_ASCII_8;
!		[TYPE_ASCII_9]:		?
		[TYPE_EBCDIC_8]:	DATATYPE = DIX$K_DT_EBCDIC_8;
		[TYPE_EBCDIC_9]:	DATATYPE = DIX$K_DT_EBCDIC_9;
		[TYPE_SIXBIT]:		DATATYPE = DIX$K_DT_SIXBIT;
		TES;

!	[DIU$K_DTYPE_VT]:		! Varying text
!	    SELECTONE .CODE OF SET
!		[TYPE_ASCII_7]:		DATATYPE = DIX$K_DT_ASCII_7;
!		[TYPE_ASCII_8]:		DATATYPE = DIX$K_DT_ASCII_8;
!		[TYPE_ASCII_9]:		?
!		[TYPE_EBCDIC_8]:	DATATYPE = DIX$K_DT_EBCDIC_8;
!		[TYPE_EBCDIC_9]:	DATATYPE = DIX$K_DT_EBCDIC_9;
!		[TYPE_SIXBIT]:		DATATYPE = DIX$K_DT_SIXBIT;
!		TES;

	[OTHERWISE]:
	    BEGIN
	    LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
		'Character type not allowed here - ignored');
	    RETURN;
	    END;
	TES;

    SELECTONE .CODE OF SET
	[TYPE_ASCII_7]:		FIELD_LEN = (.FIELD_LEN /
				    DIU$K_S_ASCII) * SIZE_OF (DIX$K_DT_ASCII_7);
	[TYPE_ASCII_8]:		FIELD_LEN = (.FIELD_LEN /
				    DIU$K_S_ASCII) * SIZE_OF (DIX$K_DT_ASCII_8);
!	[TYPE_ASCII_9]:		FIELD_LEN = (.FIELD_LEN /
!				    DIU$K_S_ASCII) * SIZE_OF (DIX$K_DT_ASCII_9);
	[TYPE_EBCDIC_8]:	FIELD_LEN = (.FIELD_LEN /
				    DIU$K_S_ASCII) *
				    SIZE_OF (DIX$K_DT_EBCDIC_8);
	[TYPE_EBCDIC_9]:	FIELD_LEN = (.FIELD_LEN /
				    DIU$K_S_ASCII) *
				    SIZE_OF (DIX$K_DT_EBCDIC_9);
	[TYPE_SIXBIT]:		FIELD_LEN = (.FIELD_LEN /
				    DIU$K_S_ASCII) * SIZE_OF (DIX$K_DT_SIXBIT);
    TES;

END;

END
ELUDOM