Google
 

Trailing-Edge - PDP-10 Archives - BB-H138F-BM_1988 - 7-sources/diultr.bli
There are 4 other files named diultr.bli in the archive. Click here to see a list.
%TITLE 'Routines to Load Transform Structures After Files Are Open' 
MODULE DIULTR(
       IDENT='253'
       %BLISS32 (,
                 ADDRESSING_MODE(EXTERNAL=GENERAL,NONEXTERNAL=LONG_RELATIVE)
                 )
       %BLISS36 (,
                 ENTRY (diuofs, recoff, dixprt, makffd, lodtra)
                )
                               ) = 
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.
!
! FACILITY:	DIU    Data Interchange Utility  V01-000
!
! ABSTRACT:	This module contains the routines to finish loading the 
!		transform structure, once the files have been opened.
!		Some of the transform information cannot be filled in
!		until such time as the files are open and the system
!		types are known.
!
! AUTHOR:  Sandy Clemens			CREATED: 9-Jan-1985
!
! EDIT HISTORY:
!
!       3	Clean up copyright notices.  Change LIBRARY 'DIUMSG'
!		to 'DIU'.  Clean up condition handling.  Add calls to
!               DIU$TAG_FIELD and DIU$INITIAL_VALUE.  General cleanup.
!		Sandy Clemens	14-Jun-85
!
!       4	During transform loading / data type remapping, if the
!               member node was made by CRX then there won't be a facility
!               specific block.  If there is an initial value, however we
!               need the facility specific block in order to save the original
!               data type (before mapping) for use in initial value processing.
!               Add creation of this block and setting of the data type within
!               it.   FILES:  DIULTR.BLI
!               Sandy Clemens	17-Jun-85
!
!       10	Make default transform generation code use the DIU top level
!               condition handler rather than DIU$TRANS_HANDLER.
!               Sandy Clemens	20-Jun-85
!
!       14      Teach tree remapping code about complex floating-point data
!               types.
!               Sandy Clemens	15-Jul-85
!
!       22	Made routine SINGLE_FQN_NAME get the entire field name string
!               out of the record description tree (not just the partial name
!               from the transform).
!               Sandy Clemens	18-Jul-85
!
!       23	Make transform loading return the destination record size.
!               FILES:  DIULTR.BLI, INTFAC.BLI.
!               Sandy Clemens	18-Jul-85
!
!       65	In DIU$LOAD_TRANS check usage types: don't allow mixed usage
!               w/in records; if user specified a usage type it must match the
!               usage of the datatypes in the record.  If user didn't specify
!               usage, then set global usages based on usage found in record
!               description (or default if none found).
!               Sandy Clemens  12-Feb-86
!
!   66	In DIU$LOAD_TRANS when checking the usage of the datatype, add
!	an OTHERWISE case to the SELECTONE statement in order to catch
!	the "data type" codes for DIU$K_DT_OVERLAY and DIU$K_DT_STRUCTURE.
!	Sandy Clemens  17-Feb-86
!
!   73	Get rid of "need_usage".
!	Sandy Clemens	4-Mar-86
!
!  162  Update comments which mention the now non-existent /USAGE switch.
!       Sandy Clemens  14-May-86
!
!  236  Change library of DIXLIB to DIUDIX.
!       Sandy Clemens  19-Jun-86
!
!  242  Datatype DIX$K_DT_DN6LO was missing from the SELECTONE statement
!       in DIU$REMAP_TREE where the usage type is set.
!       Sandy Clemens  19-Jun-86
!
!  253  Change libraries to new names.
!       Gregory A. Scott 1-Jul-86
!--
!********************************************************************
!           L I B R A R Y   A N D   R E Q U I R E    F I L E S
!********************************************************************
%IF %BLISS (BLISS32)
%THEN
     LIBRARY 'SYS$LIBRARY:XPORT';       ! XPORT definitions
     UNDECLARE %QUOTE $STRING;
     LIBRARY 'SYS$LIBRARY:STARLET';     ! VMS System Services
     LIBRARY 'DIU$SOURCE_LIB:DIUVMS';	! DIU VMS Specifics
     LIBRARY 'DIU$SOURCE_LIB:DIUMSG';	! DIU MESSAGE Literals.
%FI

%IF %BLISS (BLISS36)
%THEN
     LIBRARY 'BLI:XPORT';               ! XPORT definitions
     LIBRARY 'FAOPUT';                  ! Defines $FAO_PUT macro
     LIBRARY 'FAO';
     LIBRARY 'DIU';
%FI

UNDECLARE %QUOTE $DESCRIPTOR;
LIBRARY 'DIUCRX';                       ! CRX data structures
UNDECLARE %QUOTE $DESCRIPTOR;
LIBRARY 'DIUTLB';			! DIU Transform sturcture
UNDECLARE %QUOTE $DESCRIPTOR;
UNDECLARE %QUOTE STS$K_SEVERE, %QUOTE STS$K_ERROR, %QUOTE STS$K_WARNING,
          %QUOTE STS$K_SUCCESS, %QUOTE SS$_NORMAL, %QUOTE STS$K_INFO;
LIBRARY 'DIUDIX';			! DIX/DIL specific things
LIBRARY 'DIUMLB';			! DIU Mapping routines library

%IF %BLISS (BLISS32)
%THEN
     UNDECLARE %QUOTE $DESCRIPTOR;
%FI

LIBRARY 'DIUACTION';

EXTERNAL ROUTINE DIU$DIXERR_HANDLER,
                 DIU$MAP_DATATYPES,
                 COMPUTE_OFFSETS,
                 TREE,                  ! DEBUGGING ONLY
                 DIU$TAG_FIELD,
                 DIU$INITIAL_VALUE,
                 COMPUTE_END_OFFSETS,
                 COMPUTE_ARRAY_LENGTH,
                 DIX$$DES_BY_DET,       ! DIL routine to make FFDs
                 SINGLE_FQN_NAME,
                 DIU$DUMP_TRANSFORM;

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

LITERAL off = 0,
        on = 1;
!******************************************************************
!                    D I U $ O F F S E T S
!******************************************************************
GLOBAL ROUTINE DIU$OFFSETS (tree, field_offset, total_offset,
                            fld_length, sysor) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
!       This routine is similar to the DEFINE_GROUP_ATTS in module
!       ACTION.BLI.  This routine will recursively traverse the record
!       description tree, refiguring offsets for the member and
!       overlay nodes, based on the system type passed.
!
! FORMAL PARAMETERS
!
!       tree	        The address of the record description subtree
!			whose attributes are to be defined.
!
!	field_offset	The address of a (long)word containing the
!			offset from the beginning of the parent field
!			where the prior field ended.
!
!	total_offset	The address of a (long)word containing the
!			offset from the beginning of the record to
!			where the prior field ended.
!
!	fld_length	The address of a (long)word to be set to
!			the length of the current field.
!
!	sysor	        A value indicating system type (use literals
!                       sys_lcg, sys_pro or sys_8bit)
!
! ROUTINE VALUE
!
!	None.
!--
BEGIN

BIND offset = .field_offset,
     member_offset = .total_offset,
     total_length = .fld_length;

LOCAL   cdd_record : REF crx_record,
        member : REF crx_member,
	overlay : REF crx_overlay,
	status : INITIAL (0),
        child_offset : INITIAL (0),
        child_member_offset : INITIAL (0),
        child_blk : REF crx_member,
        child_length : INITIAL (0),
        src_indic : INITIAL (0),
        max_child_length : INITIAL (0),
        max_child_member_length : INITIAL (0),
        length : INITIAL (0);

IF .tree EQL 0 THEN
RETURN;                                 ! subtree traversal completed

cdd_record = .tree;                     ! get addressiblity via REF
member = .tree;
overlay = .tree;

SELECTONE .cdd_record [CRX$B_ID] OF
SET

[CRX$K_RECORD] :
       ! Walk all subfields
       DIU$OFFSETS (.cdd_record [CRX$A_ROOT], offset, member_offset,
                    total_length, .sysor);

[CRX$K_MEMBER] :
       BEGIN
       !++
       ! Call compute_offsets routine which figures out where this field
       ! should start.  Pass the current offset and member_offset, which
       ! will be updated, if necessary, with the new offsets.  Save the
       ! new offsets in the current member node!
       !--
       compute_offsets (offset, member_offset, .member, .sysor);

       ! set offsets...
       member [CRM$L_OFFSET] = .offset;
       member [CRM$L_MEMBER_OFFSET] = .member_offset;

       !++
       ! Handle VARIANTS fields.  The length of a VARIANTS field is the length
       ! of the longest VARIANT.
       !--
       IF .member [CRM$W_DATATYPE] EQL DIU$K_DT_OVERLAY
       THEN BEGIN
            child_blk = .member [CRM$A_CHILDREN];
            ! walk through children and find length of the longest one!
            WHILE .child_blk NEQ 0 DO
                  BEGIN
                  child_offset = .offset;
                  child_member_offset = .member_offset;
                  DIU$OFFSETS (.child_blk, child_offset, child_member_offset,
                               child_length, .sysor);

                  IF .child_length GTRU .member [CRM$L_LENGTH]
                  THEN member [CRM$L_LENGTH] = .child_length;
                  child_blk = .child_blk [CRM$A_NEXT];
                  END;
            ! save the member length -- same as lengths for VARIANTS because
            ! a variant CANNOT be an array.
            member [CRM$L_MEMBER_LENGTH] = .member [CRM$L_LENGTH];
            END;

       ! process the children for structures

       IF .member [CRM$W_DATATYPE] EQL DIU$K_DT_STRUCTURE       ! if STRUCTURE
       THEN BEGIN
            child_offset = 0;           ! Start the new structure
            child_member_offset = .member_offset;
            child_blk = .member [CRM$A_CHILDREN];
            max_child_length = 0;
            max_child_member_length = 0;
            WHILE .child_blk NEQ 0 DO   ! walk children
                  BEGIN 
                  ! save largest childs length & member length for VARIANTS
                  DIU$OFFSETS (.child_blk, child_offset, child_member_offset,
                               child_length, .sysor);

                  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]; ! next sibling
                  END;

            ! save the length in this member node
            member [CRM$L_MEMBER_LENGTH] = .length;
            member [CRM$L_LENGTH] = .length;

            END;                        ! end of IF datatype = STRUCTURE 

       !++
       ! Update offsets to those of the end of this field for return
       ! from this routine.
       !--
       compute_end_offsets (offset, member_offset, .member, .sysor);

       !++
       ! Update offsets to add additional length caused by dimensions.
       !--
       IF .member [CRM$A_DIMENSIONS] NEQ 0      ! there are dimension nodes
       THEN compute_array_length (offset, member_offset, .member, .sysor);

       ! compute total length of field:
       total_length = .member [CRM$L_LENGTH];

       END;                             ! end case crx$k_member

[CRX$K_OVERLAY] :
       BEGIN
       !++
       ! Save the current offsets in the overlay node.
       !--
       overlay [CRO$L_MIN_OFFSET] = .offset;
       overlay [CRO$L_MIN_MEMBER_OFFSET] = .member_offset;

       ! process the subfields for VARIANT
       child_offset = .offset;          ! VARIANT keeps same offset
       child_member_offset = .member_offset;
       child_blk = .overlay [CRO$A_FIELDS];
       max_child_length = 0;
       max_child_member_length = 0;
       WHILE .child_blk NEQ 0 DO   ! walk children
             BEGIN 
             ! save largest childs length & member length for VARIANTS
             DIU$OFFSETS (.child_blk, child_offset, child_member_offset,
                          child_length, .sysor);

             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]; ! next sibling
             END;

       length = .length - .offset;        ! figure length of VARIANT

       ! save the length in this overlay node
       overlay [CRO$L_TOTAL_LENGTH] = .length;

       ! Save the length of the largest subfield
       overlay [CRO$L_MAX_LENGTH] = .max_child_member_length;

       ! save total length of field (equals MAX for overlay)
       total_length = .overlay [CRO$L_MAX_LENGTH];

       END;                             ! end case crx$k_overlay

[OTHERWISE] :
       SIGNAL (DIU$_BUG);               ! signal internal bug

TES;

END;                                    ! end routine DIU$OFFSETS
!******************************************************************
!                 D I U $ R E M A P _ T R E E
!******************************************************************
ROUTINE DIU$REMAP_TREE (tree, sysor, usage) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
!       This routine walks an entire tree recursively and maps the
!       data types into DIL datatypes (by calling DIU$MAP_DATATYPES)
!       and refigures the field lengths of ONLY the terminal member
!       nodes, based on the datatypes.  DIU$OFFSETS refigures the
!       lengths of structures and variants based on what is found here!
!
! FORMAL PARAMETERS
!
!       tree	        The address of the record description subtree
!			whose attributes are to be defined.
!
!	sysor	        A value indicating system type (use literals
!                       sys_lcg, sys_pro or sys_8bit)
!
!       usage           Addr of value indicating USAGE type for character data
!
! ROUTINE VALUE
!
!	None.
!--
BEGIN

LOCAL   cdd_record : REF crx_record,
        member : REF crx_member,
	overlay : REF crx_overlay,
	status : INITIAL (0),
        child_blk : REF crx_member,
        src_indic : INITIAL (0),
        length : INITIAL (0);

IF .tree EQL 0 THEN
RETURN;                                 ! subtree traversal completed

cdd_record = .tree;                     ! get addressiblity via REF
member = .tree;
overlay = .tree;

SELECTONE .cdd_record [CRX$B_ID] OF
SET

[CRX$K_RECORD] :
       ! Walk all subfields
       DIU$REMAP_TREE (.cdd_record [CRX$A_ROOT], .sysor, .usage);

[CRX$K_MEMBER] :
       BEGIN
       LOCAL new_len : INITIAL (0),
             loc_usg : INITIAL (unspec_typ),
             dattyp : data_type_sep;

       src_indic = .member [CRM$V_FACILITY_USE_5];
       dattyp = .member [CRM$W_DATATYPE];

       !++
       ! If this member node was created by VAX-CDD then it doesn't have
       ! a facility specific block, but if an initial value was specified
       ! then a facility specific block is needed to save the original data
       ! type of the field (since it may get mapped to something different).
       ! So make a faciltiy specific block if necessary...  Note that we
       ! don't really need this if this member node is for the SOURCE record,
       ! but at this point we don't have any way to tell that...
       !--
       IF (.src_indic EQL cdd32_src) AND (.member [CRM$A_INITIAL_VALUE] NEQ 0)
       THEN BEGIN
            LOCAL additional_blk : REF crx_additional;
            $XPO_GET_MEM (FULLWORDS = cra$s_crx_additional,
                          FILL = 0,
                          RESULT = additional_blk);
            member [CRM$A_FACILITY] = .additional_blk;
            ! set bit indicating source crx 
            additional_blk [CRA$V_SRC_CRX] = 1;
            ! map datatype to 8-bit DIL equivalent
            additional_blk [CRA$L_INITIAL_TYPE] =
                     DIU$MAP_DATATYPES (sys_8bit, .dattyp, .usage, .src_indic);
            END;

       !++
       ! Check the usage type of the field.  If the data type of the
       ! member field has a usage associated with it, (fixed-point
       ! binary and floating-point fields have NO usage!)  then set
       ! LOC_USG to the usage of the member data type.  If the member
       ! field data type has no usage, then set LOC_USG to the usage
       ! passed (since there is no conflict).  If USAGE (passed) is
       ! unspecified then set it to LOC_USG.  (If LOC_USG has a usage
       ! (ie: is not unspec_typ or default_typ) then we will have set
       ! USAGE to the new usage type).
       !--
       SELECTONE .dattyp [dt_class_sep] OF
       SET
       [dt_fbin, dt_fp] : loc_usg = ..usage;

       [dt_string, dt_dnum] :
               SELECTONE .dattyp OF
               SET [DIX$K_DT_ASCII_7, DIX$K_DT_ASCII_8, DIX$K_DT_ASCIZ,
                    DIX$K_DT_DN7LO, DIX$K_DT_DN7LS, DIX$K_DT_DN7TO,
                    DIX$K_DT_DN7TS, DIX$K_DT_DN7U, DIX$K_DT_DN8LO,
                    DIX$K_DT_DN8LS, DIX$K_DT_DN8TO, DIX$K_DT_DN8TS,
                    DIX$K_DT_DN8U] : loc_usg = ascii_txt;
                   [DIX$K_DT_EBCDIC_8, DIX$K_DT_EBCDIC_9, DIX$K_DT_DN9LO,
                    DIX$K_DT_DN9LS, DIX$K_DT_DN9TO, DIX$K_DT_DN9TS,
                    DIX$K_DT_DN9U] : loc_usg = ebcdic_txt;
                   [DIX$K_DT_SIXBIT, DIX$K_DT_DN6LS, DIX$K_DT_DN6TO,
                    DIX$K_DT_DN6LO,  DIX$K_DT_DN6TS,
                    DIX$K_DT_DN6U] : loc_usg = sixbit_txt;
               TES;

       [dt_pdec] :
               IF .sysor EQL sys_lcg
               THEN loc_usg = ebcdic_txt
               ELSE loc_usg = ..usage;

       [OTHERWISE] :    ! catch datatypes DIU$K_DT_OVERLAY & DIU$K_DT_STRUCTURE
                loc_usg = ..usage;
       TES;

       SELECTONE ..usage OF
       SET
       [unspec_typ, default_typ] : .usage = .loc_usg;
       [OTHERWISE] : IF ..usage NEQ .loc_usg
                     THEN SIGNAL (DIU$_USAGE_CONFLICT);
       TES;

       !++
       ! Map the data type to the appropriate DIL data type for the
       ! system type indicated.
       !--

       member [CRM$W_DATATYPE] =
                     DIU$MAP_DATATYPES (.sysor, .dattyp, ..usage, .src_indic);
       member [CRM$V_FACILITY_USE_5] = dil_src; ! datatypes are now DIL types

       !++
       ! If the datatype is not STRUCTURE or OVERLAY then figure the
       ! length (in bits) of the field.  Set the CRM$L_LENGTH and
       ! CRM$L_MEMBER_LENGTH fields for this node...
       !--
       IF (.member [CRM$W_DATATYPE] NEQ DIU$K_DT_OVERLAY)
          AND (.member [CRM$W_DATATYPE] NEQ DIU$K_DT_STRUCTURE)
       THEN BEGIN
            dattyp = .member [CRM$W_DATATYPE];
            new_len = (CASE .dattyp [dt_class_sep] FROM 1 TO dix$k_max_class OF
                       SET

                       [dt_string] :
                         .dix$adtt_st [.dattyp [dt_code_sep], std$v_byt_siz]
                           * .member [CRM$L_STRING_UNITS];

                       [dt_fbin] :
                         .dix$adtt_fbin [.dattyp [dt_code_sep], fbd$v_siz];

                       [dt_fp] :
                         ! For floating-point complex, must multiply the
                         ! fpd$v_siz by 2 to get the size of the entire field.
                         IF .dix$adtt_fp [.dattyp [dt_code_sep], fpd$v_typ]
                             EQL fpd$k_complex
                         THEN
                            .dix$adtt_fp [.dattyp [dt_code_sep], fpd$v_siz] * 2
                         ELSE
                            .dix$adtt_fp [.dattyp [dt_code_sep], fpd$v_siz];

                       [dt_dnum] :
                         .dix$adtt_dn [.dattyp [dt_code_sep], dnd$v_byt_siz]
                           * .member [CRM$L_STRING_UNITS];

                       [dt_pdec] :
                         .dix$adtt_pd [.dattyp [dt_code_sep], pdd$v_byt_siz]
                           * .member [CRM$W_DIGITS];

                       TES);

            member [CRM$L_LENGTH] = .new_len;
            member [CRM$L_MEMBER_LENGTH] = .new_len;
            END;

       !++
       ! Process the children for OVERLAY and STRUCTURE fields...
       !--
       IF (.member [CRM$W_DATATYPE] EQL DIU$K_DT_OVERLAY) OR
         (.member [CRM$W_DATATYPE] EQL DIU$K_DT_STRUCTURE)
       THEN BEGIN
            member [CRM$L_MEMBER_OFFSET] = 0;
            member [CRM$L_OFFSET] = 0;
            member [CRM$L_LENGTH] = 0;
            member [CRM$L_MEMBER_LENGTH] = 0;

            child_blk = .member [CRM$A_CHILDREN];
            WHILE .child_blk NEQ 0 DO   ! walk children
                  BEGIN
                  DIU$REMAP_TREE (.child_blk, .sysor, .usage);
                  child_blk = .child_blk [CRM$A_NEXT];  ! next sibling
                  END;
            END;

       END;                             ! end case crx$k_member

[CRX$K_OVERLAY] :
       BEGIN
       ! process the subfields for VARIANT

       child_blk = .overlay [CRO$A_FIELDS];
       WHILE .child_blk NEQ 0 DO   ! walk children
             BEGIN 
             ! save largest childs length & member length for VARIANTS
             DIU$REMAP_TREE (.child_blk, .sysor, .usage);
             child_blk = .child_blk [CRM$A_NEXT];       ! next sibling
             END;

       END;                             ! end case crx$k_overlay

[OTHERWISE] :
       SIGNAL (DIU$_BUG);               ! signal diu internal error

TES;

END;                                    ! end routine DIU$REMAP_TREE
!******************************************************************
!                D I U $ R E C O R D _ O F F S E T S
!******************************************************************
GLOBAL ROUTINE DIU$RECORD_OFFSETS (rec_tree, sysor, usage) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!	This routine is simply an interface to the DIU$OFFSETS
!	routine, which does all the grunt work of remapping datatypes
!	and refiguring offsets based on the system of origin of the
!	record.  Note that if the SYSOR passed is SYS_PRO, we have to
!       change it to SYS_8BIT and pass a "PRO flag" (set to ON) to
!       DIU$OFFSETS, which doesn't know about SYS_PRO because some of
!       the routines it calls haven't been taught about SYS_PRO.
!
! FORMAL PARAMETERS
!
!	rec_tree	is the address of the record description
!			subtree whose attributes are to be defined
!
!	sysor		is a value indicating system of origin for the
!			record described by the record description tree;
!                       (either SYS_LCG, SYS_8BIT, or SYS_PRO)
!
!	usage		addr of integer indicating a USAGE type for
!			character data
!
! ROUTINE VALUE
!
!	Total length of the record.
!--

LOCAL field_offset : INITIAL (0),
      total_offset : INITIAL (0),
      fld_length : INITIAL (0),
      retstat : INITIAL (0),
      status : INITIAL (0);

DIU$REMAP_TREE (.rec_tree, .sysor, .usage);

DIU$OFFSETS (.rec_tree, field_offset, total_offset,
             fld_length, .sysor);

.total_offset                           ! return total record length

END;                                    ! end of routine DIU$RECORD_OFFSETS
!********************************************************************
!                  D I U $ D I X _ P O R T A L
!********************************************************************
GLOBAL ROUTINE DIU$DIX_PORTAL (src_flg, ffd, buff, sysor, crxmbr) =
!++
!
! FUNCTIONAL DESCRIPTION
!
!       This routine is the portal to the DIX$$DES_BY_DET routine.
!       This routine is called by DIU$MAKE_FFDS to fill both the
!       source and destination FFDs.
!
! FORMAL PARAMETERS
!
!       src_flg         If ON, this is the source ffd, if OFF, this is
!                       the destination ffd.
!
!	ffd		The address of the ffd to fill.
!
!	buff		The address of the record buffer.
!
!	sysor   	A value for the operating system type, either SYS_LCG,
!			SYS_PRO or SYS_8BIT.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!       DIU$_NORMAL (normal successful completion) or
!       anything signalled by DIX$$DES_BY_DET.
!
!--
BEGIN

LOCAL
     member : REF crx_member,
     dattyp : data_type_sep,
     bytsiz : INITIAL (0),
     length : INITIAL (0),
     retstat : INITIAL (0),
     status : INITIAL (0),
     error_tmp : VOLATILE;

ENABLE DIU$DIXERR_HANDLER (error_tmp);

member = .crxmbr;
dattyp = .member [CRM$W_DATATYPE];

CASE .dattyp [dt_class_sep] FROM 1 TO dix$k_max_class OF        
   SET

   [dt_string] :
       BEGIN
       length = .member [CRM$L_STRING_UNITS];
       bytsiz = .dix$adtt_st [.dattyp [dt_code_sep], std$v_byt_siz];
       END;

   [dt_dnum] :
       BEGIN
       length = .member [CRM$L_STRING_UNITS];
       bytsiz = .dix$adtt_dn [.dattyp [dt_code_sep], dnd$v_byt_siz];
       END;

   [dt_pdec] :
       BEGIN
       length = .member [CRM$W_DIGITS];
       bytsiz = .dix$adtt_pd [.dattyp [dt_code_sep], pdd$v_byt_siz];
       END;

   [dt_fbin] :
       BEGIN
       length = 0;
       bytsiz = .dix$adtt_fbin [.dattyp [dt_code_sep], fbd$v_siz];
       END;

   [dt_fp] :
       BEGIN
       length = 0;
       bytsiz = .dix$adtt_fp [.dattyp [dt_code_sep], fpd$v_siz];
       END;

   TES;

!++
! Fill the FFD.  Note that there is not a special case here for
! dimension information.  This is because the FFD is set up for the
! first cell of the array (by using the offset and datatype indicated
! in the member node) and later, when processing of transforms is
! done, the FFD will be incremented for each array cell and processed
! there appropriately.
!
! Since all field offsets in the member nodes are BIT offsets, tell
! DIL that the byte-size is 1, and the bit offset is zero and pass the
! "byte" offset directly from the member node CRM$L_MEMBER_OFFSET
! field.  This works just fine for sys_8bit and sys_pro.  However,
! because of the way DIL works, (because sys_lcg can have variable
! byte-sizes), DIL must be passed the sys_lcg offset in a slightly
! different way.  First, extract the byte-size for the field from the
! DIL data type tables and add the byte-size minus 1 to the byte
! offset (which is in bits because byte-size = bit = 1).  What we are
! trying to end up with is the offset to the low order bit of the
! first byte of the field (where byte is of the size known to DIL and
! found in the DIL data type tables).
!--

CASE .sysor FROM 1 TO sys_max+1 OF      ! sys_pro = sys_max + 1
   SET
   [sys_8bit, sys_pro] :
   !++
   ! For sys_pro tell DIL its sys_8bit, because DIL doesn't know
   ! about sys_pro.
   !--
   retstat = dix$$des_by_det (.ffd, .buff, sys_8bit, 1, 
                              .member [CRM$L_MEMBER_OFFSET],
                              0, .member [CRM$W_DATATYPE], .length,
                              .member [CRM$W_SCALE]);
   [sys_lcg] :
   retstat = dix$$des_by_det (.ffd, .buff, sys_lcg, 1,
                              (.member [CRM$L_MEMBER_OFFSET] + .bytsiz - 1),
                              0, .member [CRM$W_DATATYPE], .length,
                              .member [CRM$W_SCALE]);

   TES;

!++
! Since errors from DIX$$DES_BY_DET are signalled and returned as the
! value of this routine (thanks to the enabled handler diu$dixerr_hand,
! this is probably not necessary...
!--
IF NOT .retstat
THEN RETURN (.retstat);

RETURN DIU$_NORMAL;

END;
!********************************************************************
!                   D I U $ M A K E _ F F D S
!********************************************************************
GLOBAL ROUTINE DIU$MAKE_FFDS (trans, src_buf, src_opsys, dst_buf, dst_opsys) =
!++
!
! FUNCTIONAL DESCRIPTION
!
!       This routine walks the entire transform structure and makes
!       the FFDs indicated for each transform node.  Call routine
!       DIU$DIX_PORTAL to build FFDs.
!
! FORMAL PARAMETERS
!
!	trans		The root address of the tranform list.
!
!	src_buf		The address of the source record buffer.
!
!	src_opsys	A value for the operating system type, either SYS_LCG,
!			or SYS_8BIT.
!
!	dst_buf		The address of the source record buffer.
!
!	dst_opsys	A value for the operating system type, either SYS_LCG,
!			or SYS_8BIT.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUES
!
!       DIU$_NORMAL (normal successful completion)
!       DIU$_INVFLDDSC (with an underlying DIX error if
!		DIU$DIX_PORTAL returns an error) 
!
!--
BEGIN

LOCAL member : REF crx_member,
      tra_loc : REF transform_str,
      nam_loc : $STR_DESCRIPTOR(),
      retstat : INITIAL (0),
      status : INITIAL (0);

tra_loc = .trans;                       ! addressiblity via REF

DO BEGIN

   IF .tra_loc [tra_id] NEQ DIU$K_TRANSFORM
   THEN SIGNAL (DIU$_BUG);

   ! First process the source fields...

   member = .tra_loc [tra_src_addr];	! Addressibility via REFs
   retstat = diu$dix_portal (ON, tra_loc [tra_src_ffd], .src_buf,
                             .src_opsys, .member);

   IF NOT .retstat
   THEN                                 ! signal error
       BEGIN
       SINGLE_FQN_NAME (.tra_loc [tra_src_addr], nam_loc);      ! make a usable
       SIGNAL (DIU$_INVFLDDSC, 1, nam_loc, .retstat);           !   field name
       END;

   ! Now process the destination fields...

   member = .tra_loc [tra_dst_addr];	! Addressibility via REFs
   retstat = diu$dix_portal (OFF, tra_loc [tra_dst_ffd], .dst_buf,
                             .dst_opsys, .member);

   IF NOT .retstat
   THEN                                 ! signal error
       BEGIN
       SINGLE_FQN_NAME (.tra_loc [tra_dst_addr], nam_loc);      ! make a usable
       SIGNAL (DIU$_INVFLDDSC, 1, nam_loc, .retstat);           !   field name
       END;


   ! process next node 
   tra_loc = .tra_loc [tra_next];

   END
UNTIL .tra_loc EQL 0;                   ! stop if no more trans nodes

RETURN DIU$_NORMAL;                     ! any errors are signalled

END;                                    ! end of routine DIU$MAKE_FFDS
!********************************************************************
!                  D I U $ L O A D _ T R A N S
!********************************************************************
GLOBAL ROUTINE DIU$LOAD_TRANS (src_tree, src_buf, src_buf_len, src_opsys,
			       dst_tree, dst_buf, dst_buf_len, dst_opsys,
			       trans, src_usage, dst_usage) =
!++
!
! FUNCTIONAL DESCRIPTION
!
!       This routine is a portal for the transform loading function.
!       This routine is called, after the files are opened, to
!       complete the transform loading, ie., create FFDs.  First, call
!       DIU$RECORD_OFFSETS to reset the source record description tree
!       offsets, length, strides and etc.  Then call
!       DIU$RECORD_OFFSETS for the destination record description
!       tree.  Next, call DIU$MAKE_FFDS to create and verify FFDs for
!       the source and destination fields.
!
! FORMAL PARAMETERS
!
!	src_tree	The root address of the src record description tree.
!
!	src_buf		The address of the source record buffer.
!
!	src_buf_len	A value which indicates the length of src_buf.
!
!	src_opsys	A value for the operating system type, either SYS_LCG,
!			or SYS_8BIT.
!
!	dst_tree	The root address of the dst record description tree.
!
!	dst_buf		The address of the source record buffer.
!
!	dst_buf_len	A value which indicates the length of dst_buf.
!
!	dst_opsys	A value for the operating system type, either SYS_LCG,
!			or SYS_8BIT.
!
!	trans		The root address of the tranform list.
!
!	src_usage       Addr of USAGE type for source character data.
!
!	dst_usage       Addr of USAGE type for destination character data.
!
! IMPLICIT PARAMETERS
!
!	None
!
! ROUTINE VALUE
!
!	length of the destination record (needed for setting up
!       an internal buffer to hold the destination data)...
!
!--

BEGIN

LOCAL	retstat : INITIAL(0),
        status : INITIAL (0),
        ret_dst_len : INITIAL (0),
        tra_loc : REF transform_str,
        fqn_loc : REF crx_stringlist,
        nam_loc : $STR_DESCRIPTOR();

!++
! Call DIU$RECORD_OFFSETS to (1) reset offsets in the record definition
! trees, (2) remap the members data types so that they are DIL types, and
! (3) set [CRM$V_FACILITY_USE_5] to DIL_SRC to mark that the data types
! are now DIL types.
!--

DIU$RECORD_OFFSETS (.src_tree, .src_opsys, .src_usage);

!++
! Call DIU$TAG_FIELD for the source tree to 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 source record.
!--
DIU$TAG_FIELD (.src_tree, .src_buf, .src_opsys);

!++
! We don't care about the value returned for the source, it's the
! destination where we need to pay attention!
!--
ret_dst_len = DIU$RECORD_OFFSETS (.dst_tree, .dst_opsys, .dst_usage);

!++
! Call DIU$TAG_FIELD for the destination tree.
!--
DIU$TAG_FIELD (.dst_tree, .dst_buf, .dst_opsys);

!+
! Call DIU$MAKE_FFDS to fill in the FFDs in the transform structure, now
! that the record offsets and strides, etc. have been set correctly for
! the operating systems specified.
!++

%IF %BLISS (BLISS36) AND diu$k_tra_debug
%THEN
     $FAO_PUT (1, 'SRC_BUF = !OL', .src_buf);
     $FAO_PUT (1, 'DST_BUF = !OL', .dst_buf);
%FI

%IF %BLISS (BLISS32) AND diu$k_tra_debug
%THEN
     $FAO_PUT (1, 'SRC_BUF = !XL', .src_buf);
     $FAO_PUT (1, 'DST_BUF = !XL', .dst_buf);
%FI

retstat = DIU$MAKE_FFDS (.trans, .src_buf, .src_opsys, .dst_buf, .dst_opsys);

!++
! Since errors from DIU$MAKE_FFDS are signalled this is probably not
! necessary anyway...
!--
IF NOT .retstat
THEN RETURN (.retstat);

!++
! Call DIU$INITIAL_VALUE to replace the existing initial values pointed
! to by the CRX_MEMBER blocks with initial values 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 trasform execution.
!--
DIU$INITIAL_VALUE (.dst_tree, .trans, .dst_opsys, .dst_buf);

%IF diu$k_tra_debug
%THEN
     $FAO_PUT (1, ' ');
     $FAO_PUT (1, 'AFTER INITIAL VALUE LOADING, TRANSFORM IS: ');
     $FAO_PUT (1, ' ');
     DIU$DUMP_TRANSFORM (.trans);
%FI

%IF diu$k_tra_debug
%THEN
     $FAO_PUT (1, ' ');
     $FAO_PUT (1, 'SRC_TREE IS: ');
     $FAO_PUT (1, ' ');
     TREE (.src_tree);
%FI

%IF diu$k_tra_debug
%THEN
     $FAO_PUT (1, ' ');
     $FAO_PUT (1, 'DST_TREE IS: ');
     $FAO_PUT (1, ' ');
     TREE (.dst_tree);
%FI

.ret_dst_len                            ! return length of the dst record

END;

END
ELUDOM