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