Google
 

Trailing-Edge - PDP-10 Archives - bb-h138f-bm - 7-sources/diuau2.bli
There are 4 other files named diuau2.bli in the archive. Click here to see a list.
MODULE DIUAU2 (%require ('DIUPATSWITCH')
			IDENT = '253') =
BEGIN

!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1986.
!	ALL RIGHTS RESERVED.
!
!	THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY  BE  USED  AND
!	COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
!	THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE.   THIS  SOFTWARE  OR
!	ANY  OTHER  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
!	AVAILABLE TO ANY OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE
!	SOFTWARE IS HEREBY TRANSFERRED.
!
!	THE INFORMATION IN THIS SOFTWARE IS  SUBJECT  TO  CHANGE  WITHOUT
!	NOTICE  AND  SHOULD  NOT  BE CONSTRUED AS A COMMITMENT BY DIGITAL
!	EQUIPMENT CORPORATION.
!
!	DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF
!	ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.

!++
!
!  TITLE:  ACTUT2 			More DDL and Transform Action Utilities
!
!  FACILITY:  DIU
!
!  ABSTRACT:
!
!	This module contains utility routines which use the parser action
!	routines in ACTION.BLI and the utility routines in ACTUTL.BLI.
!
!  ENVIRONMENT:
!
!	These routines are written in compatible Bliss.
!	These routines are probably NOT AST reentrant on the VAX.
!
!  AUTHOR:  Charlotte Richardson,	28-May-85
! MODIFICATION HISTORY:
!
!  253  Rename file to DIUAU2.
!       Gregory A. Scott 1-Jul-86
!
!  236  Change library of DIXLIB to DIUDIX.
!       Sandy Clemens  19-Jun-86
!
!  174  Change library of TOPS20 to use MONSYM and JSYSDEF, use  JSYS_DFIN  and
!       JSYS_FLIN.
!       Gregory A. Scott 20-May-86
!
!  166  Modify initial value processing so that it always sets up default
!       initial values for fields which have not had anything moved into them
!       (either explicitly with a MOVE statement or with a MOVE-MATCHING or
!       MOVE-OTHERS-MATCHING statement and for which the user did not already
!       set up an initial value.  Set up the default initial value based on the
!       datatype of the field.  Note: initial value defaults are NOT set up for
!       structures or overlays.
!       Sandy Clemens 19-May-86
!
!   67	Fix problem with initial values (address of initial value buffer
!	was being passed to DIX incorrectly).
!	Sandy Clemens  18-Feb-86
!
!      40       Put the REQUIRE/LIBRARY of 'TOPS20' into a TOPS-20 only
!               conditional.
!               Sandy Clemens  7-Oct-85
!
!	3       Change REQUIRE 'TOPS20' to LIBRARY 'TOPS20' to
!               avoid insufficient dynamic memory when compiling.
!               Sandy Clemens	30-Sep-85
!
!	2	Incorporate Doug Rayner's change for FLIN/DFIn on TOPS10.
!		Charlotte Richardson	19-Aug-85
!
!	1	Account for complex numbers in DIL
!		Charlotte Richardson	12-July-85
!
!--
! INCLUDE FILES:

    LIBRARY 'BLI:XPORT';		! Transportable data structures
    LIBRARY 'DIUACTION';                ! Structures unique to semantic actions
    LIBRARY 'DIUPATDATA';               ! Names of lexical tokens
    LIBRARY 'DIUDIX';			! Define data conversion codes
%IF %BLISS (BLISS32) %THEN
    UNDECLARE %QUOTE $DESCRIPTOR;	! Clean up after XPORT
%FI
    LIBRARY 'DIUCRX';			! CRX record structures
%IF %BLISS (BLISS32) %THEN
    UNDECLARE %QUOTE $DESCRIPTOR;	! Yet again...
%FI
    LIBRARY 'DIUTLB';			! Transform data structures
    LIBRARY 'DIUMLB';                   ! DIU$K_DT_STRUCTURE, DIU$K_DT_OVERLAY 
%IF %BLISS (BLISS32) %THEN
    UNDECLARE %QUOTE $DESCRIPTOR;	! Clean up after XPORT
%FI
%IF %BLISS (BLISS32) %THEN
    UNDECLARE %QUOTE $DESCRIPTOR;	! Clean up after XPORT
    LIBRARY 'SYS$LIBRARY:STARLET';
%ELSE
    %IF %SWITCHES (TOPS20) %THEN
    LIBRARY 'MONSYM';                   ! TOPS-20 monitor symbols
    REQUIRE 'JSYSDEF';			! JSYS definitions
    %FI
%FI
! TABLE OF CONTENTS:

FORWARD ROUTINE

DIU$INITIAL_VALUE: NOVALUE,	! Fix initial values
INITIAL_VALUE_WALKER: NOVALUE,	! Internal routine called by DIU$INITIAL_VALUE
DIU$TAG_FIELD: NOVALUE,		! Fix up tag values
TAG_FIELD_WALKER: NOVALUE;	! Internal routine called by DIU$TAG_FIELD

LITERAL true = 1,
        false = 0;
! External routines:

%IF %BLISS(BLISS36) %THEN %IF %SWITCHES(TOPS10) %THEN

EXTERNAL ROUTINE
    dfin,
    flin;

%FI
%FI

EXTERNAL ROUTINE

DIX$$CON_GEN,			! Convert using two FFDs (DIL routine)
%IF %BLISS (BLISS32) %THEN
OTS$CVT_T_H,			! Convert ASCII to H-floating (VMS only)
%FI
DIU$DEL_TRANS_NODE: NOVALUE,	! Delete transform node
DIX$$DES_BY_DET,		! Make an FFD
DIU$FIND_FIELD,			! Find a field's member block
FREE_STRINGLIST: NOVALUE,	! Free a CRX_STRINGLIST node
INIT_STRINGLIST: NOVALUE,	! Initialize a CRX_STRINGLIST node
MAKE_DIMS: NOVALUE,		! Make a dims node
MAKE_TRANSFORM: NOVALUE;	! Make a transform node
!++
!  DIU$INITIAL_VALUE  (INTVAL)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine will replace the existing initial values pointed to by the
!	crx_member blocks with ones of the correct datatypes and add additional
!	transform nodes to the end of the existing transform list to cause the
!	initial values to be inserted into each destination record during
!	transform processing.  This routine is expected to be called during
!	transform loading.
!
!  CALLING SEQUENCE:
!
!	DIU$INITIAL_VALUE (rec, transform_list, sys_org, dest_buffer);
!
!  PARAMETERS:
!
!	rec			Address of the crx_record block at the head
!				of the destination record description tree.
!	transform_list		The root address of the existing loaded
!				transform list.
!	sys_org			This value should be SYS_LCG, SYS_8BIT, or
!				SYS_PRO (which behaves like SYS_8BIT here)
!				and is the system of origin for the destination
!				record.
!	dest_buffer		This is the address of the destination record
!				description buffer and is used to make the
!				destination FFD in a transform node.
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!--
GLOBAL ROUTINE DIU$INITIAL_VALUE (rec, transform_list, sys_org,
    dest_buffer): NOVALUE =
BEGIN
MAP
    rec:		REF crx_record,		! root of destination tree
    transform_list:	REF transform_str;	! transform list

INITIAL_VALUE_WALKER (.rec, .transform_list, .sys_org, .dest_buffer, 0);

END;
!++
!  INITIAL_VALUE_WALKER  (INTVLW)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine does the work for DIU$INITIAL_VALUE recursively.
!
!  CALLING SEQUENCE:
!
!	INITIAL_VALUE_WALKER (rec, transform_list, sys_org, dest_buffer,
!	    depth);
!
!  PARAMETERS:
!
!	rec			Address of the crx_record or crx_member block
!				at the root of the destination record
!				description tree or subtree.
!	transform_list		The root address of the existing loaded
!				transform list.
!	sys_org			This value should be SYS_LCG, SYS_8BIT, or
!				SYS_PRO (which behaves like SYS_8BIT here)
!				and is the system of origin for the destination
!				record.
!	dest_buffer		This is the address of the destination record
!				description buffer and is used to make the
!				destination FFD in a transform node.
!	depth			The recursion depth in this routine, used to
!				control iteration on the siblings of a node.
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!--
ROUTINE INITIAL_VALUE_WALKER (rec, transform_list, sys_org, dest_buffer,
    depth): NOVALUE =
BEGIN

MAP
    rec:		REF crx_record,		! root of destination tree
    transform_list:	REF transform_str;	! root of transform list

IF .rec EQLA NULL_PTR
    THEN RETURN;			! Nothing to do here

SELECTONE .rec [CRX$B_ID] OF
SET

! Recursively process initial values in the crx_member nodes:

! For record nodes, just recurse.

! For member nodes, iterate on the siblings at this level and recurse on the
! children.  See explanation of initial value processing of a member node,
! below.

! For overlay nodes, iterate on the siblings at this level, and recurse on the
! children.

! For other nodes, just return.  No other node types are expected to be found.


[CRX$K_RECORD]:				! CRX_RECORD node
    INITIAL_VALUE_WALKER (.rec [CRX$A_ROOT], .transform_list, .sys_org,
	.dest_buffer, .depth+1);
[CRX$K_MEMBER]:				! CRX_MEMBER node
    BEGIN
    LOCAL
	a_member:	REF crx_member,		! A crx_member node
	bytsiz,					! Bytesize of new initial value
	c_member:	REF crx_member,		! Current member for fqn/dims
	dims_head:	REF dims,		! Head of dims list
	dst_ffd:	forgn_descr,		! Destination FFD
	dt:		data_type_sep,		! Datatype of new initial value
	fqn_head:	REF crx_stringlist,	! Head of fqn list
	fullword_flag,				! Initial value is fullwords
	last_trans:	REF transform_str,	! Last existing transform node
	length,					! DIL length of initial value
	n_initial_length,			! Length of new initial value
	n_initial_value,			! Pointer to new initial value
	n_useable_fw_flag,			! Fullword "useable" value flag
	n_useable_length,			! Length of "useable" value
	n_useable_value,			! Pointer to "useable" value
	new_dims:	REF dims,		! New dims node in dims list
	new_fqn:	REF crx_stringlist,	! New fqn node in fqn list
	new_trans:	REF transform_str,	! New transform node
	p_member:	REF crx_member,		! Parent of c_member
	src_ffd:	forgn_descr,		! Source FFD
	status,					! Returned status
	this_sys: INITIAL ( %BLISS32 (SYS_8BIT) %BLISS36 (SYS_LCG) );

    EXTERNAL
	dix$adtt_st:	dtt_st,		! String datatypes
	dix$adtt_fbin:	dtt_fbin,	! Fixed-binary datatypes
	dix$adtt_fp:	dtt_fp,		! Floating-point datatypes
	dix$adtt_dn:	dtt_dn,		! Display-numeric datatypes
	dix$adtt_pd:	dtt_pd;		! Packed-decimal datatypes

    LABEL
	l_siblings;			! Block to iterate on member siblings
! Initial value processing of a member node:

! A lot of work is involved here, but it is pretty straightforward.  The
! sequence of events, for each member node sibling at this level in the
! record description tree, is:

! 1.  If the node has children, recurse to process them.

! 2.  If there is no initial value, or if the field is used (some field gets
!     moved into it by a transform), or if the initial value's datatype cannot
!     be determined (which would be due to a bug; transform loading stores the
!     initial value's datatype in the additional block for member nodes coming
!     from CRX when datatype mapping is done, and the parser stores the initial
!     value's token type for nodes not coming from CRX), no initial value will
!     be processed for this sibling.

! 3.  A new transform node for the initial value is created and hooked on to the
!     end of the transform list.  It will be deleted later if the initial
!     value cannot be created.

! 4.  The existing initial value is converted to one of the right datatype for
!     the member block (whose datatype has been mapped by transform loading).
!     If the value came from our parser, it is in ASCII and must be converted to
!     a "useful" datatype first.  Then, in both cases (node came from CRX or
!     node processed by our parser), the value must be converted to the right
!     datatype using DIL (DIX$$CON_GEN).

! 5.  The old initial value is deleted, and the new one put in its place.

! 6.  The FFDs in the initial value transform node are made and stored.

! 7.  The dims and fqn of the member block are computed and stored in the
!     destination side of the initial value transform node.  Since the
!     transform's opcode field is set to indicate that this is an initial value,
!     no source information is expected here.
    a_member = .rec;			! Get field addressability via REF

    DO BEGIN                            ! Iterate on CRX_MEMBER siblings

l_siblings:

        BEGIN
	LOCAL
	    a_facility:	REF crx_additional,	! Current facility block
	    bytes_per_word,			! Used to compute size of DIX
	    data_word_size,			! ... storage for converted
	    total_words;			! ... initial values

	a_facility = .a_member [CRM$A_FACILITY];

	! Compute word size of system of origin for our data:
	IF .sys_org EQL SYS_LCG
        THEN data_word_size = 36        ! 10 or 20 data
        ELSE data_word_size = 32;       ! VAX (or fake it for PRO) data

	! Recurse on node's children, if any:
	IF .a_member [CRM$A_CHILDREN] NEQA NULL_PTR
        THEN INITIAL_VALUE_WALKER (.a_member [CRM$A_CHILDREN],
                                   .transform_list, .sys_org,
                                   .dest_buffer, .depth+1);

	! Determine whether we need to process an initial value here:
	IF (.a_member [CRM$A_FACILITY] EQLA NULL_PTR)
        THEN LEAVE l_siblings;          ! This should not occur

        ! If the field hasn't been used yet then if the initial value isn't
        ! set, then set up the default initial value based on the datatype of
        ! the field.  Note:  initial value defaults are NOT set up for
        ! structures or overlays...
        IF (.a_member[CRM$W_INITIAL_LENGTH] EQL 0       ! no current init value
           AND NOT .a_member[CRM$V_FACILITY_USE_2]      ! fld not already moved
           AND .a_member[CRM$W_DATATYPE] NEQ DIU$K_DT_OVERLAY   ! not overlay
           AND .a_member[CRM$W_DATATYPE] NEQ DIU$K_DT_STRUCTURE)  ! not strct
        THEN BEGIN
             LOCAL addr : INITIAL(0);
             dt = .a_member [CRM$W_DATATYPE];
             SELECTONE .dt[DT_CLASS_SEP] OF
             SET
             [dt_string] :
                 BEGIN
                 !
                 ! Set the initial value's length field to the number of string
                 ! units of the member field.  Set the initial type to quoted
                 ! string since that's what our parser does for string initial
                 ! values.  Create a field filled with spaces for the initial
                 ! value and save its address in the member node.
                 !
                 a_member[CRM$W_INITIAL_LENGTH]= .a_member[CRM$L_STRING_UNITS];
                 a_facility[CRA$L_INITIAL_TYPE] = T_QUOTED_STRING;
                 $XPO_GET_MEM(CHARACTERS = .a_member[CRM$W_INITIAL_LENGTH],
                              FILL = %O'40',    ! fill with spaces
                              RESULT = addr);
                 a_member[CRM$A_INITIAL_VALUE] = .addr;
                 END;

             [dt_dnum, dt_pdec] :
                 BEGIN
                 !
                 ! Set the initial value's length field to the number of digits
                 ! in the member field.  Set the initial type to unsigned
                 ! integer.  Create a field filled with zero characters and
                 ! save its address in the member node.
                 !
                 a_member[CRM$W_INITIAL_LENGTH] = .a_member[CRM$W_DIGITS];
                 a_facility[CRA$L_INITIAL_TYPE] = T_UNSIGNED_INTEGER;
                 $XPO_GET_MEM(CHARACTERS = .a_member[CRM$W_INITIAL_LENGTH],
                              FILL = %O'60',    ! fill with zero chars "0"
                              RESULT = addr);
                 a_member[CRM$A_INITIAL_VALUE] = .addr;
                 END;

             [dt_fbin] :
                 !
                 ! Set the initial value's length field to 1 and the initial
                 ! type to unsigned integer.  Create a one character field
                 ! filled with a zero character and save its address in the
                 ! member node.
                 !
                 BEGIN
                 a_member[CRM$W_INITIAL_LENGTH] = 1;
                 a_facility[CRA$L_INITIAL_TYPE] = T_UNSIGNED_INTEGER;
                 $XPO_GET_MEM(CHARACTERS = .a_member[CRM$W_INITIAL_LENGTH],
                              FILL = %O'60',    ! fill with zero chars "0"
                              RESULT = addr);
                 a_member[CRM$A_INITIAL_VALUE] = .addr;
                 END;

             [dt_fp] :
                 BEGIN
                 !
                 ! First check to see if the datatype is a complex floating
                 ! point datatype:
                 !
                 IF .dix$adtt_fp[.dt[DT_CODE_SEP], fpd$v_typ] EQL fpd$k_complex
                 THEN BEGIN
                      !
                      ! If the datatype is complex, then set the initial
                      ! value's length field to 3 and set the initial type to
                      ! nt_complex.  Create a field filled with "0 0", since
                      ! that is what our parser does for complex initial
                      ! values, and save its address in the member node.  Set
                      ! the "real" portion initial type and the "imaginary"
                      ! portion initial type to unsigned integer, and the
                      ! "real" portions length to 1.  This is to be consistent
                      ! with what our parser does.
                      !
                      a_facility[CRA$L_INITIAL_TYPE] = NT_COMPLEX_NUMBER;
                      a_member[CRM$W_INITIAL_LENGTH] = 3;
                      a_facility[CRA$L_INITIAL_TYPE_1] = T_UNSIGNED_INTEGER;
                      a_facility[CRA$L_INITIAL_TYPE_2] = T_UNSIGNED_INTEGER;
                      a_facility[CRA$L_INITIAL_LENGTH_1] = 1;
                      $XPO_GET_MEM(CHARACTERS = 3,
                                   FILL = 0,
                                   RESULT = addr);
                      $STR_COPY(STRING = '0 0',
                                TARGET = (3, addr));
                      a_member[CRM$A_INITIAL_VALUE] = .addr;
                      END
                 ELSE BEGIN
                      !
                      ! Set the initial value's length field to 1 and set the
                      ! initial type to unsigned integer.  Create a field
                      ! filled with a zero character for the initial value and
                      ! save its address in the member node.
                      !
                      a_facility[CRA$L_INITIAL_TYPE] = T_UNSIGNED_INTEGER;
                      a_member[CRM$W_INITIAL_LENGTH] = 1;
                      $XPO_GET_MEM(CHARACTERS = 1,
                                   FILL = %O'60',       ! fill with "0" chars
                                   RESULT = addr);
                      a_member[CRM$A_INITIAL_VALUE] = .addr;
                      END;
                 END;
             TES;
             .a_member [CRM$V_FACILITY_USE_2] = 1;
             END
        ELSE ! Determine whether we need to process an initial value here:
             BEGIN
             IF .a_member [CRM$V_FACILITY_USE_2]
             THEN LEAVE l_siblings;	! This field is used anyway
             IF .a_member [CRM$W_INITIAL_LENGTH] EQL 0
             THEN LEAVE l_siblings;	! This field is used anyway
             END;

	! Resign ourselves to processing an initial value.
	! Make new transform node and hook it in:
	MAKE_TRANSFORM (0, 0, 0, 0, 0, 0, new_trans);
	! Flag transform as an initial value:
	new_trans [TRA_OPCODE] = DIU$K_INITIAL;
	last_trans = .transform_list;
	UNTIL (.last_trans [TRA_NEXT] EQLA NULL_PTR) DO
	    last_trans = .last_trans [TRA_NEXT];
	last_trans [TRA_NEXT] = .new_trans;

	! Set status to indicate initial value is useable:
	status = TRUE;
! Convert initial values produced by CRX to the correct datatype.

	! Get the initial value into the right datatype for the transform node
	IF (.this_sys EQL SYS_8BIT) AND .a_facility [CRA$V_SRC_CRX]
	    THEN BEGIN			! Initial value came from CRX
		! Figure out length and bytesize of new initial value,
		! based on datatype and length:
		dt = .a_member [CRM$W_DATATYPE];
		SELECTONE .dt [DT_CLASS_SEP] OF SET

		[DT_STRING, DT_DNUM]:	! String datatypes
		    BEGIN		!  and display-numeric datatypes
		    length = .a_member [CRM$L_STRING_UNITS];
		    IF .dt [DT_CLASS_SEP] EQL DT_STRING
			THEN bytsiz = .dix$adtt_st [.dt [DT_CODE_SEP],
			    STD$V_BYT_SIZ]	! Bytsize of a string
			ELSE bytsiz = .dix$adtt_dn [.dt [Dt_CODE_SEP],
			    DND$V_BYT_SIZ];	! Bytesize of display-numeric
		    IF ((.this_sys EQL SYS_8BIT) AND (.bytsiz EQL 8)) OR
			((.this_sys EQL SYS_LCG) AND (.bytsiz EQL 7))
			THEN BEGIN	! Character storage
			    fullword_flag = FALSE;
			    n_initial_length = .a_member [CRM$L_STRING_UNITS];
			END		! Character storage
			ELSE BEGIN	! Word storage
			    fullword_flag = TRUE;
			    bytes_per_word = .data_word_size / .bytsiz;
			    total_words = .a_member [CRM$L_STRING_UNITS]
				/ .bytes_per_word;
			    IF .a_member [CRM$L_STRING_UNITS]
				MOD .bytes_per_word NEQ 0
				THEN total_words = .total_words + 1;
			    n_initial_length = (.total_words * .data_word_size)
				/ %BPVAL;
			    IF (.total_words * .data_word_size) MOD %BPVAL
				NEQ 0
				THEN n_initial_length = .n_initial_length + 1;
			END;		! Word storage
		    END;

		[DT_PDEC]:		! Packed-decimal datatypes
		    BEGIN
		    length = .a_member [CRM$W_DIGITS];
		    bytsiz = .dix$adtt_pd [.dt [DT_CODE_SEP], PDD$V_BYT_SIZ];
		    IF ((.this_sys EQL SYS_8BIT) AND (.bytsiz EQL 8)) OR
			((.this_sys EQL SYS_LCG) AND (.bytsiz EQL 7))
			THEN BEGIN	! Character storage
			    fullword_flag = FALSE;
			    n_initial_length = .a_member [CRM$L_STRING_UNITS];
			END		! Character storage
			ELSE BEGIN	! Word storage
			    fullword_flag = TRUE;
			    bytes_per_word = .data_word_size / .bytsiz;
			    total_words = .a_member [CRM$L_STRING_UNITS]
				/ .bytes_per_word;
			    IF .a_member [CRM$L_STRING_UNITS] MOD .bytes_per_word
				NEQ 0
				THEN total_words = .total_words + 1;
			    n_initial_length = (.total_words * .data_word_size)
				/ %BPVAL;
			    IF (.total_words * .data_word_size) MOD %BPVAL
				NEQ 0
				THEN n_initial_length = .n_initial_length + 1;
			END;		! Word storage
		    END;

		[DT_FBIN]:		! Fixed-binary datatypes
		    BEGIN
		    length = 0;
		    bytsiz = .dix$adtt_fbin [.dt [DT_CODE_SEP], FBD$V_SIZ];
		    n_initial_length = (.bytsiz + %BPVAL-1) / %BPVAL;
		    fullword_flag = TRUE;
		    END;

		[DT_FP]:		! Floating-point datatypes
		    BEGIN
		    length = 0;
		    bytsiz = .dix$adtt_fp [.dt [DT_CODE_SEP], FPD$V_SIZ];
		    n_initial_length = (.bytsiz + %BPVAL-1) / %BPVAL;
		    ![1] Account for the bytesize of a complex number.
		    IF .dix$adtt_fp [.dt [DT_CODE_SEP], fpd$v_typ]
			EQL fpd$k_complex
			THEN n_initial_length = ((2*.bytsiz) + %bpval-1) /
			    %BPVAL;
		    fullword_flag = TRUE;
		    END;

		TES;
! Convert initial values coming from CRX:

		! Create an area to store it in:
		IF .fullword_flag
		    THEN $XPO_GET_MEM (FULLWORDS = .n_initial_length,
			RESULT = n_initial_value, FILL = 0)
		    ELSE $XPO_GET_MEM (CHARACTERS = .n_initial_length,
			RESULT = n_initial_value, FILL = 0);

		! Make an FFD to the original value:
		status = DIX$$DES_BY_DET (src_ffd,
		    .a_member [CRM$A_INITIAL_VALUE], SYS_8BIT, 1, 0, 0,
		    .a_facility [CRA$L_INITIAL_TYPE], .length,
		    .a_member [CRM$W_SCALE]);

		! Make an FFD to the new value:
		IF .status THEN
		IF .sys_org EQL SYS_8BIT OR .sys_org EQL SYS_PRO
		    THEN status = DIX$$DES_BY_DET (dst_ffd, .n_initial_value,
			SYS_8BIT, 1, 0, 0, .a_member [CRM$W_DATATYPE],
			.length, .a_member [CRM$W_SCALE])
		    ELSE status = DIX$$DES_BY_DET (dst_ffd,
			address_of_byte (.n_initial_value),
			SYS_LCG, 1, (0 + .bytsiz - 1), 0,
			.a_member [CRM$W_DATATYPE], .length,
			.a_member [CRM$W_SCALE]);

		! Do the conversion:
		IF .status THEN
		status = DIX$$CON_GEN (src_ffd, dst_ffd);
		! If this fails, this initial value is not useable
	    END				! Initial value came from CRX
! Convert initial values produced by our parser to the correct datatype.

	    ELSE BEGIN			! Initial value came from our parser
		! Figure out length of current initial value after conversion
		! from ASCII, based on datatype and length, create a place
		! to store it, and convert current initial value from ASCII
		! to something useable.
		! Then, figure out length of new initial value, based on
		! datatype and length, and make an FFD to it:

		dt = .a_member [CRM$W_DATATYPE];
		SELECTONE .dt [DT_CLASS_SEP] OF SET

		[DT_STRING]:		! String datatypes
		    BEGIN
		    ! Initial value must be a quoted string.
		    n_useable_length = .a_member [CRM$W_INITIAL_LENGTH];
		    $XPO_GET_MEM (CHARACTERS = .n_useable_length, FILL=0,
			RESULT = n_useable_value);
		    IF .a_facility [CRA$L_INITIAL_TYPE] NEQ T_QUOTED_STRING
			THEN status = FALSE
			ELSE BEGIN	! A quoted string
			$STR_COPY (STRING = (.n_useable_length,
			    .a_member [CRM$A_INITIAL_VALUE]),
			    TARGET = (.n_useable_length,
			    .n_useable_value));
			IF .this_sys EQL SYS_8BIT
			    THEN status = DIX$$DES_BY_DET (src_ffd,
				.n_useable_value, SYS_8BIT, 1, 0, 0,
			 	DIX$K_DT_ASCII_8, .n_useable_length, 0)
			    ELSE status = DIX$$DES_BY_DET (src_ffd,
				address_of_byte (.n_useable_value),
				SYS_LCG, 1, (0 + 7 - 1), 0,
				DIX$K_DT_ASCII_7, .n_useable_length, 0);
			END;		! A quoted string
		    n_useable_fw_flag = FALSE;
		    length = .a_member [CRM$L_STRING_UNITS];
		    bytsiz = .dix$adtt_st [.dt [DT_CODE_SEP], STD$V_BYT_SIZ];
		    IF ((.this_sys EQL SYS_8BIT) AND (.bytsiz EQL 8)) OR
			((.this_sys EQL SYS_LCG) AND (.bytsiz EQL 7))
			THEN BEGIN	! Character storage
			    fullword_flag = FALSE;
			    n_initial_length = .a_member [CRM$L_STRING_UNITS];
			END		! Character storage
			ELSE BEGIN	! Word storage
			    fullword_flag = TRUE;
			    bytes_per_word = .data_word_size / .bytsiz;
			    total_words = .a_member [CRM$L_STRING_UNITS]
				/ .bytes_per_word;
			    IF .a_member [CRM$L_STRING_UNITS]
				MOD .bytes_per_word NEQ 0
				THEN total_words = .total_words + 1;
			    n_initial_length = (.total_words * .data_word_size)
				/ %BPVAL;
			    IF (.total_words * .data_word_size) MOD %BPVAL
				NEQ 0
				THEN n_initial_length = .n_initial_length + 1;
			END;		! Word storage
		    END;
		[DT_DNUM, DT_PDEC]:		! Display-numeric datatypes
		    BEGIN			! Packed-decimal datatypes
		    LOCAL
			signed_flag,		! Useable value signed
			useable_datatype,	! Datatype of useable value
			useable_temporary;	! Used to create this
		    ! Acceptable initial values: signed or unsigned integers,
		    ! octal numbers, and hex numbers.
		    n_useable_length = .a_member [CRM$W_DIGITS] + 1;
		    n_useable_fw_flag = FALSE;
		    $XPO_GET_MEM (CHARACTERS = .n_useable_length,
			FILL = 0, RESULT = n_useable_value);
		    SELECTONE .a_facility [CRA$L_INITIAL_TYPE] OF SET
		    [T_UNSIGNED_INTEGER, T_SIGNED_INTEGER]:
			$STR_BINARY (STRING = (.a_member [CRM$W_INITIAL_LENGTH],
			    .a_member [CRM$A_INITIAL_VALUE]),
			    RESULT = useable_temporary);
		    [T_OCTAL_NUMBER]:
			$STR_BINARY (STRING = (.a_member [CRM$W_INITIAL_LENGTH],
			    .a_member [CRM$A_INITIAL_VALUE]),
			    RESULT = useable_temporary, OPTION = BASE8);
		    [T_HEX_NUMBER]:
			$STR_BINARY (STRING = (.a_member [CRM$W_INITIAL_LENGTH],
			    .a_member [CRM$A_INITIAL_VALUE]),
			    RESULT = useable_temporary, OPTION = BASE16);
		    [OTHERWISE]:
			status = FALSE;
		    TES;

		    IF .status THEN BEGIN
			$STR_COPY (STRING = $STR_ASCII (.useable_temporary,
			    LENGTH = .n_useable_length),
			    TARGET = (.n_useable_length, .n_useable_value));
			IF .useable_temporary LSS 0
			    THEN signed_flag = TRUE
			    ELSE signed_flag = FALSE;
			END;
		    IF .this_sys EQL SYS_8BIT
			THEN IF .signed_flag
			    THEN useable_datatype = DIX$K_DT_DN8LS
			    ELSE useable_datatype = DIX$K_DT_DN8U
			ELSE IF .signed_flag
			    THEN useable_datatype = DIX$K_DT_DN7LS
			    ELSE useable_datatype = DIX$K_DT_DN7U;
		    IF .status THEN
		    IF .this_sys EQL SYS_8BIT
			THEN status = DIX$$DES_BY_DET (src_ffd,
			    .n_useable_value, SYS_8BIT, 1, 0, 0,
			    .useable_datatype, .n_useable_length, 0)
			ELSE status = DIX$$DES_BY_DET (src_ffd,
			    address_of_byte (.n_useable_value),
			    SYS_LCG, 1, (0 + 7 - 1), 0,
			    .useable_datatype, .n_useable_length, 0);
		    IF .dt [DT_CLASS_SEP] EQL DT_DNUM
			THEN BEGIN	! Display numeric
			length = .a_member [CRM$L_STRING_UNITS];
			bytsiz = .dix$adtt_dn [.dt [DT_CODE_SEP],
			    DND$V_BYT_SIZ];
			END		! Display numeric
			ELSE BEGIN	! Packed decimal
			    length = .a_member [CRM$W_DIGITS];
			    bytsiz = .dix$adtt_pd [.dt [DT_CODE_SEP],
				PDD$V_BYT_SIZ];
			END;		! Packed decimal
		    IF ((.this_sys EQL SYS_8BIT) AND (.bytsiz EQL 8)) OR
			((.this_sys EQL SYS_LCG) AND (.bytsiz EQL 7))
			THEN BEGIN	! Character storage
			    fullword_flag = FALSE;
			    n_initial_length = .a_member [CRM$L_STRING_UNITS];
			END		! Character storage
			ELSE BEGIN	! Word storage
			    fullword_flag = TRUE;
			    bytes_per_word = .data_word_size / .bytsiz;
			    total_words = .a_member [CRM$L_STRING_UNITS]
				/ .bytes_per_word;
			    IF .a_member [CRM$L_STRING_UNITS]
				MOD .bytes_per_word NEQ 0
				THEN total_words = .total_words + 1;
			    n_initial_length = (.total_words * .data_word_size)
				/ %BPVAL;
			    IF (.total_words * .data_word_size) MOD %BPVAL
				NEQ 0
				THEN n_initial_length = .n_initial_length + 1;
			END;		! Word storage
		    END;		! Display-numeric and packed decimal
		[DT_FBIN]:		! Fixed-binary datatypes
		    BEGIN
		    ! Acceptable initial values: signed or unsigned integers,
		    ! octal numbers, and hex numbers.
		    LOCAL
			temp_dt: INITIAL (DIX$K_DT_SBF36) data_type_sep;
		    n_useable_length = 1;	! Fullwords
		    n_useable_fw_flag = TRUE;
		    $XPO_GET_MEM (FULLWORDS = 1, RESULT = n_useable_value,
			FILL = 0);
		    SELECTONE .a_facility [CRA$L_INITIAL_TYPE] OF SET
		    [T_UNSIGNED_INTEGER, T_SIGNED_INTEGER]:
			$STR_BINARY (STRING = (.a_member [CRM$W_INITIAL_LENGTH],
			    .a_member [CRM$A_INITIAL_VALUE]),
			    RESULT = .n_useable_value);
		    [T_OCTAL_NUMBER]:
			$STR_BINARY (STRING = (.a_member [CRM$W_INITIAL_LENGTH],
			    .a_member [CRM$A_INITIAL_VALUE]),
			    RESULT = .n_useable_value, OPTION = BASE8);
		    [T_HEX_NUMBER]:
			$STR_BINARY (STRING = (.a_member [CRM$W_INITIAL_LENGTH],
			    .a_member [CRM$A_INITIAL_VALUE]),
			    RESULT = .n_useable_value, OPTION = BASE16);
		    [OTHERWISE]:
			status = FALSE;
		    TES;
		    IF .status THEN
		    IF .this_sys EQL SYS_8BIT
			THEN status = DIX$$DES_BY_DET (src_ffd,
			    .n_useable_value, SYS_8BIT, 1, 0, 0, DIX$K_DT_SBF32,
			    0, 0)
			ELSE status = DiX$$DES_BY_DET (src_ffd,
			    address_of_byte (.n_useable_value),
			    SYS_LCG, 1, (0 +
			     .dix$adtt_fbin [.temp_dt [DT_CODE_SEP], fbd$v_siz]
			     - 1), 0, DIX$K_DT_SBF36, 0, 0);
		    length = 0;
		    bytsiz = .dix$adtt_fbin [.dt [DT_CODE_SEP], FBD$V_SIZ];
		    n_initial_length = (.bytsiz + %BPVAL-1) / %BPVAL;
		    fullword_flag = TRUE;
		    END;		! Fixed-binary datatypes
		[DT_FP]:		! Floating-point datatypes
		    BEGIN
		    IF .dix$adtt_fp [.dt [DT_CODE_SEP], fpd$v_typ]
			EQL fpd$k_complex
			THEN		! Complex datatype
			%IF %BLISS (BLISS32) %THEN
			BEGIN			! Use VAX code for complex
			n_useable_length = 16;	! Use H-FLOAT COMPLEX
			n_useable_fw_flag = TRUE;
			$XPO_GET_MEM (FULLWORDS = 16, RESULT = n_useable_value,
			    FILL = 0);
			! Acceptable token type is NT_COMPLEX_NUMBER.
			! Acceptable individual token types are signed and
			! unsigned inegers, floating-point numbers, and
			! fixed-point numbers.
			IF .a_facility [CRA$L_INITIAL_TYPE]
			    NEQ NT_COMPLEX_NUMBER
			    THEN status = FALSE
			    ELSE BEGIN		! Initial value is complex
			    SELECTONE .a_facility [CRA$L_INITIAL_TYPE_1]
				OF SET		! Real part of complex number
			    [T_UNSIGNED_INTEGER, T_SIGNED_INTEGER,
				T_FLOATING_POINT, T_FIXED_POINT]:
			    BEGIN
			    LOCAL des: $STR_DESCRIPTOR (STRING =
				(.a_facility [CRA$L_INITIAL_LENGTH_1],
				.a_member [CRM$A_INITIAL_VALUE]));
			    status = OTS$CVT_T_H (des,
				.n_useable_value, 0, 0, 0);
			    END;
			    [OTHERWISE]:
			    status = FALSE;
			    TES;		! Real part of complex number
			    IF .status THEN
			    SELECTONE .a_facility [CRA$L_INITIAL_TYPE_2] OF
				SET		! Imaginary part of complex
			    [T_UNSIGNED_INTEGER, T_SIGNED_INTEGER,
				T_FLOATING_POINT, T_FIXED_POINT]:
			    BEGIN
			    LOCAL des: $STR_DESCRIPTOR (STRING =
				(.a_member [CRM$W_INITIAL_LENGTH] -
				.a_facility [CRA$L_INITIAL_LENGTH_1] - 1,
				ch$plus (.a_member [CRM$A_INITIAL_VALUE],
				.a_facility [CRA$L_INITIAL_LENGTH_1] + 1)));
			    status = OTS$CVT_T_H (des,
				.n_useable_value + 8*4, 0, 0, 0);
			    END;
			    [OTHERWISE]:
			    status = FALSE;
			    TES;		! Imaginary part of complex
			    IF .status THEN
			    status = DIX$$DES_BY_DET (src_ffd, .n_useable_value,
				SYS_8BIT, 1, 0, 0, DIX$K_DT_H_CMPLX, 0, 0);
			    END;		! Initial value is complex
			END			! Use VAX code for complex
			%ELSE
			BEGIN			! Use 20 code for complex
![1]			n_useable_length = 4;	! Use D-FLOAT COMPLEX
			n_useable_length = 2;	! Use F-FLOAT COMPLEX for now
			n_useable_fw_flag = TRUE;
			$XPO_GET_MEM (FULLWORDS = .n_useable_length,	![1]
			    RESULT = n_useable_value, FILL = 0);	![1]
			! Acceptable token type is NT_COMPLEX_NUMBER.
			! Acceptable individual token types are signed or
			! unsigned integers, floating-point numbers, and
			! fixed-point numbers.
			IF .a_facility [CRA$L_INITIAL_TYPE]
			    NEQ NT_COMPLEX_NUMBER
			    THEN status = FALSE
			    ELSE BEGIN		! Initial value is complex
			    SELECTONE .a_facility [CRA$L_INITIAL_TYPE_1] OF
			    SET			! Real part of complex number
			    [T_UNSIGNED_INTEGER, T_SIGNED_INTEGER,
				T_FLOATING_POINT, T_FIXED_POINT]:
			    BEGIN
			    LOCAL t_err, t_ptr, t_str;
			    ! Make it an ASCIZ string.
			    $XPO_GET_MEM (CHARACTERS =
				.a_facility [CRA$L_INITIAL_LENGTH_1] + 1,
				RESULT = t_str, FILL = 0);
			    $STR_COPY (STRING = (
				.a_facility [CRA$L_INITIAL_LENGTH_1],
				.a_member [CRM$A_INITIAL_VALUE]),
				TARGET = (.a_facility [CRA$L_INITIAL_LENGTH_1],
				.t_str));
![1]			    status = dfin (.t_str; t_ptr, .n_useable_value,
![1]				.n_useable_value + 1, t_err);
%BLISS36(
%IF %SWITCHES(TOPS20)
%THEN
			    status = JSYS_flin (.t_str; t_ptr,		![1]
				.n_useable_value, t_err);		![1]
%ELSE
			    status = flin (.t_str, t_ptr,		![1]
				.n_useable_value, t_err);		![1]
%FI)
			    $XPO_FREE_MEM (STRING = (
				.a_facility [CRA$L_INITIAL_LENGTH_1] + 1,
				.t_str));
			    END;
			    [OTHERWISE]:
			    status = FALSE;
			    TES;			! Real part of complex
			    IF .status THEN
			    SELECTONE .a_facility [CRA$L_INITIAL_TYPE_2] OF
				SET			! Imaginary part
			    [T_UNSIGNED_INTEGER, T_SIGNED_INTEGER,
				T_FLOATING_POINT, T_FIXED_POINT]:
			    BEGIN
			    LOCAL t_err, t_ptr, t_str;
			    ! Make it an ASCIZ string.
			    $XPO_GET_MEM (CHARACTERS =
				.a_member [CRM$W_INITIAL_LENGTH] -
				.a_facility [CRA$L_INITIAL_LENGTH_1],
				RESULT = t_str, FILL = 0);
			    $STR_COPY (STRING = (
				.a_member [CRM$W_INITIAL_LENGTH]
				- .a_facility [CRA$L_INITIAl_LENGTH_1] - 1,
				ch$plus (.a_member [CRM$A_INITIAL_VALUE],
				.a_facility [CRA$L_INITIAL_LENGTH_1] + 1)),
				TARGET = (.a_member [CRM$W_INITIAL_LENGTH] -
				.a_facility [CRA$L_INITIAl_LENGTH_1] - 1,
				.t_str));
![1]			    status = dfin (.t_str; t_ptr, .n_useable_value+2,
![1]				.n_useable_value+3, t_err);
%BLISS36(
%IF %SWITCHES(TOPS20)
%THEN
			    status = JSYS_flin (.t_str; t_ptr,		![1]
				.n_useable_value+1, t_err);		![1]
%ELSE
			    status = flin (.t_str, t_ptr,		![1]
				.n_useable_value+1, t_err);		![1]
%FI)
			    $XPO_FREE_MEM (STRING = (
				.a_member [CRM$W_INITIAL_LENGTH] -
				.a_facility [CRA$L_INITIAL_LENGTH_1], .t_str));
			    END;
			    [OTHERWISE]:
			    status = FALSE;
			    TES;			! Imaginary part
			    IF .status THEN
			    status = DIX$$DES_BY_DET (src_ffd,
				address_of_byte (.n_useable_value),
![1]				SYS_LCG, 1, (0 + 72 - 1), 0,
![1]				DIX$K_DT_D_CMPLX144, 0, 0);
				SYS_LCG, 1, (0 + 36 - 1), 0,		![1]
				DIX$K_DT_F_CMPLX36, 0, 0);		![1]
			    END;			! Use 20 code
			END				! Complex initial value
			%FI
			ELSE		! Floating-point datatype
			%IF %BLISS (BLISS32) %THEN
			BEGIN			! Use VMS code for floating
			n_useable_length = 8;	! Use H_FLOATING
			n_useable_fw_flag = TRUE;
			$XPO_GET_MEM (FULLWORDS = 8, RESULT = n_useable_value,
			    FILL = 0);
			! Acceptable initial values here are signed or unsigned
			! integers, floating-point numbers, and fixed-point
			! numbers.
			SELECTONE .a_facility [CRA$L_INITIAL_TYPE] OF SET
			[T_UNSIGNED_INTEGER, T_SIGNED_INTEGER,
			    T_FLOATING_POINT, T_FIXED_POINT]:
			BEGIN
			LOCAL des: $STR_DESCRIPTOR (STRING =
			    (.a_member [CRM$W_INITIAL_LENGTH],
			    .a_member [CRM$A_INITIAL_VALUE]));
			status = OTS$CVT_T_H (des, .n_useable_value, 0, 0, 0);
			END;
			[OTHERWISE]:
			status = FALSE;
			TES;
			IF .status THEN
			status = DIX$$DES_BY_DET (src_ffd, .n_useable_value,
			    SyS_8BIT, 1, 0, 0, DiX$K_DT_H_FLOAT, 0, 0);
			END;			! Use VMS code for floating
			%ELSE
			BEGIN			! Use 20 code for floating
			n_useable_length = 2;	! Use D-float (best we can do)
			n_useable_fw_flag = TRUE;
			$XPO_GET_MEM (FULLWORDS = 2, RESULT = n_useable_value,
			    FILL = 0);
			! Acceptable initial values here are signed or unsigned
			! integers, floating-point numbers, and fixed-point
			! numbers.
			SELECTONE .a_facility [CRA$L_INITIAL_TYPE] OF SET
			[T_UNSIGNED_INTEGER, T_SIGNED_INTEGER,
			    T_FLOATING_POINT, T_FIXED_POINT]:
			BEGIN
			LOCAL t_err, t_ptr, t_str;
			! Make ASCIZ string.
			$XPO_GET_MEM (CHARACTERS =
			    .a_member [CRM$W_INITIAL_LENGTH] + 1,
			    RESULT = t_str, FILL = 0);
			$STR_COPY (STRING = (.a_member [CRM$W_INITIAL_LENGTH],
			    .a_member [CRM$A_INITIAL_VALUE]), TARGET =
			    (.a_member [CRM$W_INITIAL_LENGTH], .t_str));
%BLISS36(
%IF %SWITCHES(TOPS20)
%THEN
			status = JSYS_dfin (.t_str; t_ptr, .n_useable_value,
			    .n_useable_value + 1, t_err);
%ELSE
			status = dfin (.t_str, t_ptr, .n_useable_value,
			    .n_useable_value + 1, t_err);
%FI)
			$XPO_FREE_MEM (STRING = (
			    .a_member [CRM$W_INITIAL_LENGTH] + 1, .t_str));
			END;
			[OTHERWISE]:
			status = FALSE;
			TES;
			IF .status THEN
			status = DIX$$DES_BY_DET (src_ffd,
			    address_of_byte (.n_useable_value),
			    SYS_LCG, 1, (0 + 72 - 1), 0,
			    DIX$K_DT_FLOAT_72, 0, 0);
			END;		! Use 20 code for floating
			%FI
		    length = 0;
		    bytsiz = .dix$adtt_fp [.dt [DT_CODE_SEP], FPD$V_SIZ];
		    n_initial_length = (.bytsiz + %BPVAL-1) / %BPVAL;
		    ![1] Account for complex bytesize.
		    IF .dix$adtt_fp [.dt [DT_CODE_SEP], FPD$V_TYP]
			EQL FPD$K_COMPLEX
			THEN n_initial_length = ((2*.bytsiz) + %BPVAL-1) /
			    %BPVAL;
		    fullword_flag = TRUE;
		    END;		! Floating-point datatypes

		TES;
! Convert initial values coming from our parser:

		! Make the new initial value:
		IF .status THEN
		IF .fullword_flag
		    THEN $XPO_GET_MEM (FULLWORDS = .n_initial_length, FILL = 0,
			RESULT = n_initial_value)
		    ELSE $XPO_GET_MEM (CHARACTERS = .n_initial_length, FILL = 0,
			RESULT = n_initial_value);

		! Make an FFD to the new initial value:
		IF .status THEN
		IF .sys_org EQL SYS_8BIT OR .sys_org EQL SYS_PRO
		    THEN status = DIX$$DES_BY_DET (dst_ffd, .n_initial_value,
			SYS_8BIT, 1, 0, 0, .a_member [CRM$W_DATATYPE],
			.length, .a_member [CRM$W_SCALE])
		    ELSE status = DIX$$DES_BY_DET (dst_ffd,
			address_of_byte (.n_initial_value),
			SYS_LCG, 1, (0 + .bytsiz - 1), 0,
			.a_member [CRM$W_DATATYPE], .length,
			.a_member [CRM$W_SCALE]);

		! Do the conversion:
		IF .status THEN
		status = DIX$$CON_GEN (src_ffd, dst_ffd);

		! Delete the useable value:
		IF .n_useable_fw_flag
		    THEN $XPO_FREE_MEM (BINARY_DATA = (.n_useable_length,
			.n_useable_value, FULLWORDS))
		    ELSE $XPO_FREE_MEM (STRING = (.n_useable_length,
			.n_useable_value));
		n_useable_length = 0;
	    END;			! Initial value came from our parser
! Initial value is now of the correct datatype, wherever it came from.

	    ! Delete the old initial value:
	    $XPO_FREE_MEM (STRING = (.a_member [CRM$W_INITIAL_LENGTH],
		.a_member [CRM$A_INITIAL_VALUE]));
	    ! Replace it with the new value:
	    a_member [CRM$W_INITIAL_LENGTH] = .n_initial_length;
	    a_member [CRM$A_INITIAL_VALUE] = .n_initial_value;
	    ! Set flag for FULLWORD allocation if appropriate.
	    a_member [CRM$V_FACILITY_USE_3] = .fullword_flag;

	    ! Fill in source FFD in new transform node:
	    IF .status THEN
	    IF .sys_org EQL SYS_8BIT OR .sys_org EQL SYS_PRO
		THEN status = DIX$$DES_BY_DET (new_trans [tra_src$V_UNIT],
		    .a_member [CRM$A_INITIAL_VALUE], SYS_8BIT, 1, 0, 0,
		    .a_member [CRM$W_DATATYPE], .length,
		    .a_member [CRM$W_SCALE])
		ELSE status = DIX$$DES_BY_DET (new_trans [tra_src$V_UNIT],
		    address_of_byte(.a_member [CRM$A_INITIAL_VALUE]),     ![67]
                    SYS_LCG, 1, (0 + .bytsiz - 1), 0,
		    .a_member [CRM$W_DATATYPE], .length,
		    .a_member [CRM$W_SCALE]);

	    ! Fill in destination FFD in new transform node:
	    IF .status THEN
	    IF .sys_org EQL SYS_8BIT OR .sys_org EQL SYS_PRO
		THEN status = DIX$$DES_BY_DET (new_trans [tra_dst$V_UNIT],
		    .dest_buffer, SYS_8BIT, 1, .a_member [CRM$L_MEMBER_OFFSET],
		    0, .a_member [CRM$W_DATATYPE], .length,
		    .a_member [CRM$W_SCALE])
		ELSE status = DIX$$DES_BY_DET (new_trans [tra_dst$V_UNIT],
		    .dest_buffer, SYS_LCG, 1,
		    (.a_member [CRM$L_MEMBER_OFFSET] + .bytsiz - 1),
		    0, .a_member [CRM$W_DATATYPE], .length,
		    .a_member [CRM$W_SCALE]);

	    new_trans [TRA_DST_ADDR] = .a_member;
	    ! Fill in dims and fqn for destination in initial value transform:

	    dims_head = NULL_PTR;	! Initialize dims list for transform
	    fqn_head = NULL_PTR;	! Initialize fqn for transform
	    c_member = .a_member;	! Initialize current member

	    ! Loop on levels of member node parents in record tree.
	    ! Stop when we get to the record node.
	    IF .status THEN
	    WHILE (.c_member [CRM$B_ID] NEQ CRX$K_RECORD) DO
		BEGIN
		! Add current field name to fqn list:
		$XPO_GET_MEM (FULLWORDS = diu$s_crx_stringlist,
		    RESULT = new_fqn, FILL = 0);
		INIT_STRINGLIST (.new_fqn);
		IF .fqn_head EQLA NULL_PTR
		    THEN fqn_head = .new_fqn	! Lowest name in list
		    ELSE BEGIN			! Prefix on to name list
		    fqn_head [CRS$A_PREVIOUS] = .new_fqn;
		    new_fqn [CRS$A_NEXT] = .fqn_head;
		    fqn_head = .new_fqn;
		    END;			! Prefix on to name list
		new_fqn [CRS$W_STRING_LENGTH] = .c_member [CRM$B_NAME_LENGTH];
		$XPO_GET_MEM (CHARACTERS = .new_fqn [CRS$W_STRING_LENGTH],
		    RESULT = new_fqn [CRS$A_STRING]);
		CH$MOVE (.new_fqn [CRS$W_STRING_LENGTH],
		    ch$ptr (c_member [CRM$T_NAME]), .new_fqn [CRS$A_STRING]);
		! Add current dimensions, if any, to dims list:
		IF .c_member [CRM$B_DIMENSIONS_CNT] GTR 0
		    THEN BEGIN			! Has dimensions
		    MAKE_DIMS (new_dims, .c_member);
		    IF .dims_head EQL NULL_PTR
			THEN dims_head = .new_dims	! Lowest dims in list
			ELSE BEGIN			! Prefix on to dims list
			dims_head [DIMS$A_PREVIOUS] = .new_dims;
			new_dims [DIMS$A_NEXT] = .dims_head;
			dims_head = .new_dims;
			END;				! Prefix on to dims list
		    END;			! Has dimensions

		! Find the next parent member block for this member node
		p_member = .c_member [CRM$A_PREVIOUS];
		WHILE TRUE DO
		    IF .p_member [CRM$B_ID] EQL CRX$K_MEMBER	! Member parent
			THEN IF .p_member [CRM$A_CHILDREN] EQLA .c_member
			    THEN EXITLOOP	! Found parent member node
			    ELSE BEGIN		! Try previous node as parent
			    c_member = .p_member;
			    p_member = .p_member [CRM$A_PREVIOUS];
			    END
		    ELSE
		    IF .p_member [CRM$B_ID] EQL CRX$K_OVERLAY	! Overlay node
			THEN BEGIN		! Potential parent is overlay
			LOCAL p_overlay: REF crx_overlay;
			p_overlay = .p_member;	! Go upward until find a
			c_member = .p_member;	!  member parent
			p_overlay = .p_overlay [CRO$A_PREVIOUS];
			p_member = .p_overlay;
			END			! Potential parent is overlay
		    ELSE
		    IF .p_member [CRM$B_ID] EQL CRX$K_RECORD	! Record node
			THEN EXITLOOP;		! Found top node - get out fast!

		c_member = .p_member;
		END;				! Loop on levels of member nodes

	! Put dims and fqn in the new transform
	new_trans [TRA_DST_NAM] = .fqn_head;
	new_trans [TRA_DST_DIMS] = .dims_head;

	IF NOT .status
	    THEN BEGIN			! Initial value is no good - toss it
	    last_trans [TRA_NEXT] = NULL_PTR;
	    DIU$DEL_TRANS_NODE (.new_trans);
	    new_trans = NULL_PTR;
	    END;			! Initial value is no good - toss it


!   Process sibling member nodes at this level:

        END;                            ! end of l_siblings loop
        a_member = .a_member [CRM$A_NEXT];

    END UNTIL (.a_member EQLA NULL_PTR) OR (.depth EQL 0);

    END;				! Member node
! Initial value processing for other node types:

[CRX$K_OVERLAY]:			! CRX_OVERLAY node
    RETURN;				! Just return for now
    ! The code below should be incorporated when VARIANTS are properly
    ! handled in transforms (especially MOVE MATCHING).
!    BEGIN
!    LOCAL
!	a_overlay:	REF crx_overlay;	! A crx_overlay node
!
!    a_overlay = .rec;		! Get field addressability via REF
!
!    DO					! Iterate on CRX_OVERLAY siblings
!	IF .a_overlay [CRO$W_FIELDS_CNT] NEQ 0
!	    THEN INITIAL_VALUE_WALKER (.a_overlay [CRO$A_FIELDS],
!		.transform_list, .sys_org, .dest_buffer, .depth+1)
!    UNTIL ((a_overlay = .a_overlay [CRO$A_NEXT]) EQL NULL_PTR)
!	OR (.depth EQL 0);
!    END;

[CRX$K_DIMENSION]:			! CRX_DIMENSION node
    RETURN;				! Should never get here anyways

[CRX$K_STRINGLIST]:			! CRX_STRINGLIST node
    RETURN;				! Should never get here anyways

[CRX$K_PLI_SPECIFIC]:			! CRX_PLI_SPECIFIC node
    RETURN;				! Should never get here anyways

[CRX$K_LITERAL_LIST]:			! CRX_LITERAL_LIST node
    RETURN;				! Should never get here anyways

TES;

END;
!++
!  DIU$TAG_FIELD  (TAGFLD)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine will replace each crx_stringlist which is the tag
!	variable for an OCCURS DEPENDING with a new block (crx_tag_ffd)
!	which will contain an FFD to the tag variable field in the
!	record during transform processing, a block id, the usual pointers,
!	and a "suspicious tag value" flag.  This routine will be called during
!	transform loading after datatype mapping has been done for the source
!	and destination record description trees.
!
!  CALLING SEQUENCE:
!
!	DIU$TAG_FIELD (root, source_record, sys_org);
!
!  PARAMETERS:
!
!	root		Address of the crx_record block which is the root of the
!			record description tree.
!	source_record	The starting address in memory of the record
!			buffer to be used during transform processing.  This is
!			used to construct the FFD to the tag variable's value.
!	sys_org		System of origin of the record (SYS_8BIT,
!			SYS_LCG, or SYS_PRO), used to make the FFD.
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!--
GLOBAL ROUTINE DIU$TAG_FIELD (root, source_record, sys_org): NOVALUE =
BEGIN

MAP
    root:	REF	crx_record;	! Root of tree

TAG_FIELD_WALKER (.root, .source_record, .sys_org, 0, .root);

END;
!++
!  TAG_FIELD_WALKER  (TAGFLW)
!
!  FUNCTIONAL DESCRIPTION:
!
!	This routine does the work for DIU$TAG_FIELD recursively.
!
!  CALLING SEQUENCE:
!
!	TAG_FIELD_WALKER (root, source_record, sys_org, depth, top);
!
!  PARAMETERS:
!
!	root		Address of the crx_record or crx_member block which is
!			the root of the record description tree or subtree.
!	source_record	The starting address in memory of the record
!			buffer to be used during transform processing.  This is
!			used to construct the FFD to the tag variable's value.
!	sys_org		System of origin of the record (SYS_8BIT,
!			SYS_LCG, or SYS_PRO), used to make the FFD.
!	depth		The recursion depth in this routine.  This is used to
!			control iteration on the siblings of the root node.
!	top		Root of record description tree (a crx_record
!			node).  Used to initialize tree traversals.
!
!  IMPLICIT INPUTS:
!
!	None
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	None
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!--
ROUTINE TAG_FIELD_WALKER (root, source_record, sys_org, depth, top) : NOVALUE =
BEGIN

MAP
    root:	REF crx_record,		! Root of tree or subtree
    top:	REF crx_record;		! Root of tree

IF .root EQLA NULL_PTR
    THEN RETURN;			! Nothing to do here

SELECTONE .root [CRX$B_ID] OF
SET

[CRX$K_RECORD]:				! CRX_RECORD node
    TAG_FIELD_WALKER (.root [CRX$A_ROOT], .source_record, .sys_org,
	.depth+1, .top);

[CRX$K_MEMBER]:				! CRX_MEMBER node
    BEGIN
    LOCAL
	a_dimension:	REF crx_dimension,	! A crx_dimension node
	a_member:	REF crx_member,		! A crx_member node
	a_tag_ffd:	REF crx_tag_ffd,	! A crx_tag_ffd node
	bytsiz,					! Byte size to make FFD
	length,					! Length to make FFD
	status,					! Return status
	t_member:	REF crx_member;		! Tag member block

     LABEL
	l_dimensions,				! Block inside dimensions loop
	l_siblings;				! Block inside siblings loop

    a_member = .root;			! Get field addressability via REF

    DO L_SIBLINGS: BEGIN		! Iterate on CRX_MEMBER siblings
	IF .a_member [CRM$A_CHILDREN] NEQA NULL_PTR
	    THEN TAG_FIELD_WALKER (.a_member [CRM$A_CHILDREN], .source_record,
		.sys_org, .depth+1, .top);
	IF .a_member [CRM$B_DIMENSIONS_CNT] EQL 0
	    THEN LEAVE L_SIBLINGS;	! No dimensions, so no tag fields
	a_dimension = .a_member [CRM$A_DIMENSIONS];
	
	DO L_DIMENSIONS: BEGIN		! Iterate on CRX_DIMENSION siblings
	    IF .a_dimension [CRD$B_DEPEND_ITEM_CNT] EQL 0
		THEN LEAVE L_DIMENSIONS;! No tag field here
	    ! Process the tag field
	    status = DIU$FIND_FIELD (.a_dimension [CRD$A_DEPEND_ITEM],
		.top, t_member);
	    IF .status			! Found the tag field
		THEN BEGIN		! Verify tag useable as an integer
		LOCAL			!  and
		    dt: data_type_sep;	! Compute length and bytesize
		EXTERNAL		! Datatype tables
		    dix$adtt_st:	dtt_st,		! String datatypes
		    dix$adtt_fbin:	dtt_fbin,	! Fixed-point binary
		    dix$adtt_fp:	dtt_fp,		! Floating-point
		    dix$adtt_dn:	dtt_dn,		! Display-numeric
		    dix$adtt_pd:	dtt_pd;		! Packed decimal
		dt = .t_member [CRM$W_DATATYPE];
		CASE .dt [DT_CLASS_SEP] FROM 1 TO DIX$K_MAX_CLASS OF
		    SET
		    [DT_STRING]:
			BEGIN			! String datatypes
			length = .t_member [CRM$L_STRING_UNITS];
			bytsiz = .dix$adtt_st [.dt [dt_code_sep],
			    std$v_byt_siz];
			status = FALSE;
			END;			! String datatypes

		    [DT_FBIN]:
			BEGIN			! Fixed-binary datatypes
			length = 0;
			bytsiz = .dix$adtt_fbin [.dt [dt_code_sep],
			    fbd$v_siz];
			status = TRUE;
			END;			! Fixed-binary datatypes

		    [DT_FP]:
			BEGIN			! Floating-point datatypes
			length = 0;
			bytsiz = .dix$adtt_fp [.dt [dt_code_sep],
			    fpd$v_siz];
			status = FALSE;
			END;			! Floating-point datatypes

		    [DT_DNUM]:
			BEGIN			! Display-numeric datatypes
			length = .t_member [CRM$L_STRING_UNITS];
			bytsiz = .dix$adtt_dn [.dt [dt_code_sep],
			    dnd$v_byt_siz];
			status = TRUE;
			END;			! Display-numeric datatypes

		    [DT_PDEC]:
			BEGIN			! Packed-decimal datatypes
			length = .t_member [CRM$W_DIGITS];
			bytsiz = .dix$adtt_pd [.dt [dt_code_sep],
			    pdd$v_byt_siz];
			status = TRUE;
			END;			! Packed-decimal datatypes

		    TES;
		END;				! Found the tag field
	    ! Make a Tag FFD block:
	    $XPO_GET_MEM (FULLWORDS = diu$s_crx_tag_ffd, RESULT = a_tag_ffd,
		FILL = 0);
	    ! Fill it in:
	    a_tag_ffd [CRT$A_PREVIOUS] = .a_dimension;
	    ! CRT$A_NEXT is always a NULL_PTR, which is zero
	    a_tag_ffd [CRT$B_ID] = CRX$K_TAG_FFD;
	    ! Make the FFD:
	    IF .status
		THEN IF .sys_org EQL SYS_8BIT OR .sys_org EQL SYS_PRO
		    THEN status = DIX$$DES_BY_DET (a_tag_ffd [CRT$V_UNIT],
			.source_record, SYS_8BIT, 1,
			.t_member [CRM$L_MEMBER_OFFSET], 0,
			.t_member [CRM$W_DATATYPE], .length,
			.t_member [CRM$W_SCALE])
		    ELSE status = DIX$$DES_BY_DET (a_tag_ffd [CRT$V_UNIT],
			.source_record, SYS_LCG, 1,
			(.t_member [CRM$L_MEMBER_OFFSET] + .bytsiz - 1),
			0, .t_member [CRM$W_DATATYPE], .length,
			.t_member [CRM$W_SCALE]);
	    IF NOT .status
		THEN a_tag_ffd [CRT$V_SUSPICIOUS_TAG] = TRUE;
	    ! Free the stringlist and hook the tag_ffd in in its place:
	    FREE_STRINGLIST (.a_dimension [CRD$A_DEPEND_ITEM]);
	    a_dimension [CRD$A_DEPEND_ITEM] = .a_tag_ffd;
	END UNTIL ((a_dimension = .a_dimension [CRD$A_NEXT]) EQLA NULL_PTR);

    END UNTIL ((a_member = .a_member [CRM$A_NEXT]) EQLA NULL_PTR)
	OR (.depth EQL 0);

    END;
[CRX$K_OVERLAY]:			! CRX_OVERLAY node
    BEGIN
    LOCAL
	a_overlay:	REF crx_overlay;	! A crx_overlay node

    a_overlay = .root;			! Get field addressability via REF

    DO					! Iterate on CRX_OVERLAY siblings
	IF .a_overlay [CRO$W_FIELDS_CNT] NEQ 0
	    THEN TAG_FIELD_WALKER (.a_overlay [CRO$A_FIELDS],
		.source_record, .sys_org, .depth+1, .top)
    UNTIL ((a_overlay = .a_overlay [CRO$A_NEXT]) EQLA NULL_PTR)
	OR (.depth EQL 0);
    END;

[CRX$K_DIMENSION]:			! CRX_DIMENSION node
    RETURN;				! Should never get here anyways

[CRX$K_STRINGLIST]:			! CRX_STRINGLIST node
    RETURN;				! Should never get here anyways

[CRX$K_PLI_SPECIFIC]:			! CRX_PLI_SPECIFIC node
    RETURN;				! Should never get here anyways

[CRX$K_LITERAL_LIST]:			! CRX_LITERAL_LIST node
    RETURN;				! Should never get here anyways

TES;

END;

END
ELUDOM