Trailing-Edge
-
PDP-10 Archives
-
BB-JF18A-BM
-
sources/diu/diuau1.bli
There are 4 other files named diuau1.bli in the archive. Click here to see a list.
MODULE DIUAU1 (%require ('DIUPATSWITCH')
IDENT = '253') =
BEGIN
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1986.
! ALL RIGHTS RESERVED.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND
! COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
! THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR
! ANY OTHER COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
! AVAILABLE TO ANY OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE
! SOFTWARE IS HEREBY TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
! NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
! EQUIPMENT CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF
! ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
!++
!
! TITLE: ACTUTL DDL and Transform Action Utilities
!
! FACILITY: DIU
!
! ABSTRACT:
!
! This module contains utility routines used by the parser action
! routines in ACTION.BLI.
!
! ENVIRONMENT:
!
! All routines run in user access mode.
!
! These routines are NOT AST reentrant.
!
! AUTHOR: Charlotte Richardson, 1-Feb-85
!
! MODIFICATION HISTORY:
!
! 253 Rename file to DIUAU1.
! Gregory A. Scott 1-Jul-86
!
! 236 Change library of DIXLIB to DIUDIX.
! Sandy Clemens 19-Jun-86
!
! 145 Fix FREE_STRINGLIST so that if zero is passed to it, it won't
! try to release the memory...
! Sandy Clemens 7-May-86
!
! 1 Charlotte Richardson 30-May-85
! Teach FREE_STRINGLIST and friends to deal with CRX_TAG_FFD
! nodes.
!--
! INCLUDE FILES:
REQUIRE 'DIUPATPROLOG'; ! General module prologue
LIBRARY 'DIUPATTOKEN'; ! Token manipulation
LIBRARY 'DIUPATDATA'; ! Shared specification
LIBRARY 'DIUDEB'; ! Debugging
LIBRARY 'DIUPATLANGSP'; ! Language Specific function
LIBRARY 'DIUPATPARSER';
LIBRARY 'BLI:XPORT'; ! Transportable data structures
LIBRARY 'DIUACTION'; ! Structures unique to semantic actions
LIBRARY 'DIUDIX'; ! Define data conversion codes
%IF %BLISS (BLISS32) %THEN
UNDECLARE %QUOTE $DESCRIPTOR; ! Clean up after XPORT
%FI
LIBRARY 'DIUCRX'; ! CRX record structures
%IF %BLISS (BLISS32) %THEN
UNDECLARE %QUOTE $DESCRIPTOR; ! Yet again...
%FI
LIBRARY 'DIUTLB'; ! Transform data structures
%IF %BLISS (BLISS32) %THEN
UNDECLARE %QUOTE $DESCRIPTOR; ! Clean up after XPORT
%FI
LIBRARY 'DIUMLB'; ! Datatype mapping library
%IF %BLISS (BLISS32) %THEN
UNDECLARE %QUOTE $DESCRIPTOR; ! Clean up after XPORT
LIBRARY 'SYS$LIBRARY:STARLET';
%FI
! TABLE OF CONTENTS:
FORWARD ROUTINE
COMPUTE_ARRAY_LENGTH: NOVALUE, ! Compute array length
COMPUTE_BYTE_SIZE, ! Compute field's byte size
COMPUTE_BYTE_SIZE_WALKER, ! Used by COMPUTE_BYTE_SIZE
COMPUTE_END_OFFSETS: NOVALUE, ! Compute offsets at end of field
COMPUTE_OFFSETS: NOVALUE, ! Compute field offsets
COMPUTE_STRIDES: NOVALUE, ! Compute array strides
COPY_RECORD, ! Copy a record template
DEAL_WITH_TRANSFORM_NAMES, ! Deal with field names used in a transform
DUPLICATE_SUBTREE, ! Duplicate a record description subtree
FIND_DATATYPE, ! Find a datatype for a field
FIND_DATATYPE_WALKER, ! Used by FIND_DATATYPE
DIU$FIND_FIELD, ! Find specified field
FIND_MATCHING_MEMBER, ! Find matching member block given name
FIND_NAMES_IN_TREES, ! Find member blocks to match names
FIX_COPY_TEMPLATE: NOVALUE, ! Map datatypes in COPY template
FIX_VARIANTS: NOVALUE, ! Complete VARIANT blocks in tree
FREE_DIMENSIONS: NOVALUE, ! Free a list of dimensions
FREE_LITLIST: NOVALUE, ! Free a list of literal lists
FREE_MEMBERS: NOVALUE, ! Releases a crx_member and all subtrees
FREE_RECORD: NOVALUE, ! Free a record and all subtrees
FREE_STRINGLIST: NOVALUE, ! Free a stringlist and all subtrees
INIT_LITERAL: NOVALUE, ! Initialize a crx_literal_list node
INIT_MEMBER: NOVALUE, ! Initialize a crx_member node
INIT_STRINGLIST: NOVALUE, ! Initialize a crx_stringlist node
MAKE_DIMS: NOVALUE, ! Make a dims structure
MAKE_FQN: NOVALUE, ! Make an FQN structure
MAKE_TRANSFORM: NOVALUE, ! Make a transform structure
NAME_SYNTAX, ! Check field name syntax
PRODUCE_FQN, ! Produce fully-qualified name list
VALIDATE_FQN; ! Validate a fuly-qualified name list
! External routines for transform processing:
EXTERNAL ROUTINE
DIU$DEL_DIMS: NOVALUE; ! Delete a dims structure
!++
! COMPUTE_ARRAY_LENGTH (CMTARR)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine computes the offsets created by an array. It also calls
! the routine which computes the stride of the array dimensions,
! and computes the total number of elements in the array.
!
! CALLING SEQUENCE:
!
! COMPUTE_ARRAY_LENGTH (field_offset, field_member_offset,
! field_blk, sys_org);
!
! INPUT PARAMETERS:
!
! field_offset is the address of the offset from the beginning
! of the parent field to where the prior field ended.
! It is updated to reflect the end of the array.
!
! field_member_offset is the address of the offset from the beginning
! of the record to where the prior field ended.
! It is updated to reflect the end of the array.
!
! field_blk is the address of the field block whose offset is to
! be defined.
!
! sys_org System of origin (sys_lcg or sys_8bit/sys_pro)
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! none
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
GLOBAL ROUTINE COMPUTE_ARRAY_LENGTH (FIELD_OFFSET, FIELD_MEMBER_OFFSET,
FIELD_BLK, SYS_ORG): NOVALUE =
BEGIN
MAP
FIELD_BLK : REF CRX_MEMBER;
BIND
OFFSET = .FIELD_OFFSET,
MEMBER_OFFSET = .FIELD_MEMBER_OFFSET,
ADDITIONAL_BLK = .FIELD_BLK [crm$a_facility]: crx_additional;
LOCAL
BITS_LEFT,
BYTE_SIZE,
BYTES_LEFT,
BYTES_PER_WORD,
DCB_PTR : REF crx_dimension,
FILL_LENGTH : INITIAL (0),
INTEGRAL_WORDS,
LENGTH,
NEW_MEMBER_OFFSET : INITIAL (0),
NEW_OFFSET : INITIAL (0),
NO_ELEMENTS : INITIAL (0),
ONE_DIMENSION_FL : INITIAL (FALSE);
DEB_EVENT ('Semantic actions',
PUT_MSG_EOL ('ACTION_RTN called COMPUTE_ARRAY_LENGTH'));
! Compute field length allowing for field alignment and synchronization:
! Store current member length and replace it: COMPUTE_END_OFFSETS may try to
! recompute it, and we are only calling the offset routines to compute the
! length of the second and succeeding elements.
LENGTH = .FIELD_BLK [CRM$L_LENGTH];
NEW_OFFSET = .OFFSET;
NEW_MEMBER_OFFSET = .MEMBER_OFFSET;
COMPUTE_OFFSETS (new_offset, new_member_offset, .field_blk, .sys_org);
COMPUTE_END_OFFSETS (new_offset, new_member_offset, .field_blk, .sys_org);
FIELD_BLK [CRM$L_LENGTH] = .LENGTH;
FILL_LENGTH = .NEW_OFFSET - .OFFSET;
! NOTE: This will be the length of each element in the array (except possibly
! the first element) for all arrays EXCEPT character string arrays on 10/20
! systems which are not synchronized and which are not aligned on a datatype
! other than BIT or BYTE. Grrr....
! Compute number of elements and member length for simple cases:
NO_ELEMENTS = 1;
DCB_PTR = .FIELD_BLK [crm$a_dimensions];
WHILE .DCB_PTR NEQU NULL_PTR DO
BEGIN
NO_ELEMENTS = .NO_ELEMENTS * (.DCB_PTR [crd$l_upper_bound] -
.DCB_PTR [crd$l_lower_bound] + 1);
DCB_PTR = .DCB_PTR [crd$a_next];
END;
FIELD_BLK [crm$l_total_cells] = .NO_ELEMENTS;
FIELD_BLK [crm$l_member_length] = .NO_ELEMENTS * .FIELD_BLK [crm$l_length];
! Compute length of record so far if the offset calculation is simple.
! This will be used to correct the member length later if the offset
! calculation is not simple or is changed by alignment.
length = .field_blk [CRM$L_MEMBER_OFFSET] +
.field_blk [CRM$L_MEMBER_LENGTH];
! Compute ending field offsets (see NOTE above):
! Calculation of the ending offsets is simple if:
! 1. This is a VAX or PRO, or
! 2. This field is not some kind of character string, or
! 3. This field is aligned on something other than BIT or BYTE, or
! 4. This field is synchronized.
IF (.sys_org EQL SYS_8BIT) OR (.sys_org EQL SYS_PRO) OR
(NOT .field_blk [CRM$V_STRING_TYPE]) OR
((additional_blk NEQA NULL_PTR) AND
(.additional_blk [CRA$V_ALIGNMENT_EXISTS]) AND
(.additional_blk [CRA$L_ALIGNMENT] NEQ T_BIT) AND
(.additional_blk [CRA$L_ALIGNMENT] NEQ T_BYTE)) OR
((additional_blk NEQA NULL_PTR) AND
(.additional_blk [CRA$V_SYNC_LEFT] OR
.additional_blk [CRA$V_SYNC_RIGHT]))
THEN BEGIN ! "Simple" offset calculation
OFFSET = .FILL_LENGTH * (.NO_ELEMENTS - 1) + .OFFSET;
MEMBER_OFFSET = .FILL_LENGTH * (.NO_ELEMENTS - 1) + .MEMBER_OFFSET;
IF (additional_blk NEQA NULL_PTR) AND
(.additional_blk [CRA$V_SYNC_LEFT])
THEN LENGTH = (.FILL_LENGTH - .FIELD_BLK [CRM$L_LENGTH])
* (.NO_ELEMENTS - 1)
ELSE LENGTH = .MEMBER_OFFSET - .LENGTH;
END ! Of "simple" offset calculation
! The complex offset calculation is needed for byte string arrays on 10/20
! which are BIT or BYTE aligned (or not aligned at all) and which are not
! synchronized (synchronization forces word-alignment and also causes the
! data field to end on a word boundary when slack bytes and bits are included).
! 1. Find the byte size of the string array.
! 2. Find how many bytes of this size fit in a word.
! 3. Find how many bits are left in the last word containing part of the
! first element in the string array.
! 4. Fill this word.
! 5. If there are more bytes, update the offsets to the end of this word.
! 6. Account for the intregral words, if any, in the offsets.
! 7. Compute how many bytes go in the last partial word occupied by the
! string array.
! 8. Update offsets to the end of the last element in the string array.
ELSE BEGIN ! Complex offset calculation
byte_size = COMPUTE_BYTE_SIZE (.field_blk, .sys_org);
bytes_per_word = DIU$K_O_WORD / .byte_size;
bits_left = (DIU$K_O_WORD - (.member_offset MOD DIU$K_O_WORD))
MOD DIU$K_O_WORD;
bytes_left = .field_blk [CRM$L_STRING_UNITS] * (.no_elements - 1)
- (.bits_left / .byte_size);
IF .bytes_left GTR 0
THEN BEGIN ! Won't all fit in current word
member_offset = ((.member_offset + DIU$K_O_WORD-1)
/ DIU$K_O_WORD) * DIU$K_O_WORD;
offset = ((.offset + DIU$K_O_WORD-1)
/ DIU$K_O_WORD) * DIU$K_O_WORD;
integral_words = (.bytes_left - 1) / .bytes_per_word;
END ! Won't all fit in current word
ELSE BEGIN ! Will fit in current word
integral_words = 0;
bytes_left = .field_blk [CRM$L_STRING_UNITS]
* (.no_elements - 1);
END; ! Will fit in current word
member_offset = .member_offset + (.integral_words * DIU$K_O_WORD);
offset = .offset + (.integral_words * DIU$K_O_WORD);
bytes_left = .bytes_left - (.integral_words * .bytes_per_word);
member_offset = .member_offset + (.bytes_left * .byte_size);
offset = .offset + (.bytes_left * .byte_size);
length = .member_offset - .length;
END; ! Of complex offset calculation
! Update member_length in case the offset was complex or the field
! was aligned or synchronized left:
field_blk [crm$l_member_length] = .field_blk [crm$l_member_length]
+ .length;
! See if array is one-dimensional:
IF .FIELD_BLK [crm$b_dimensions_cnt] EQL 1
THEN ONE_DIMENSION_FL = TRUE;
! Compute dimension strides:
COMPUTE_STRIDES (.FIELD_BLK [crm$a_dimensions], .FILL_LENGTH,
.ONE_DIMENSION_FL, .FIELD_BLK [crm$v_column_major]);
END;
!++
! COMPUTE_BYTE_SIZE (CMTBSZ)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine computes the applicable byte size for aligning a field.
! For a VAX or PRO, the result is always 8.
! For a 10/20, the result is:
! The byte size of the field in question, if it has one
! The byte size of the first child of the filed found by a
! depth-first search, if any
! The byte size of the innermost encompassing structure which
! has a byte size, if any
! 6 (for SIXBIT, the COBOL default), if no byte size can be
! determined up through the record level.
!
! CALLING SEQUENCE:
!
! byte_size = COMPUTE_BYTE_SIZE (field_blk, sys_org);
!
! PARAMETERS:
!
! field_blk Address of the member block in question
! sys_org System of origin (sys_lcg or sys_8bit/sys_pro)
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! Returns the byte size to be used to align the field.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE COMPUTE_BYTE_SIZE (field_blk, sys_org) =
BEGIN
MAP
field_blk: REF crx_member;
IF (.sys_org EQL SYS_8BIT) ! VAX case - easy!
OR (.sys_org EQL SYS_PRO)
THEN RETURN 8
ELSE BEGIN ! 10/20 case:
LOCAL
byte_size,
current_member: REF crx_member,
current_parent: REF crx_member;
! If field is a string, return its bytesize:
IF .field_blk [CRM$V_STRING_TYPE]
THEN RETURN size_of (.field_blk [CRM$W_DATATYPE]);
! Try a depth-first search of the children looking for a usable byte-size:
byte_size = COMPUTE_BYTE_SIZE_WALKER (.field_blk, 0);
IF .byte_size NEQ 0
THEN RETURN .byte_size;
! Look for an encompassing structure with a bytesize, and return that:
current_member = .field_blk;
current_parent = .field_blk [CRM$A_PREVIOUS];
WHILE TRUE DO BEGIN
IF (.current_parent [CRM$B_ID] NEQ CRX$K_RECORD)
THEN WHILE (.current_parent [CRM$A_CHILDREN] NEQ .current_member)
DO BEGIN ! Still in sibling group
current_member = .current_parent;
current_parent = .current_member [CRM$A_PREVIOUS];
END;
! Found parent or the top record node.
IF .current_parent [CRM$B_ID] EQL CRX$K_RECORD
THEN RETURN 6; ! All the way back up to the record node
IF .current_parent [CRM$V_STRING_TYPE]
THEN RETURN size_of (.current_parent [CRM$W_DATATYPE]);
! Try next higher encompassing structure.
current_member = .current_parent;
current_parent = .current_member [CRM$A_PREVIOUS];
END;
END; ! 10/20 case
RETURN 1; ! Satisfy Bliss compiler's need for a value here
END;
!++
! COMPUTE_BYTE_SIZE_WALKER (CMTBSW)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine is called by COMPUTE_BYTE_SIZE to find the byte-size
! of the first child of the field in question found by a depth-first
! search, if there is any. Otherwise, it will return zero.
!
! CALLING SEQUENCE:
!
! byte_size = COMPUTE_BYTE_SIZE_WALKER (field_blk, depth);
!
! PARAMETERS:
!
! field_blk Address of the member block in question
! depth Recursion depth
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! Returns the byte size if it finds one.
! Returns zero otherwise.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
ROUTINE COMPUTE_BYTE_SIZE_WALKER (field_blk, depth) =
BEGIN
MAP
field_blk: REF crx_member; ! Member block in question
LOCAL
byte_size, ! Returned byte-size
current_member: REF crx_member; ! Current member block
IF .field_blk [CRM$B_ID] NEQ CRX$K_MEMBER
THEN RETURN 0; ! Not a member block, so no byte-size
current_member = .field_blk;
WHILE (.current_member NEQA NULL_PTR) Do
BEGIN
IF .current_member [CRM$V_STRING_TYPE]
THEN RETURN size_of (.current_member [CRM$W_DATATYPE]);
IF (.current_member [CRM$A_CHILDREN] NEQA NULL_PTR)
THEN BEGIN
byte_size = COMPUTE_BYTE_SIZE_WALKER
(.current_member [CRM$A_CHILDREN], .depth+1);
IF .byte_size NEQ 0
THEN RETURN .byte_size;
END;
IF (.depth NEQ 0)
THEN current_member = .current_member [CRM$A_NEXT]
ELSE RETURN 0;
END;
RETURN 0;
END;
!++
! COMPUTE_END_OFFSETS (CMTEND)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine computes the offset and member_offset at the end of a
! field based on the field's length, datatype, and any SYNCHRONIZED
! clause.
!
! CALLING SEQUENCE:
!
! COMPUTE_END_OFFSETS (current_offset, current_member_offset, field_blk,
! sys_org);
!
! PARAMETERS:
!
! current_offset Address of current offset of this field, updated
! current_member_offset Address of current member_offset of this
! field, updated
! field_blk Address of the member block in question
! sys_org System of origin or destination for this record
! (sys_lcg or sys_8bit/sys_pro)
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
!--
GLOBAL ROUTINE COMPUTE_END_OFFSETS (current_offset, current_member_offset,
field_blk, sys_org): NOVALUE =
BEGIN
MAP
field_blk: REF crx_member;
BIND
additional_blk = .field_blk [CRM$A_FACILITY]: crx_additional,
member_offset = .current_member_offset,
offset = .current_offset;
LOCAL
bits_left,
byte_size,
bytes_left,
bytes_per_word,
integral_words,
length;
! Handle where the data itself ends:
! If SYS_ORG is a VAX or PRO, data ends where its length indicates.
! If an LCG system:
! If the data is not a string, it ends where its length indicates.
! If the data is a string, it ends where its length indicates,
! adjusted to account for how the bytes are stored.
IF (.sys_org EQL SYS_8BIT) OR (NOT .field_blk [CRM$V_STRING_TYPE])
OR (.sys_org EQL SYS_PRO)
THEN BEGIN ! Easy case: it ends where it says it ends
offset = .offset + .field_blk [CRM$L_LENGTH];
member_offset = .member_offset + .field_blk [CRM$L_LENGTH];
END
! Computation of end of a byte field on 10/20:
! 1. Stuff as many bytes as will fit into the current partial word; the
! bytes may be aligned improperly in this word due to proceeding fields.
! DO NOT do this if the current word has nothing in it yet; it
! can't have any misaligned bytes in that case.
! 2. Update offsets to the end of this word.
! 3. Fill up an integral number of words.
! Note that the last word filled has to be treated as a partial word,
! so that we don't fill to the end of the word as part of this field.
! 4. Fill a partial word.
! Then compute the REAL field length.
ELSE BEGIN ! Messy case: field does NOT end where it says it does
byte_size = COMPUTE_BYTE_SIZE (.field_blk, .sys_org);
length = .member_offset;
bits_left = (DIU$K_O_WORD - (.member_offset MOD DIU$K_O_WORD))
MOD DIU$K_O_WORD;
bytes_left = .field_blk [CRM$L_STRING_UNITS] - .bits_left / .byte_size;
bytes_per_word = DIU$K_O_WORD / .byte_size;
IF .bytes_left GTR 0
THEN BEGIN ! Field will not fit in current word
member_offset = ((.member_offset + DIU$K_O_WORD-1)
/ DIU$K_O_WORD) * DIU$K_O_WORD;
integral_words = (.bytes_left-1) / .bytes_per_word;
END ! Field will not fit in current word
ELSE BEGIN ! Field will fit in current word
integral_words = 0;
bytes_left = .field_blk [CRM$L_STRING_UNITS];
END; ! Field will fit in current word
member_offset = .member_offset + (.integral_words * DIU$K_O_WORD);
bytes_left = .bytes_left - (.integral_words * .bytes_per_word);
member_offset = .member_offset + (.bytes_left * .byte_size);
length = .member_offset - .length;
offset = .offset + .length;
field_blk [CRM$L_LENGTH] = .length;
field_blk [CRM$L_MEMBER_LENGTH] = .length;
end;
! Handle SYNCHRONIZED LEFT:
! Change offsets to end on a word boundary.
IF (additional_blk NEQA NULL_PTR) AND
(.additional_blk [CRA$V_SYNC_LEFT])
THEN BEGIN
length = .member_offset;
member_offset = ((.member_offset + DIU$K_O_WORD-1) / DIU$K_O_WORD)
* DIU$K_O_WORD;
length = .member_offset - .length;
offset = .offset + .length;
END;
END;
!++
! COMPUTE_OFFSETS (CMTOFF)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine computes the offset and member_offset for a field based on
! the field's datatype, any explicit alignment provided by an
! ALIGNED clause, and alignment caused by SYNCHRONIZED.
!
! NOTE: We let the ALIGNED clause take precedence over the default for the
! datatype, on the assumption that the user asked for it. Thus a user
! can force a field which would normally be word-aligned on a 10/20 to
! be byte-aligned (on some size byte), but the resulting data may be
! difficult to access.
!
! CALLING SEQUENCE:
!
! COMPUTE_OFFSETS (current_offset, current_member_offset, field_blk,
! sys_org);
!
! PARAMETERS:
!
! current_offset Address of current offset of this field, updated
! current_member_offset Address of current member_offset of this
! field, updated
! field_blk Address of the member block in question
! sys_org System of origin or destination for this
! record (sys_lcg or sys_8bit/sys_pro)
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE COMPUTE_OFFSETS (current_offset, current_member_offset,
field_blk, sys_org) : NOVALUE =
BEGIN
MAP
field_blk: REF crx_member;
BIND
additional_blk = .field_blk [CRM$A_FACILITY]: crx_additional,
offset = .current_offset,
member_offset = .current_member_offset;
LOCAL
bits_left,
bits_more,
bytes_left,
bytes_per_word,
byte_size,
integral_words,
s_byte,
s_word,
s_longword,
s_quadword,
s_octaword;
! Pre-compute sizes to reduce size of generated code (common subexpression
! elimination isn't this smart). This should prevent running out of heap
! space while compiling this module with BLISS36.
s_byte = DIU$K_O_BYTE;
s_word = DIU$K_O_WORD;
s_longword = DIU$K_O_LONGWORD;
s_quadword = DIU$K_O_QUADWORD;
s_octaword = DIU$K_O_OCTAWORD;
! Explicit ALIGNED clause:
IF additional_blk NEQA NULL_PTR AND
.additional_blk [CRA$V_ALIGNMENT_EXISTS]
THEN SELECTONE .additional_blk [CRA$L_ALIGNMENT] OF
SET
[T_BIT]: ; ! No changes necessary
[T_BYTE]: BEGIN
byte_size = COMPUTE_BYTE_SIZE (.field_blk, .sys_org);
integral_words = .member_offset / .s_word;
bits_left = .member_offset - (.integral_words * .s_word);
bits_more = (((.bits_left + .byte_size-1) / .byte_size)
* .byte_size) - .bits_left;
offset = .offset + .bits_more;
member_offset = .member_offset + .bits_more;
END;
[T_WORD]: BEGIN
bits_more = .member_offset;
member_offset = ((.member_offset + .s_word-1)
/ .s_word) * .s_word;
bits_more = .member_offset - .bits_more;
offset = .offset + .bits_more;
END;
[T_LONGWORD]: BEGIN
bits_more = .member_offset;
member_offset = ((.member_offset + .s_longword-1)
/ .s_longword) * .s_longword;
bits_more = .member_offset - .bits_more;
offset = .offset + .bits_more;
END;
[T_QUADWORD]: BEGIN
bits_more = .member_offset;
member_offset = ((.member_offset + .s_quadword-1)
/ .s_quadword) * .s_quadword;
bits_more = .member_offset - .bits_more;
offset = .offset + .bits_more;
END;
[T_OCTAWORD]: BEGIN
bits_more = .member_offset;
member_offset = ((.member_offset + .s_octaword-1)
/ .s_octaword) * .s_octaword;
bits_more = .member_offset - .bits_more;
offset = .offset + .bits_more;
END;
TES
! No explicit ALIGNED clause:
ELSE IF (.sys_org EQL SYS_8BIT)
OR (.sys_org EQL SYS_PRO) THEN BEGIN
! VAX or PRO case:
! bit field: begins on next bit
! any other field: begins on next 8-bit byte
! IF .field_blk [CRM$W_DATATYPE] EQL DIU$K_DTYPE_VU
! THEN RETURN
! ELSE BEGIN
bits_more = .member_offset;
member_offset = ((.member_offset + .s_byte-1)
/ .s_byte) * .s_byte;
bits_more = .member_offset - .bits_more;
offset = .offset + .bits_more;
! END;
END
! TOPS-10/20 case:
! fixed-point, floating-point, or pointer field: next word
! any other field: next byte (of byte size of field, encompassing
! structure, or record)
ELSE BEGIN
LOCAL dattyp: data_type_sep;
dattyp = FIND_DATATYPE (.field_blk, .sys_org);
selectone .dattyp [DT_CLASS_SEP] OF SET
[DT_FBIN, DT_FP]: BEGIN ! Word-aligned
bits_more = .member_offset;
member_offset = ((.member_offset + .s_word-1)
/ .s_word) * .s_word;
bits_more = .member_offset - .bits_more;
offset = .offset + .bits_more;
END;
[OTHERWISE]: BEGIN ! "Byte" aligned
byte_size = COMPUTE_BYTE_SIZE (.field_blk, .sys_org);
integral_words = .member_offset / .s_word;
bits_left = .member_offset -
(.integral_words * .s_word);
IF (.s_word - .bits_left) LSS .byte_size
THEN BEGIN ! No more bytes fit in this word
bits_more = .member_offset;
member_offset = ((.member_offset + .s_word-1)
/ .s_word) * .s_word;
bits_more = .member_offset - .bits_more;
offset = .offset + .bits_more;
END ! No more bytes fit in this word
ELSE BEGIN ! Start string at right place in word
bits_more = (((.bits_left + .byte_size-1)
/ .byte_size) * .byte_size) - .bits_left;
offset = .offset + .bits_more;
member_offset = .member_offset + .bits_more;
END; ! Start string at right place in word
END;
TES;
END;
! Handle synchronization:
! Synchronization of either sort causes word alignment.
! Right synchronization causes additional slack bytes so field will end on
! a word boundary.
! Left synchronization only affects the ending offset of the field, once word
! alignment has been done, so no more work is needed here.
IF additional_blk NEQA NULL_PTR AND
(.additional_blk [CRA$V_SYNC_LEFT] OR .additional_blk [CRA$V_SYNC_RIGHT])
THEN BEGIN ! Adjust for word alignment
bits_more = .member_offset;
member_offset = ((.member_offset + .s_word-1) / .s_word) * .s_word;
bits_more = .member_offset - .bits_more;
offset = .offset + .bits_more;
END;
IF additional_blk NEQA NULL_PTR AND
.additional_blk [CRA$V_SYNC_RIGHT]
THEN BEGIN ! Right synchronized
byte_size = COMPUTE_BYTE_SIZE (.field_blk, .sys_org);
bytes_per_word = .s_word / .byte_size;
bytes_left = .bytes_per_word -
(.field_blk [CRM$L_STRING_UNITS] MOD .bytes_per_word);
offset = .offset + .bytes_left * .byte_size;
member_offset = .member_offset + .bytes_left * .byte_size;
END;
RETURN;
END;
!++
! COMPUTE_STRIDES (CMTSTR)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine computes the strides for each dimension in an array.
! The number of bits calculated will be correct as is if:
! 1. This is a VAX or PRO, or
! 2. The field is not a character string of any sort, or
! 3. The field is aligned on something other than BIT or BYTE, or
! 4. The field is synchronized.
! Otherwise, see the calculation in COMPUTE_ARRAY_LENGTH, above.
!
! CALLING SEQUENCE:
!
! COMPUTE_STRIDES (dcb_ptr, stride_length, one_dimension_fl,
! column_major_fl);
!
! INPUT PARAMETERS:
!
! dcb_ptr is the address of the dimension node describing
! the first array dimension.
!
! stride_length is the length of an element in the array plus
! the fill area (if any) between elements.
!
! one_dimension_fl TRUE if array has one dimension
!
! column_major_fl TRUE if array is column_major
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! none
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
GLOBAL ROUTINE COMPUTE_STRIDES (DCB_PTR, STRIDE_LENGTH, ONE_DIMENSION_FL,
COLUMN_MAJOR_FL) : NOVALUE =
BEGIN
MAP
DCB_PTR : REF crx_dimension;
LOCAL
NO_ELEMENTS : INITIAL (0),
TEMP_PTR : REF crx_dimension;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called COMPUTE_STRIDES'));
! Compute strides for last or only dimension:
IF (.DCB_PTR [crd$a_next] EQLU NULL_PTR) OR .ONE_DIMENSION_FL
THEN BEGIN
DCB_PTR [crd$l_stride] = .STRIDE_LENGTH;
DCB_PTR [crd$v_stride_fl] = TRUE;
RETURN;
END;
! Compute column-major strides:
IF .COLUMN_MAJOR_FL
THEN BEGIN
NO_ELEMENTS = 1;
WHILE .DCB_PTR NEQU NULL_PTR DO
BEGIN
DCB_PTR [crd$l_stride] = .NO_ELEMENTS * .STRIDE_LENGTH;
DCB_PTR [crd$v_stride_fl] = TRUE;
NO_ELEMENTS = .NO_ELEMENTS * (.DCB_PTR [crd$l_upper_bound] -
.DCB_PTR [crd$l_lower_bound] + 1);
DCB_PTR = .DCB_PTR [crd$a_next];
END;
RETURN;
END;
! Compute row-major strides:
WHILE .DCB_PTR NEQU NULL_PTR DO
BEGIN
NO_ELEMENTS = 1;
TEMP_PTR = .DCB_PTR [crd$a_next];
WHILE .TEMP_PTR NEQU NULL_PTR DO
BEGIN
NO_ELEMENTS = .NO_ELEMENTS *
(.TEMP_PTR [crd$l_upper_bound] -
.TEMP_PTR [crd$l_lower_bound] + 1);
TEMP_PTR = .TEMP_PTR [crd$a_next];
END;
DCB_PTR [crd$l_stride] = .NO_ELEMENTS * .STRIDE_LENGTH;
DCB_PTR [crd$v_stride_fl] = TRUE;
DCB_PTR = .DCB_PTR [crd$a_next];
END;
END;
!++
! COPY_RECORD (CPYREC)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine copies a record template from the data dictionary.
!
! CALLING SEQUENCE:
!
! status = COPY_RECORD (field_blk, name);
!
! INPUT PARAMETERS:
!
! field_blk Address of field block to be copied to
! name Address of string descriptor of name to copy
!
! IMPLICIT INPUTS:
!
! TBS
!
! IMPLICIT OUTPUTS:
!
! TBS
!
! COMPLETION STATUS:
!
! FALSE Operation not implemented yet
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE COPY_RECORD (field_blk, name) =
BEGIN
MAP
FIELD_BLK: REF crx_member,
NAME: REF $STR_DESCRIPTOR ();
%IF %BLISS (BLISS32) %THEN
EXTERNAL ROUTINE
CRX$EXTRACT_DESCRIPTION,
LIB$GET_VM,
CRX$SIGN_OFF;
LOCAL
temp: REF crx_member,
tree: REF crx_record initial (NULL_PTR),
root: REF crx_member,
fac: initial (FALSE), ! CDD facility-specific stuff not wanted
comments: initial (FALSE); ! CDD descriptions not wanted
%FI
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called COPY_RECORD'));
! The CRX code should be called here to retrieve the record template from
! the CDD (on VMS) or from a DTR-20 dictionary (on TOPS-20), some day.
%IF %BLISS (BLISS36) %THEN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'COPY of Datatrieve descriptions not implemented');
RETURN FALSE;
%ELSE
tree = CRX$EXTRACT_DESCRIPTION (.name, %REF (LIB$GET_VM), fac, comments);
root = .tree [CRX$A_ROOT]; ! Root member node of COPY template
! Move data from root of COPY template into COPY record:
field_blk [CRM$W_REF_LENGTH] = .root [CRM$W_REF_LENGTH];
field_blk [CRM$W_CHILDREN_CNT] = .root [CRM$W_CHILDREN_CNT];
field_blk [CRM$B_TAG_VARIABLE_CNT] = .root [CRM$B_TAG_VARIABLE_CNT];
field_blk [CRM$B_DIMENSIONS_CNT] = .root [CRM$B_DIMENSIONS_CNT];
! Don't bother to copy CRM$A_DESCRIPTION - not used by DIU
field_blk [CRM$A_REFERENCE] = .root [CRM$A_REFERENCE];
temp = .root [CRM$A_REFERENCE];
IF .temp NEQA NULL_PTR
THEN temp [CRM$A_PREVIOUS] = .field_blk;
field_blk [CRM$A_CHILDREN] = .root [CRM$A_CHILDREN];
temp = .root [CRM$A_CHILDREN];
IF .temp NEQA NULL_PTR
THEN temp [CRM$A_PREVIOUS] = .field_blk;
field_blk [CRM$A_TAG_VARIABLE] = .root [CRM$A_TAG_VARIABLE];
temp = .root [CRM$A_TAG_VARIABLE];
IF .temp NEQA NULL_PTR
THEN temp [CRM$A_PREVIOUS] = .field_blk;
field_blk [CRM$L_LENGTH] = .root [CRM$L_LENGTH];
field_blk [CRM$L_OFFSET] = .root [CRM$L_OFFSET]; ! May get changed
field_blk [CRM$L_MEMBER_LENGTH] = .root [CRM$L_MEMBER_LENGTH]; ! "
! CRM$L_MEMBER_OFFSET will have to be recomputed.
field_blk [CRM$L_STRING_UNITS] = .root [CRM$L_STRING_UNITS];
field_blk [CRM$A_DIMENSIONS] = .root [CRM$A_DIMENSIONS];
temp = .root [CRM$A_DIMENSIONS];
IF .temp NEQA NULL_PTR
THEN .temp [CRM$A_PREVIOUS] = .field_blk;
field_blk [CRM$L_TOTAL_CELLS] = .root [CRM$L_TOTAL_CELLS];
! No CRM$A_FACILITY needed
field_blk [CRM$W_DATATYPE] = .root [CRM$W_DATATYPE]; ! Must be mapped
field_blk [CRM$W_DIGITS] = .root [CRM$W_DIGITS];
field_blk [CRM$W_MAX_DIGITS] = .root [CRM$W_MAX_DIGITS];
field_blk [CRM$W_SCALE] = .root [CRM$W_SCALE];
field_blk [CRM$B_BASE] = .root [CRM$B_BASE];
field_blk [CRM$V_COLUMN_MAJOR] = .root [CRM$V_COLUMN_MAJOR];
field_blk [CRM$V_STRING_TYPE] = .root [CRM$V_STRING_TYPE];
field_blk [CRM$V_COMPUTE_TYPE] = .root [CRM$V_COMPUTE_TYPE];
field_blk [CRM$V_DEBUG_FLAG] = .root [CRM$V_DEBUG_FLAG];
! CRM$V_FIRST_CHILD does not carry over from COPY template
field_blk [CRM$V_BLANK_WHEN_ZERO] = .root [CRM$V_BLANK_WHEN_ZERO];
field_blk [CRM$V_RIGHT_JUSTIFIED] = .root [CRM$V_RIGHT_JUSTIFIED];
field_blk [CRM$V_SOURCE_TYPE_TRUNC] = .root [CRM$V_SOURCE_TYPE_TRUNC];
field_blk [CRM$V_REFERENCE_TRUNC] = .root [CRM$V_REFERENCE_TRUNC];
field_blk [CRM$V_INITIAL_VALUE_TRUNC] = .root [CRM$V_INITIAL_VALUE_TRUNC];
! CRM$V_FACILITY_USE_n not carried over from COPY template
field_blk [CRM$A_INITIAL_VALUE] = .root [CRM$A_INITIAL_VALUE];
field_blk [CRM$W_INITIAL_LENGTH] = .root [CRM$W_INITIAL_LENGTH];
! Delete the top (root) member node in the COPY template:
$XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_member, .root, FULLWORDS));
! Delete the record node in the COPY template:
$XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_record, .tree, FULLWORDS));
CRX$SIGN_OFF ();
RETURN TRUE;
%FI
END;
!++
! DEAL_WITH_TRANSFORM_NAMES (DWTNMS)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine deals with the field names involved in a transform.
!
! CALLING SEQUENCE:
!
! status = DEAL_WITH_TRANSFORM_NAMES (source_name, source_fqn,
! dest_name, dest_fqn);
!
! PARAMETERS:
!
! source_name String descriptor of source field name
! source_fqn Address to set to fully-qualified-name list of
! source field name
! dest_name String descriptor of destination field name
! dest_fqn Address to set to fully-qualified-name list of
! destination field name
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLIIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! TRUE if OK.
! FALSE if not OK (error message has already been produced).
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE DEAL_WITH_TRANSFORM_NAMES (source_name, source_fqn,
dest_name, dest_fqn) =
BEGIN
MAP
source_name: REF $STR_DESCRIPTOR (),
source_fqn: REF crx_stringlist,
dest_name: REF $STR_DESCRIPTOR (),
dest_fqn: REF crx_stringlist;
LOCAL
status; ! Return status
status = PRODUCE_FQN (.source_name, .source_fqn);
IF NOT .status
THEN BEGIN
FREE_STRINGLIST (.source_fqn);
RETURN FALSE;
END;
status = PRODUCE_FQN (.dest_name, .dest_fqn);
IF NOT .status
THEN BEGIN
FREE_STRINGLIST (.dest_fqn);
RETURN FALSE;
END;
status = VALIDATE_FQN (.source_fqn);
IF NOT .status
THEN BEGIN
FREE_STRINGLIST (.source_fqn);
RETURN FALSE;
END;
status = VALIDATE_FQN (.dest_fqn);
IF NOT .status
THEN FREE_STRINGLIST (.dest_fqn);
RETURN .status;
END;
!++
! DUPLICATE_SUBTREE (DUPDSC)
!
! This routine recursively makes a duplicate copy of a record description
! tree or subtree. It is called by DIU$COPY_DESCRIPTION in PATPOR.BLI,
! which is used by the command driver to make a copy of a record
! description tree.
!
! CALLING SEQUENCE:
!
! status = DUPLICATE_SUBTREE (root, copy, depth, previous);
!
! PARAMETERS:
!
! root is the address of the head node of the record
! description tree or subtree to be duplicated.
! copy is the address of a pointer to be set to the duplicate.
! depth is the recursion depth in this routine. If the
! recursion depth is zero, the routine does not iterate
! on the siblings of the root node of the subtree it is
! working on.
! previous is the address to be placed in the xxx$A_PREVIOUS field
! of the root of the subtree being constructed, or a null
! pointer if none.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! TRUE if copy done, "copy" set
! FALSE if copy failed, "copy" not set
!
! SIDE EFFECTS:
!
! Any previously-existing record description tree or subtree pointed
! to by "copy" is disposed of before the copy is made.
!
!--
GLOBAL ROUTINE DUPLICATE_SUBTREE (root, copy, depth, previous) =
BEGIN
MAP
root: REF crx_record, ! Root of subtree to copy
copy: REF crx_record, ! Root of copy
previous: REF crx_member; ! xxx$A_PREVIOUS field for copy
LOCAL
status: INITIAL (TRUE); ! Return status
IF .root EQLA NULL_PTR
THEN BEGIN
.copy = NULL_PTR; ! Make sure nothing in copy
RETURN TRUE; ! Nothing to do here
END;
SELECTONE .root [CRX$B_ID] OF
SET
[CRX$K_RECORD]: ! CRX_RECORD node
BEGIN
LOCAL
c_member: REF crx_member ! Copy of a crx_member node
INITIAL (NULL_PTR),
c_record: REF crx_record ! Copy of a crx_record node
INITIAL (NULL_PTR);
IF ..copy NEQA NULL_PTR THEN FREE_RECORD (..copy);
$XPO_GET_MEM (FULLWORDS = diu$s_crx_record, RESULT = c_record, FILL = 0);
.copy = .c_record; ! Prepare to return address of structure
status = DUPLICATE_SUBTREE (.root [CRX$A_ROOT], c_member, .depth+1,
.c_record);
c_record [CRX$A_ROOT] = .c_member;
! c_member = NULL_PTR;
c_record [CRX$B_ID] = CRX$K_RECORD;
c_record [CRX$B_CORE_LEVEL] = 4;
$STR_COPY (STRING = 'CDD$RECORD',
TARGET = (10, ch$ptr (c_record [CRX$T_PROTOCOL])));
! CRX$W_FACILITY_CODE not used
! CRX$B_DESCRIPTION_CNT not used
! CRX$A_FACILITY not used
c_record [CRX$L_FORMAT] = .root [CRX$L_FORMAT];
! CRX$A_DESCRIPTION not used
END; ! CRX_RECORD node
[CRX$K_MEMBER]: ! CRX_MEMBER node
BEGIN
LOCAL
c_dimension: REF crx_dimension ! Copy of a crx_dimension node
INITIAL (NULL_PTR),
a_member: REF crx_member ! A crx_member node
INITIAL (NULL_PTR),
c_member: REF crx_member ! Copy of a crx_member node
INITIAL (NULL_PTR),
n_member: REF crx_member ! New crx_member node
INITIAL (NULL_PTR),
p_member: REF crx_member ! Previous crx_member node
INITIAL (NULL_PTR),
c_stringlist: REF crx_stringlist ! Copy of a crx_stringlist node
INITIAL (NULL_PTR);
a_member = .root; ! Get field addressibility
IF ..copy NEQA NULL_PTR THEN FREE_MEMBERS (..copy);
p_member = .previous;
DO BEGIN ! Iterate on CRX_MEMBER siblings
$XPO_GET_MEM (FULLWORDS = diu$s_crx_member, RESULT = c_member,
FILL = 0);
IF .a_member EQLA .root
THEN .copy = .c_member; ! Set root address of copy
c_member [CRM$A_PREVIOUS] = .p_member;
IF NOT .a_member [CRM$V_FIRST_CHILD] AND .depth NEQ 0
THEN p_member [CRM$A_NEXT] = .c_member;
! Our CRM$A_NEXT set later
c_member [CRM$B_ID] = CRX$K_MEMBER;
! CRM$B_DESCRIPTION_CNT not used
c_member [CRM$W_SOURCE_LENGTH] = .a_member [CRM$W_SOURCE_LENGTH];
! CRM$W_REF_LENGTH not used
c_member [CRM$W_CHILDREN_CNT] = .a_member [CRM$W_CHILDREN_CNT];
c_member [CRM$B_TAG_VARIABLE_CNT] =
.a_member [CRM$B_TAG_VARIABLE_CNT];
c_member [CRM$B_DIMENSIONS_CNT] = .a_member [CRM$B_DIMENSIONS_CNT];
c_member [CRM$B_NAME_LENGTH] = .a_member [CRM$B_NAME_LENGTH];
$STR_COPY (STRING = (.a_member [CRM$B_NAME_LENGTH],
ch$ptr (a_member [CRM$T_NAME])),
TARGET = (.c_member [CRM$B_NAME_LENGTH],
ch$ptr (c_member [CRM$T_NAME])) );
! CRM$A_DESCRIPTION not used
$XPO_GET_MEM (CHARACTERS = .c_member [CRM$W_SOURCE_LENGTH],
RESULT = c_member [CRM$A_SOURCE_TYPE]);
$STR_COPY (STRING = (.a_member [CRM$W_SOURCE_LENGTH],
.a_member [CRM$A_SOURCE_TYPE]),
TARGET = (.c_member [CRM$W_SOURCE_LENGTH],
.c_member [CRM$A_SOURCE_TYPE]));
! CRM$A_REFERENCE not used
status = .status AND DUPLICATE_SUBTREE
(.a_member [CRM$A_CHILDREN], n_member, .depth+1, .c_member);
c_member [CRM$A_CHILDREN] = .n_member;
n_member = NULL_PTR;
status = .status AND DUPLICATE_SUBTREE (.a_member [CRM$A_TAG_VARIABLE],
c_stringlist, .depth+1, .c_member);
c_member [CRM$A_TAG_VARIABLE] = .c_stringlist;
c_stringlist = NULL_PTR;
c_member [CRM$L_LENGTH] = .a_member [CRM$L_LENGTH];
c_member [CRM$L_OFFSET] = .a_member [CRM$L_OFFSET];
c_member [CRM$L_MEMBER_LENGTH] = .a_member [CRM$L_MEMBER_LENGTH];
c_member [CRM$L_MEMBER_OFFSET] = .a_member [CRM$L_MEMBER_OFFSET];
c_member [CRM$L_STRING_UNITS] = .a_member [CRM$L_STRING_UNITS];
status = .status AND DUPLICATE_SUBTREE (.a_member [CRM$A_DIMENSIONS],
c_dimension, .depth+1, .c_member);
c_member [CRM$A_DIMENSIONS] = .c_dimension;
c_dimension = NULL_PTR;
c_member [CRM$L_TOTAL_CELLS] = .a_member [CRM$L_TOTAL_CELLS];
IF .a_member [CRM$A_FACILITY] NEQA NULL_PTR
THEN BEGIN ! Copy CRM$A_FACILITY
LOCAL
a_facility: REF crx_additional ! A crx_additional node
INITIAL (NULL_PTR),
c_facility: REF crx_additional ! Copy of crx_additional
INITIAL (NULL_PTR);
a_facility = .a_member [CRM$A_FACILITY]; ! Get addressability
$XPO_GET_MEM (FULLWORDS = cra$s_crx_additional, RESULT = c_facility,
FILL = 0);
c_member [CRM$A_FACILITY] = .c_facility;
c_facility [CRA$L_LOCATOR] = .a_facility [CRA$L_LOCATOR];
c_facility [CRA$L_TYPE] = .a_facility [CRA$L_TYPE];
! CRA$L_MAX_MEMBER_LENGTH not needed
c_facility [CRA$L_INITIAL_TYPE] = .a_facility [CRA$L_INITIAL_TYPE];
c_facility [CRA$L_INITIAL_TYPE_1] =
.a_facility [CRA$L_INITIAL_TYPE_1];
c_facility [CRA$L_INITIAL_TYPE_2] =
.a_facility [CRA$L_INITIAL_TYPE_2];
c_facility [CRA$L_INITIAL_LENGTH_1] =
.a_facility [CRA$L_INITIAL_LENGTH_1];
c_facility [CRA$V_ALIGNMENT_EXISTS] =
.a_facility [CRA$V_ALIGNMENT_EXISTS];
c_facility [CRA$V_LENGTH_SET] = .a_facility [CRA$V_LENGTH_SET];
c_facility [CRA$V_OFFSET_SET] = .a_facility [CRA$V_OFFSET_SET];
c_facility [CRA$V_DIMENSION] = .a_facility [CRA$V_DIMENSION];
c_facility [CRA$V_SYNC_LEFT] = .a_facility [CRA$V_SYNC_LEFT];
c_facility [CRA$V_SYNC_RIGHT] = .a_facility [CRA$V_SYNC_RIGHT];
END; ! Copy CRM$A_FACILITY
c_member [CRM$W_DATATYPE] = .a_member [CRM$W_DATATYPE];
c_member [CRM$W_DIGITS] = .a_member [CRM$W_DIGITS];
c_member [CRM$W_MAX_DIGITS] = .a_member [CRM$W_MAX_DIGITS];
c_member [CRM$W_SCALE] = .a_member [CRM$W_SCALE];
c_member [CRM$B_BASE] = .a_member [CRM$B_BASE];
c_member [CRM$V_COLUMN_MAJOR] = .a_member [CRM$V_COLUMN_MAJOR];
c_member [CRM$V_STRING_TYPE] = .a_member [CRM$V_STRING_TYPE];
c_member [CRM$V_COMPUTE_TYPE] = .a_member [CRM$V_COMPUTE_TYPE];
c_member [CRM$V_DEBUG_FLAG] = .a_member [CRM$V_DEBUG_FLAG];
c_member [CRM$V_FIRST_CHILD] = .a_member [CRM$V_FIRST_CHILD];
! CRM$V_BLANK_WHEN_ZERO not used
c_member [CRM$V_RIGHT_JUSTIFIED] = .a_member [CRM$V_RIGHT_JUSTIFIED];
c_member [CRM$V_SOURCE_TYPE_TRUNC] =
.a_member [CRM$V_SOURCE_TYPE_TRUNC];
! CRM$V_REFERENCE_TRUNC not used
c_member [CRM$V_INITIAL_VALUE_TRUNC] =
.a_member [CRM$V_INITIAL_VALUE_TRUNC];
! CRM$V_FACILITY_USE_1 not needed here
! CRM$V_FACILITY_USE_2 not duplicated
c_member [CRM$V_FACILITY_USE_3] = .a_member [CRM$V_FACILITY_USE_3];
! CRM$V_FACILITY_USE_4 not used
c_member [CRM$V_FACILITY_USE_5] = .a_member [CRM$V_FACILITY_USE_5];
c_member [CRM$W_INITIAL_LENGTH] = .a_member [CRM$W_INITIAL_LENGTH];
IF NOT .a_member [CRM$V_FACILITY_USE_3]
THEN BEGIN ! Initial value in characters
$XPO_GET_MEM (CHARACTERS = .c_member [CRM$W_INITIAL_LENGTH],
RESULT = c_member [CRM$A_INITIAL_VALUE]);
$STR_COPY (STRING = (.a_member [CRM$W_INITIAL_LENGTH],
.a_member [CRM$A_INITIAL_VALUE]),
TARGET = (.c_member [CRM$W_INITIAL_LENGTH],
.c_member [CRM$A_INITIAL_VALUE]));
END ! Initial value in characters
ELSE BEGIN ! In words - suspicious!
$XPO_GET_MEM (FULLWORDS = .c_member [CRM$W_INITIAL_LENGTH],
RESULT = c_member [CRM$A_INITIAL_VALUE]);
CH$MOVE (.c_member [CRM$W_INITIAL_LENGTH] * %upval,
CH$PTR (.a_member [CRM$A_INITIAL_VALUE], 0, %BPUNIT),
CH$PTR (.c_member [CRM$A_INITIAL_VALUE], 0, %BPUNIT));
END; ! In words - suspicious!
p_member = .c_member;
a_member = .a_member [CRM$A_NEXT];
END UNTIL (.a_member EQLA NULL_PTR OR .depth EQL 0)
END; ! CRX_MEMBER node
[CRX$K_OVERLAY]: ! CRX_OVERLAY node
BEGIN
LOCAL
c_literal_list: REF crx_literal_list ! Copy of a crx_literal_list
INITIAL (NULL_PTR),
c_member: REF crx_member ! Copy of a crx_member node
INITIAL (NULL_PTR),
a_overlay: REF crx_overlay ! A crx_overlay node
INITIAL (NULL_PTR),
c_overlay: REF crx_overlay ! Copy of a crx_overlay node
INITIAL (NULL_PTR),
p_overlay: REF crx_overlay ! Previous crx_overlay node
INITIAL (NULL_PTR),
first: INITIAL (TRUE); ! First child flag
a_overlay = .root; ! Get field addressability
IF ..copy NEQA NULL_PTR THEN FREE_MEMBERS (..copy);
p_overlay = .previous;
DO BEGIN ! Iterate on CRX_OVERLAY siblings
$XPO_GET_MEM (FULLWORDS = diu$s_crx_overlay, RESULT = c_overlay,
FILL = 0);
IF .a_overlay EQLA .root
THEN .copy = .c_overlay; ! Set root address of copy
c_overlay [CRO$A_PREVIOUS] = .p_overlay;
IF .first
THEN first = FALSE
ELSE p_overlay [CRO$A_NEXT] = .c_overlay;
! Our CRO$A_NEXT set later
c_overlay [CRO$B_ID] = CRX$K_OVERLAY;
c_overlay [CRO$W_FIELDS_CNT] = .a_overlay [CRO$W_FIELDS_CNT];
status = .status AND DUPLICATE_SUBTREE (.a_overlay [CRO$A_FIELDS],
c_member, .depth+1, .c_overlay);
c_overlay [CRO$A_FIELDS] = .c_member;
c_member = NULL_PTR;
c_overlay [CRO$L_MAX_LENGTH] = .a_overlay [CRO$L_MAX_LENGTH];
c_overlay [CRO$L_MIN_OFFSET] = .a_overlay [CRO$L_MIN_OFFSET];
c_overlay [CRO$L_MAX_MEMBER_LENGTH] =
.a_overlay [CRO$L_MAX_MEMBER_LENGTH];
c_overlay [CRO$L_MIN_MEMBER_OFFSET] =
.a_overlay [CRO$L_MIN_MEMBER_OFFSET];
status = .status AND DUPLICATE_SUBTREE (.a_overlay [CRO$A_TAG_VALUES],
c_literal_list, .depth+1, .c_overlay);
c_overlay [CRO$A_TAG_VALUES] = .c_literal_list;
c_literal_list = NULL_PTR;
c_overlay [CRO$W_TAG_VALUES_CNT] =
.a_overlay [CRO$W_TAG_VALUES_CNT];
c_overlay [CRO$L_TOTAL_LENGTH] = .a_overlay [CRO$L_TOTAL_LENGTH];
p_overlay = .c_overlay;
a_overlay = .a_overlay [CRO$A_NEXT];
END UNTIL (.a_overlay EQLA NULL_PTR OR .depth EQL 0)
END; ! CRX_OVERLAY node
[CRX$K_DIMENSION]: ! CRX_DIMENSION node
BEGIN
LOCAL
a_dimension: REF crx_dimension ! A crx_dimension node
INITIAL (NULL_PTR),
c_dimension: REF crx_dimension ! Copy of a crx_dimension node
INITIAL (NULL_PTR),
p_dimension: REF crx_dimension ! Previous crx_dimension node
INITIAL (NULL_PTR),
c_stringlist: REF crx_stringlist ! Copy of a crx_stringlist node
INITIAL (NULL_PTR),
first: INITIAL (TRUE); ! First sibling flag
a_dimension = .root; ! Get field addressability
IF ..copy NEQA NULL_PTR THEN FREE_DIMENSIONS (..copy);
p_dimension = .previous;
DO BEGIN ! Iterate on CRX_DIMENSION siblings
$XPO_GET_MEM (FULLWORDS = diu$s_crx_dimension, RESULT = c_dimension,
FILL = 0);
IF .a_dimension EQLA .root
THEN .copy = .c_dimension; ! Set root address of copy
c_dimension [CRD$A_PREVIOUS] = .p_dimension;
IF .first
THEN first = FALSE
ELSE p_dimension [CRD$A_NEXT] = .c_dimension;
! Our CRD$A_NEXT set later
c_dimension [CRD$B_ID] = CRX$K_DIMENSION;
c_dimension [CRD$B_DEPEND_ITEM_CNT] =
.a_dimension [CRD$B_DEPEND_ITEM_CNT];
c_dimension [CRD$L_LOWER_BOUND] = .a_dimension [CRD$L_LOWER_BOUND];
c_dimension [CRD$L_UPPER_BOUND] = .a_dimension [CRD$L_UPPER_BOUND];
c_dimension [CRD$L_STRIDE] = .a_dimension [CRD$L_STRIDE];
status = .status AND DUPLICATE_SUBTREE
(.a_dimension [CRD$A_DEPEND_ITEM],
c_stringlist, .depth+1, .c_dimension);
c_dimension [CRD$A_DEPEND_ITEM] = .c_stringlist;
c_stringlist = NULL_PTR;
c_dimension [CRD$L_MIN_OCCURS] = .a_dimension [CRD$L_MIN_OCCURS];
c_dimension [CRD$V_LOWER_BOUND_FL] =
.a_dimension [CRD$V_LOWER_BOUND_FL];
c_dimension [CRD$V_UPPER_BOUND_FL] =
.a_dimension [CRD$V_UPPER_BOUND_FL];
c_dimension [CRD$V_STRIDE_FL] = .a_dimension [CRD$V_STRIDE_FL];
c_dimension [CRD$V_MIN_OCCURS_FL] =
.a_dimension [CRD$V_MIN_OCCURS_FL];
p_dimension = .c_dimension;
a_dimension = .a_dimension [CRD$A_NEXT];
END UNTIL (.a_dimension EQLA NULL_PTR OR .depth EQL 0)
END; ! CRX_DIMENSION node
[CRX$K_STRINGLIST]: ! CRX_STRINGLIST node
BEGIN
LOCAL
a_stringlist: REF crx_stringlist ! A crx_stringlist node
INITIAL (NULL_PTR),
c_stringlist: REF crx_stringlist ! Copy of a crx_stringlist node
INITIAL (NULL_PTR),
p_stringlist: REF crx_stringlist ! Previous crx_stringlist node
INITIAL (NULL_PTR),
first: INITIAL (TRUE); ! First sibling flag
a_stringlist = .root; ! Get field addressability
IF ..copy NEQA NULL_PTR THEN FREE_STRINGLIST (..copy);
p_stringlist = .previous;
DO BEGIN ! Iterate on CRX_STRINGLIST siblings
$XPO_GET_MEM (FULLWORDS = diu$s_crx_stringlist, RESULT = c_stringlist,
FILL = 0);
IF .a_stringlist EQLA .root
THEN .copy = .c_stringlist; ! Set root address of copy
c_stringlist [CRS$A_PREVIOUS] = .p_stringlist;
IF .first
THEN first = FALSE
ELSE p_stringlist [CRS$A_NEXT] = .c_stringlist;
! Our CRS$A_NEXT set later
INIT_STRINGLIST (.c_stringlist); ! Sets CRS$B_ID
c_stringlist [CRS$V_STRING_TRUNC] = .a_stringlist [CRS$V_STRING_TRUNC];
c_stringlist [CRS$V_BINARY_STRING] =
.a_stringlist [CRS$V_BINARY_STRING];
c_stringlist [CRS$W_STRING_LENGTH] =
.a_stringlist [CRS$W_STRING_LENGTH];
$XPO_GET_MEM (CHARACTERS = .c_stringlist [CRS$W_STRING_LENGTH],
RESULT = c_stringlist [CRS$A_STRING]);
$STR_COPY (STRING = (.a_stringlist [CRS$W_STRING_LENGTH],
.a_stringlist [CRS$A_STRING]),
TARGET = (.c_stringlist [CRS$W_STRING_LENGTH],
.c_stringlist [CRS$A_STRING]));
p_stringlist = .c_stringlist;
a_stringlist = .a_stringlist [CRS$A_NEXT];
END UNTIL (.a_stringlist EQLA NULL_PTR OR .depth EQL 0)
END; ! CRX_STRINGLIST node
[CRX$K_PLI_SPECIFIC]:; ! Not copied
[CRX$K_LITERAL_LIST]: ! CRX_LITERAL_LIST node
BEGIN
LOCAL
a_literal_list: REF crx_literal_list ! A crx_literal_list node
INITIAL (NULL_PTR),
c_literal_list: REF crx_literal_list ! Copy of a crx_literal_list
INITIAL (NULL_PTR),
p_literal_list: REF crx_literal_list ! Previous crx_literal_list node
INITIAL (NULL_PTR),
c_stringlist: REF crx_stringlist ! Copy of a crx_stringlist node
INITIAL (NULL_PTR),
first: INITIAL (TRUE); ! First sibling flag
a_literal_list = .root; ! Get field addressability
IF ..copy NEQA NULL_PTR THEN FREE_LITLIST (..copy);
p_literal_list = .previous;
DO BEGIN ! Iterate on CRX_LITERAL_LIST siblings
$XPO_GET_MEM (FULLWORDS = diu$s_crx_literal_list,
RESULT = c_literal_list, FILL = 0);
IF .a_literal_list EQLA .root
THEN .copy = .c_literal_list; ! Set root address of copy
c_literal_list [CRL$A_PREVIOUS] = .p_literal_list;
IF .first
THEN first = FALSE
ELSE p_literal_list [CRL$A_NEXT] = .c_literal_list;
! Our CRL$A_NEXT set later
INIT_LITERAL (.c_literal_list); ! Sets CRL$B_ID
c_literal_list [CRL$W_LITERALS_CNT] =
.a_literal_list [CRL$W_LITERALS_CNT];
status = .status AND DUPLICATE_SUBTREE
(.a_literal_list [CRL$A_LITERALS],
c_stringlist, .depth+1, .c_literal_list);
c_literal_list [CRL$A_LITERALS] = .c_stringlist;
c_stringlist = NULL_PTR;
p_literal_list = .c_literal_list;
a_literal_list = .a_literal_list [CRL$A_NEXT];
END UNTIL (.a_literal_list EQLA NULL_PTR OR .depth EQL 0)
END; ! CRX_LITERAL_LIST node
[CRX$K_TAG_FFD]: ! Tag FFD node
BEGIN ! Copying one of these is VERY suspicious!!
LOCAL
a_tag_ffd: REF crx_tag_ffd, ! A tag FFD node
c_tag_ffd: REF crx_tag_ffd; ! Copy of a tag FFD node
a_tag_ffd = .root; ! Get field addressability
IF ..copy NEQA NULL_PTR THEN FREE_STRINGLIST (..copy);
$XPO_GET_MEM (FULLWORDS = diu$s_crx_tag_ffd, RESULT = c_tag_ffd,
FILL = 0);
.copy = .c_tag_ffd;
c_tag_ffd [CRT$A_PREVIOUS] = .previous;
! CRT$A_NEXT always NULL_PTR
c_tag_ffd [CRT$B_ID] = CRX$K_TAG_FFD;
c_tag_ffd [CRT$V_SUSPICIOUS_TAG] = TRUE; ! VERY suspicious!!
! Leave the FFD blank; it can't be any good anyways!!
END; ! Tag FFD node
TES;
RETURN .status;
END;
!++
! FIND_DATATYPE (FNDTYP)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine returns the DIL datatype for a field. If the field has
! none (for example, a structure), it will return the datatype pf the
! first child of the field found by a depth-first search which has a
! datatype, the datatype of the smallest encompassing structure that
! has a datatype, or SIXBIT (TOPS-20) or ASCII_8 (VMS/PRO), if it reaches
! the top record node without finding a datatype.
!
! CALLING SEQUENCE:
!
! data_type = FIND_DATATYPE (field_blk, sys_org);
!
! PARAMETERS:
!
! field_blk Address of the member block in question
! sys_org System of origin code (sys_lcg or sys_8bit/sys_pro)
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! Returns the DIL datatype for the field.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE FIND_DATATYPE (field_blk, sys_org) =
BEGIN
MAP
field_blk: REF crx_member;
LOCAL
current_member: REF crx_member,
current_parent: REF crx_member,
datatype;
! If field has a datatype, return it:
IF (.field_blk [CRM$W_DATATYPE] NEQ DIU$K_DT_OVERLAY) AND
(.field_blk [CRM$W_DATATYPE] NEQ DIU$K_DT_STRUCTURE)
THEN RETURN .field_blk [CRM$W_DATATYPE];
! Try a depth-first search of the field's children looking for a usable
! datatype:
datatype = FIND_DATATYPE_WALKER (.field_blk, 0);
IF .datatype NEQ 0
THEN RETURN .datatype;
! Look for an encompassing structure with a datatype, and return that:
current_member = .field_blk;
current_parent = .field_blk [CRM$A_PREVIOUS];
WHILE TRUE DO BEGIN
IF (.current_parent [CRM$B_ID] NEQ CRX$K_RECORD)
THEN WHILE (.current_parent [CRM$A_CHILDREN] NEQ .current_member)
DO BEGIN ! Still in sibling group
current_member = .current_parent;
current_parent = .current_member [CRM$A_PREVIOUS];
END;
! Found parent or the top record node:
IF .current_parent [CRM$B_ID] EQL CRX$K_RECORD
THEN IF .sys_org EQL sys_lcg
THEN RETURN DIX$K_DT_SIXBIT
ELSE RETURN DIX$K_DT_ASCII_8;
! Not the record node yet. If this structure has a datatype, return that.
IF .current_parent [CRM$W_DATATYPE] NEQ 0
THEN RETURN .current_parent [CRM$W_DATATYPE];
! Try next higher encompassing structure.
current_member = .current_parent;
current_parent = .current_member [CRM$A_PREVIOUS];
END
END;
!++
! FIND_DATATYPE_WALKER (FNDTYW)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine is called by FIND_DATATYPE to find the datatype of the
! first child of the field in question found by a depth-first search,
! if there is one. Otherwise it will return 0.
!
! CALLING SEQUENCE:
!
! status = FIND_DATATYPE_WALKER (field_blk, depth);
!
! PARAMETERS:
!
! field_blk Address of the member block in question
! depth Recursion depth
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! Returns the datatype if there is one.
! Returns zero otherwise.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
ROUTINE FIND_DATATYPE_WALKER (field_blk, depth) =
BEGIN
MAP
field_blk: REF crx_member; ! Member block in question
LOCAL
current_member: REF crx_member, ! Current member block
datatype; ! Datatype in recursive call, or zero
IF .field_blk [CRM$B_ID] NEQ CRX$K_MEMBER
THEN RETURN 0;
current_member = .field_blk;
WHILE (.current_member NEQA NULL_PTR) DO
BEGIN
IF .current_member [CRM$W_DATATYPE] NEQ DIU$K_DT_OVERLAY
AND .current_member [CRM$W_DATATYPE] NEQ DIU$K_DT_STRUCTURE
THEN RETURN .current_member [CRM$W_DATATYPE];
IF .current_member [CRM$A_ChILDREN] NEQA NULL_PTR
THEN BEGIN
datatype = FIND_DATATYPE_WALKER
(.current_member [CRM$A_CHILDREN], .depth+1);
IF .datatype NEQ 0
THEN RETURN .datatype;
END;
IF (.depth NEQ 0)
THEN current_member = .current_member [CRM$A_NEXT]
ELSE RETURN 0;
END;
RETURN 0;
END;
!++
! DIU$FIND_FIELD (FNDFLD)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine finds a field's member block without collecting any
! auxillary information.
!
! CALLING SEQUENCE:
!
! status = DIU$FIND_FIELD (fqn, root, member);
!
! PARAMETERS:
!
! fqn Fully-qualified name list of field to find
! root Root of tree to look for matching member block in
! member Set to address of matching member block, if any
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! TRUE if OK, "member" is set up
! FALSE if not OK, "member" is not set up
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE DIU$FIND_FIELD (fqn, root, member) =
BEGIN
MAP
fqn: REF crx_stringlist, ! Fully-qualified name to find
root: REF crx_member, ! Root of tree to look in
member: REF crx_member; ! Member block found
RETURN FIND_MATCHING_MEMBER (.fqn, .root, .member, 0);
END;
!++
! FIND_MATCHING_MEMBER (FNDMTC)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine finds a member block matching a fully-qualified-name list.
!
! CALLING SEQUENCE:
!
! status = FIND_MATCHING_MEMBER (fqn, root, member, dim);
!
! PARAMETERS:
!
! fqn Fully-qualified-name list of field to find
! root Root of tree to look for matching member block in
! member Set to address of matching member block, if any
! dim Set to address of dimension list for matching member
! unless a null pointer is passed
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! True if OK, member and dim are set up.
! False if not OK, member and dim are not set up.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE FIND_MATCHING_MEMBER (fqn, root, member, dim) =
BEGIN
MAP
fqn: REF crx_stringlist, ! Fully-qualified name to find
root: REF crx_member, ! Root of tree to look in
member: REF crx_member, ! Member block found
dim: REF dims; ! Dimension list
LOCAL
last_dims: REF dims
INITIAL (NULL_PTR), ! Last dims node in list
new_dims: REF dims
INITIAL (NULL_PTR), ! New dims node
new_root: REF crx_member, ! Sibling of 'root'
status; ! Return status
! If the tree to search is null, this path has failed.
IF .root EQLA NULL_PTR
THEN RETURN FALSE;
! Determine what to try based on what type of node is at the root.
! Legitimate roots here are records, members, and overlays.
SELECTONE .root [CRM$B_ID] OF
SET
[CRX$K_RECORD]: ! Record root:
BEGIN ! Recurse on the subtree of members
LOCAL record_node: REF crx_record;
record_node = .root;
status = FIND_MATCHING_MEMBER (.fqn, .record_node [CRX$A_ROOT],
.member, .dim);
RETURN .status;
END; ! Record root
[CRX$K_OVERLAY]: ! Variant:
BEGIN ! Recurse on the subtree of members
LOCAL overlay_node: REF crx_overlay;
overlay_node = .root;
WHILE (.overlay_node NEQA NULL_PTR)
DO BEGIN ! Loop to try subtrees of overlays
status = FIND_MATCHING_MEMBER (.fqn, .overlay_node [CRO$A_FIELDS],
.member, .dim);
IF .status
THEN RETURN TRUE; ! Found it!
overlay_node = .overlay_node [CRO$A_NEXT];
END; ! Loop to try subtrees of overlays
RETURN FALSE; ! Does not match here
END; ! Variant
[CRX$K_MEMBER]: ! Member node:
BEGIN
new_root = .root;
WHILE (.new_root NEQA NULL_PTR)
DO BEGIN ! Try siblings at this level
! Save the dimension list, if any, in case this path obtains.
! If this path fails, back out the dimension list if necessary.
IF (.new_root [CRM$B_DIMENSIONS_CNT] GTR 0)
AND (.DIM NEQA NULL_PTR)
THEN BEGIN ! Has dimensions and we want them
MAKE_DIMS (new_dims, .new_root);
IF ..dim EQLA NULL_PTR
THEN .dim = .new_dims
ELSE BEGIN ! Add to list
last_dims = ..dim;
WHILE (.last_dims [DIMS$A_NEXT] NEQA NULL_PTR)
DO last_dims = .last_dims [DIMS$A_NEXT];
last_dims [DIMS$A_NEXT] = .new_dims;
new_dims [DIMS$A_PREVIOUS] = .last_dims;
END; ! Add to list
END; ! Has dimensions
! See if we have a match so far:
IF (.new_root [CRM$B_NAME_LENGTH] EQL .fqn [CRS$W_STRING_LENGTH])
AND CH$EQL (.new_root [CRM$B_NAME_LENGTH],
CH$PTR (new_root [CRM$T_NAME]),
.fqn [CRS$W_STRING_LENGTH], .fqn [CRS$A_STRING], %C' ')
THEN ! Found a match so far
IF .fqn [CRS$A_NEXT] NEQA NULL_PTR
THEN BEGIN ! More to go, recurse on children
status = FIND_MATCHING_MEMBER (.fqn [CRS$A_NEXT],
.new_root [CRM$A_CHILDREN], .member, .dim);
RETURN .status;
END
ELSE BEGIN ! No more names, found it!
.member = .new_root;
RETURN TRUE;
END;
! Did not match so far. Try children - incomplete name?
status = FIND_MATCHING_MEMBER (.fqn, .new_root [CRM$A_CHILDREN],
.member, .dim);
IF .status
THEN RETURN TRUE; ! Found it
! Not below here in the tree, so try next sibling.
! Back out dims here, if necessary.
IF (.new_root [CRM$B_DIMENSIONS_CNT] NEQ 0) AND
(.DIM NEQA NULL_PTR)
THEN BEGIN ! Has dimensions and we want them
IF ..dim EQLA .new_dims
THEN .dim = NULL_PTR
ELSE BEGIN ! Find last dims node
last_dims = ..dim;
new_dims = .last_dims [DIMS$A_NEXT];
WHILE .new_dims [DIMS$A_NEXT] NEQA NULL_PTR
DO BEGIN ! Walk dims nodes
last_dims = .new_dims;
new_dims = .new_dims [DIMS$A_NEXT];
END; ! Walk dims nodes
last_dims = .new_dims [DIMS$A_PREVIOUS];
last_dims [DIMS$A_NEXT] = NULL_PTR;
END; ! Find last dims node
DIU$DEL_DIMS (.new_dims);
END; ! Has dimensions
new_root = .new_root [CRM$A_NEXT];
END; ! Loop to try siblings at this level
RETURN FALSE; ! No match anywhere
END; ! Member node
[OTHERWISE]: ! Something else?!
RETURN FALSE;
TES;
END;
!++
! FIND_NAMES_IN_TREES (FNDNAM)
!
! FUNCTIONAL DESCRIPTION:
!
! Looks up source fully-qualified-name list in the source record
! description tree and the destination fully-qualified-name list in the
! destination record description tree and returns the addresses of the
! member blocks thus found.
!
! CALLING SEQUENCE:
!
! status = FIND_NAMES_IN_TREES (source_fqn, source_root, dest_fqn,
! dest_root, dest_root, source_member, dest_member,
! source_dim, dest_dim);
!
! PARAMETERS:
!
! source_fqn Source field fully-qualified-name list
! source_root Root of source record description tree
! dest_fqn Destination field fully-qualified-name list
! dest_root Root of destination record description tree
! source_member Set to address of the matching source member block
! dest_member Set to address of the matching destination member block
! source_dim Set to the source dimension list
! dest_dim Set to the destination dimension list
!
! IMPLICIT INPUTS:
!
! PAT$TOKEN_CURRENT_PTR Pointer to current lexical token.
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! TRUE if OK.
! FALSE if not OK.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE FIND_NAMES_IN_TREES (source_fqn, source_root, dest_fqn,
dest_root, source_member, dest_member, source_dim, dest_dim) =
BEGIN
MAP
source_root: REF crx_member, ! Source tree
dest_root: REF crx_member, ! Destination tree
source_member: REF crx_member, ! Source member block
dest_member: REF crx_member; ! Destination member block
LOCAL
status; ! Return status
status = FIND_MATCHING_MEMBER (.source_fqn, .source_root, .source_member,
.source_dim);
IF NOT .status
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Field name not found in source record description');
DIU$DEL_DIMS (..source_dim);
FREE_STRINGLIST (..source_fqn);
RETURN FALSE;
END;
status = FIND_MATCHING_MEMBER (.dest_fqn, .dest_root, .dest_member, .dest_dim);
IF NOT .status
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Field name not found in destination record description');
DIU$DEL_DIMS (..source_dim);
DIU$DEL_DIMS (..dest_dim);
FREE_STRINGLIST (..source_fqn);
FREE_STRINGLIST (..dest_fqn);
RETURN FALSE;
END;
RETURN TRUE;
END;
!++
! FIX_COPY_TEMPLATE (FIXCPY)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine maps the datatypes in a COPY template copied from CDD-32
! to DIL datatypes. It may need to be modified in order to map the
! datatypes in a COPY template copied from DTR-20.
!
! CALLING SEQUENCE:
!
! FIX_COPY_TEMPLATE (member, level);
!
! INPUT PARAMETERS:
!
! member Address of member block at root of COPY template
! level Level, measured from COPY template root, of member
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! The datatypes of "member" and all subordinate nodes are mapped from
! CDD-32 (or DTR-20) to DIL datatypes.
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE FIX_COPY_TEMPLATE (member, level) : NOVALUE =
BEGIN
MAP
member: REF crx_member;
%IF %BLISS (BLISS32) %THEN
! Might as well not have this here for BLISS36 until we support DTR-20 templates
LOCAL
current_member: REF crx_member,
current_overlay: REF crx_overlay,
new_datatype;
EXTERNAL ROUTINE
DIU$MAP_DATATYPES;
LITERAL this_sys = %BLISS36 (sys_lcg) %BLISS32 (sys_8bit);
LITERAL this_src = %BLISS36 (dtr20_src) %BLISS32 (cdd32_src);
IF .member EQLA NULL_PTR
THEN RETURN; ! Nothing to do...
IF .member [CRM$B_ID] EQL CRX$K_MEMBER
THEN BEGIN ! Member node (may be at level 0)
current_member = .member;
DO BEGIN
IF .current_member [CRM$W_DATATYPE] NEQ 0
THEN BEGIN ! It has a datatype, so map it
new_datatype = DIU$MAP_DATATYPES (this_sys,
.current_member [CRM$W_DATATYPE], default_typ,
this_src, FALSE);
current_member [CRM$W_DATATYPE] = .new_datatype;
END;
! Indicate that we have mapped the datatype:
current_member [CRM$V_FACILITY_USE_5] = DIL_SRC;
FIX_COPY_TEMPLATE (.current_member [CRM$A_CHILDREN], .level+1);
IF .level EQL 0 ! Do NOT iterate on siblings of template root
THEN RETURN;
current_member = .current_member [CRM$A_NEXT]; ! Iterate
END UNTIL .current_member EQLA NULL_PTR;
END
ELSE BEGIN ! Overlay node (cannot be at level 0)
current_overlay = .member;
DO BEGIN ! Do member nodes below each overlay
FIX_COPY_TEMPLATE (.current_overlay [CRO$A_FIELDS], .level+1);
current_overlay = .current_overlay [CRO$A_NEXT];
END UNTIL .current_overlay EQLA NULL_PTR;
END;
%FI
RETURN;
END;
!++
! FIX_VARIANTS (FIXVAR)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine converts fields marked as FLD$K_VARIANT into
! crx_overlay nodes.
! This cannot be done earlier because the facility_use_1 flag and the
! additional_block are needed to create the tree structure (see code in
! DEFINE_FIELD and END_SET).
!
! CALLING SEQUENCE:
!
! FIX_VARIANTS (member);
!
! INPUT PARAMETERS:
!
! member Address of member node
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE FIX_VARIANTS (member: VOLATILE REF crx_member): NOVALUE =
BEGIN
! Could already have an overlay node here as the result of a COPY.
IF .member [CRM$B_ID] EQL CRX$K_OVERLAY
THEN RETURN
ELSE BEGIN ! A member node
BIND
ADDITIONAL_BLK = .MEMBER [crm$a_facility]: crx_additional;
LOCAL
TEMP_LITLIST : REF crx_literal_list,
OVERLAY_NODE : REF crx_overlay,
TEMP_NODE : REF crx_member;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called FIX_VARIANTS'));
IF .MEMBER [crm$a_next] NEQA NULL_PTR
THEN FIX_VARIANTS (.MEMBER [crm$a_next]);
IF .MEMBER [crm$a_children] NEQA NULL_PTR
THEN FIX_VARIANTS (.MEMBER [crm$a_children]);
IF additional_blk eqla NULL_PTR ! Must have been a COPY template...
THEN RETURN; ! so nothing to do here
IF .ADDITIONAL_BLK [cra$l_type] EQL FLD$K_VARIANT
THEN BEGIN ! Member should become overlay
$XPO_GET_MEM (FULLWORDS = diu$s_crx_overlay, RESULT = OVERLAY_NODE,
FILL = 0);
OVERLAY_NODE [cro$b_id] = CRX$K_OVERLAY;
OVERLAY_NODE [cro$a_previous] = .MEMBER [crm$a_previous];
TEMP_NODE = .MEMBER [crm$a_previous];
IF .TEMP_NODE NEQA NULL_PTR
THEN IF .TEMP_NODE [crm$a_next] eqla .MEMBER
THEN TEMP_NODE [crm$a_next] = .OVERLAY_NODE;
IF .TEMP_NODE NEQA NULL_PTR
THEN IF .TEMP_NODE [crm$a_children] EQLA .MEMBER
THEN TEMP_NODE [crm$a_children] = .OVERLAY_NODE;
OVERLAY_NODE [cro$a_next] = .MEMBER [crm$a_next];
TEMP_NODE = .MEMBER [crm$a_next];
IF .TEMP_NODE NEQA NULL_PTR
THEN IF .TEMP_NODE [crm$a_previous] EQLA .MEMBER
THEN TEMP_NODE [crm$a_previous] = .OVERLAY_NODE;
OVERLAY_NODE [cro$w_fields_cnt] = .MEMBER [crm$w_children_cnt];
OVERLAY_NODE [cro$a_fields] = .MEMBER [crm$a_children];
TEMP_NODE = .MEMBER [crm$a_children];
IF .TEMP_NODE [crm$a_previous] EQLA .MEMBER
THEN TEMP_NODE [crm$a_previous] = .OVERLAY_NODE;
OVERLAY_NODE [cro$l_max_length] = .MEMBER [crm$l_length];
OVERLAY_NODE [cro$l_min_offset] = .MEMBER [crm$l_offset];
OVERLAY_NODE [cro$l_max_member_length] =
.ADDITIONAL_BLK [cra$l_max_member_length];
OVERLAY_NODE [cro$l_min_member_offset] =
.MEMBER [crm$l_member_offset];
OVERLAY_NODE [cro$a_tag_values] = .MEMBER [crm$a_tag_variable];
TEMP_LITLIST = .MEMBER [crm$a_tag_variable];
IF .TEMP_LITLIST NEQA NULL_PTR
THEN IF .TEMP_LITLIST [crl$a_previous] EQLA .MEMBER
THEN TEMP_LITLIST [crl$a_previous] = .OVERLAY_NODE;
IF .TEMP_LITLIST NEQA NULL_PTR
THEN OVERLAY_NODE [cro$w_tag_values_cnt] = 1;
OVERLAY_NODE [cro$l_total_length] = .MEMBER [crm$l_member_length];
$XPO_FREE_MEM (BINARY_DATA =
(cra$s_crx_additional, ADDITIONAL_BLK, FULLWORDS));
$XPO_FREE_MEM (BINARY_DATA =
(diu$s_crx_member, .MEMBER, FULLWORDS));
END;
END; ! Else clause for member nodes
END;
!++
! FREE_DIMENSIONS (FREDIM)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine frees a list of dimension blocks.
!
! CALLING SEQUENCE:
!
! FREE_DIMENSIONS (dimension);
!
! INPUT PARAMETERS:
!
! dimension Address of a list of crx_dimension nodes
!
! IMPLICIT INPUTS:
!
! none
!
! IMPLICIT OUTPUTS:
!
! none
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
GLOBAL ROUTINE FREE_DIMENSIONS (dimension) : NOVALUE =
BEGIN
MAP
DIMENSION: REF CRX_DIMENSION;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called FREE_DIMENSIONS'));
IF .DIMENSION [crd$a_next] NEQA NULL_PTR
THEN FREE_DIMENSIONS (.DIMENSION [crd$a_next]);
IF .DIMENSION [crd$a_depend_item] NEQA NULL_PTR
THEN FREE_STRINGLIST (.DIMENSION [crd$a_depend_item]);
$XPO_FREE_MEM (BINARY_DATA = (diu$S_CRX_DIMENSION, .DIMENSION, FULLWORDS));
END;
!++
! FREE_LITLIST (FRELIT)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine frees a literal_list.
!
! CALLING SEQUENCE:
!
! FREE_LITLIST (litlist);
!
! INPUT PARAMETERS:
!
! litlist Address of a list of literal_lists
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE FREE_LITLIST (litlist): NOVALUE =
BEGIN
MAP
litlist: REF crx_literal_list;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called FREE_LITLIST'));
IF .LITLIST [crl$a_next] NEQA NULL_PTR
THEN FREE_LITLIST (.LITLIST [crl$a_next]);
IF .LITLIST [crl$a_literals] NEQA NULL_PTR
THEN FREE_STRINGLIST (.LITLIST [crl$a_literals]);
$XPO_FREE_MEM (BINARY_DATA = (diu$S_CRX_LITERAL_LIST, .LITLIST, FULLWORDS));
END;
!++
! FREE_MEMBERS (FREMEM)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine frees everything pointed to by a member block (crx_member)
! or an overlay block (crx_overlay).
!
! CALLING SEQUENCE:
!
! FREE_MEMBERS (member);
!
! INPUT PARAMETERS:
!
! member Address of a crx_member block
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE FREE_MEMBERS (member) : NOVALUE =
BEGIN
MAP
MEMBER: REF CRX_MEMBER;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called FREE_MEMBERS'));
IF .member [CRM$B_ID] EQL CRX$K_MEMBER
THEN BEGIN ! A member node
! No need to free a_descriptions, since we don't make any.
! IF .MEMBER [crm$a_description] NEQA NULL_PTR
! THEN FREE_STRINGLIST (.MEMBER [crm$a_description]);
IF .MEMBER [crm$a_next] NEQA NULL_PTR
THEN FREE_MEMBERS (.MEMBER [crm$a_next]); ! Siblings
IF .MEMBER [crm$w_source_length] NEQ 0
THEN $XPO_FREE_MEM (STRING = (.MEMBER [crm$w_source_length],
.MEMBER [crm$a_source_type]));
IF .MEMBER [crm$a_children] NEQA NULL_PTR
THEN FREE_MEMBERS (.MEMBER [crm$a_children]); ! Children
! We do not use crm$a_reference field
! IF .MEMBER [crm$a_reference] NEQA NULL_PTR
! THEN FREE_STRINGLIST (.MEMBER [crm$a_reference]);
IF .MEMBER [crm$a_tag_variable] NEQA NULL_PTR
THEN FREE_STRINGLIST (.MEMBER [crm$a_tag_variable]);
IF .MEMBER [crm$a_dimensions] NEQA NULL_PTR
THEN FREE_DIMENSIONS (.MEMBER [crm$a_dimensions]); ! Dimensions
IF .member [CRM$A_FACILITY] NEQA NULL_PTR
THEN $XPO_FREE_MEM ! Note: BINDing the additional block
(BINARY_DATA = (cra$s_crx_additional,! gives a compiler bug (binds
.member [CRM$A_FACILITY], FULLWORDS));! to member block instead)!
IF .MEMBER [crm$a_initial_value] NEQA NULL_PTR
THEN IF NOT .MEMBER [crm$v_facility_use_3]
THEN
$XPO_FREE_MEM ( ! Characters
STRING = (.member [CRM$W_INITIAL_LENGTH],
.member [CRM$A_INITIAL_VALUE]))
ELSE $XPO_FREE_MEM ( ! Words
BINARY_DATA = (.member [CRM$W_INITIAL_LENGTH],
.member [CRM$A_INITIAL_VALUE], FULLWORDS));
$XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_member, .member, FULLWORDS));
END
ELSE BEGIN ! An overlay node
LOCAL overlay: REF crx_overlay;
overlay = .member;
IF .overlay [CRO$A_NEXT] NEQA NULL_PTR
THEN FREE_MEMBERS (.overlay [CRO$A_NEXT]);
IF .overlay [CRO$A_FIELDS] NEQA NULL_PTR
THEN FREE_MEMBERS (.overlay [CRO$A_FIELDS]);
IF .overlay [CRO$A_TAG_VALUES] NEQA NULL_PTR
THEN FREE_LITLIST (.overlay [CRO$A_TAG_VALUES]);
$XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_overlay, .overlay, FULLWORDS));
END;
END;
!++
! FREE_RECORD (FREREC)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine frees a crx_record node and all subtrees.
!
! CALLING SEQUENCE:
!
! FREE_RECORD (record_ptr);
!
! INPUT PARAMETERS:
!
! record_ptr Address of a crx_record node
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE FREE_RECORD (record_ptr) : NOVALUE =
BEGIN
MAP record_ptr: REF crx_record;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called FREE_RECORD'));
! Free descriptions: (commented out because we make no descriptions)
! IF .RECORD_PTR [crx$a_description] NEQA NULL_PTR
! THEN FREE_STRINGLIST (.RECORD_PTR [crx$a_description]);
! Free member tree, if any.
IF .RECORD_PTR [CRX$A_ROOT] NEQU NULL_PTR
THEN FREE_MEMBERS (.record_ptr [CRX$A_ROOt]);
! crx$a_facility not used
$XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_record, .record_ptr, FULLWORDS));
RECORD_PTR = NULL_PTR;
END;
!++
! FREE_STRINGLIST (FRESTR)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine frees a stringlist.
!
! CALLING SEQUENCE:
!
! FREE_STRINGLIST (stringlist);
!
! INPUT PARAMETERS:
!
! STRINGLIST Address of a list of stringlists
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE FREE_STRINGLIST (stringlist): NOVALUE =
BEGIN
MAP
STRINGLIST: REF crx_stringlist;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called FREE_STRINGLIST'));
IF .stringlist EQL 0 THEN RETURN;
IF .STRINGLIST [CRS$B_ID] EQL CRX$K_STRINGLIST
THEN BEGIN ! A stringlist node
IF .STRINGLIST [crs$a_next] NEQA NULL_PTR
THEN FREE_STRINGLIST (.STRINGLIST [crs$a_next]);
$XPO_FREE_MEM (STRING = (.STRINGLIST [crs$w_string_length],
.STRINGLIST [crs$a_string]));
$XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_stringlist, .STRINGLIST,
FULLWORDS));
END ! A stringlist node
ELSE ! A tag field FFD node
$XPO_FREE_MEM (BINARY_DATA = (diu$s_crx_tag_ffd, .stringlist,
FULLWORDS));
END;
!++
! INIT_LITERAL (INTLIT)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine initializes a literal list block. The block should be
! zero-filled when it is allocated.
!
! CALLING SEQUENCE:
!
! INIT_LITERAL (literal_list);
!
! INPUT PARAMETERS:
!
! literal_list Literal list to be initialized
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE INIT_LITERAL (literal_list) : NOVALUE =
BEGIN
MAP
LITERAL_LIST: REF crx_literal_list;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called INIT_LITERAL'));
LITERAL_LIST [crl$b_id] = crx$k_literal_list;
END;
!++
! INIT_MEMBER (INTMEM)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine initializes a member block (crx_member). The block
! should be zero-filled when it is allocated.
!
! CALLING SEQUENCE:
!
! INIT_MEMBER (member, previous, name, source_loc);
!
! INPUT PARAMETERS:
!
! member Address of crx_member node to initialize
! previous Address of previous node
! name String description of name of field
! source_loc Source locator
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
GLOBAL ROUTINE INIT_MEMBER (member, previous, name, source_loc) : NOVALUE =
BEGIN
MAP
MEMBER : REF crx_member,
NAME: REF $STR_DESCRIPTOR (CLASS=DYNAMIC);
LOCAL
ADD_BLK : REF crx_additional;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called INIT_MEMBER'));
MEMBER [crm$a_previous] = .PREVIOUS;
MEMBER [crm$b_id] = crx$k_member;
MEMBER [crm$b_name_length] = .NAME [str$h_length];
MEMBER [crm$l_total_cells] = 1;
MEMBER [crm$v_facility_use_5] = DIL_SRC;
ch$move ((if .NAME [str$h_length] LEQ 31
THEN .NAME [str$h_length] ELSE 31),
.NAME [str$a_pointer], ch$ptr (MEMBER [crm$t_name]));
MEMBER [crm$w_datatype] = 0;
! Create additional block and hook it in:
$XPO_GET_MEM (FULLWORDS = cra$s_crx_additional, FILL = 0,
RESULT = ADD_BLK);
MEMBER [crm$a_facility] = .ADD_BLK;
ADD_BLK [cra$l_locator] = .source_loc;
END;
!++
! INIT_STRINGLIST (INTSTR)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine initializes a stringlist block. The block should be
! zero-filled when it is allocated.
!
! CALLING SEQUENCE:
!
! INIT_STRINGLIST (stringlist);
!
! INPUT PARAMETERS:
!
! stringlist Stringlist to be initialized
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE INIT_STRINGLIST (stringlist) : NOVALUE =
BEGIN
MAP
STRINGLIST : REF crx_stringlist;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called INIT_STRINGLIST'));
STRINGLIST [crs$b_id] = crx$k_stringlist;
END;
!++
! MAKE_DIMS (MAKDIM)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine makes a dims node. It should only be called for
! member blocks which have dimensions.
!
! CALLING SEQUENCE:
!
! MAKE_DIMS (new_dims, member);
!
! PARAMETERS:
!
! new_dims Set to address of the new dims node
! member Address of the member block
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE MAKE_DIMS (new_dims, p_node) : NOVALUE =
BEGIN
LOCAL
member : REF crx_member, ! if p_node is a member block
dims_node : REF dims; ! if p_node is a DIMS node
LOCAL
my_dims : REF dims; ! new DIMS node
! Make and fill a new DIMS node
member = .p_node;
dims_node = .p_node;
$XPO_GET_MEM (FULLWORDS = dims$k_size, RESULT = .new_dims, FILL = 0);
my_dims = ..new_dims;
my_dims [DIMS$B_ID] = DIU$K_DIMSNODE;
SELECTONE .member[CRM$B_ID] OF
SET
[CRX$K_MEMBER] : ! new DIMS being made from member info
BEGIN
my_dims [DIMS$B_DIMENSIONS_CNT] = .member [CRM$B_DIMENSIONS_CNT];
my_dims [DIMS$A_LIST] = .member [CRM$A_DIMENSIONS];
my_dims [DIMS$L_TOT_CELLS] = .member [CRM$L_TOTAL_CELLS];
END;
[DIU$K_DIMSNODE] : ! DIMS is being copied to a new DIMS
BEGIN
my_dims [DIMS$B_DIMENSIONS_CNT] = .dims_node [DIMS$B_DIMENSIONS_CNT];
my_dims [DIMS$A_LIST] = .dims_node [DIMS$A_LIST];
my_dims [DIMS$L_TOT_CELLS] = .dims_node [DIMS$L_TOT_CELLS];
END;
TES;
RETURN;
END;
!++
! MAKE_FQN (MAKFQN)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine makes an FQN stringlist node.
!
! CALLING SEQUENCE:
!
! MAKE_FQN (new_fqn, node);
!
! PARAMETERS:
!
! new_fqn Set to address of the new FQN stringlist node
! node Address of the member block from which the FQN
! information is to be extracted OR address of the
! old FQN which is being copied to this new FQN.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it
! calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE MAKE_FQN (new_fqn, p_node) : NOVALUE =
BEGIN
LOCAL
member : REF crx_member, ! if p_node is a member block
fqn_node : REF crx_stringlist; ! if p_node is an FQN stringlist
LOCAL
my_fqn : REF crx_stringlist; ! new FQN node
! Make and fill a new fqn node
member = .p_node;
fqn_node = .p_node;
$XPO_GET_MEM (FULLWORDS = diu$s_crx_stringlist, RESULT = .new_fqn, FILL = 0);
my_fqn = ..new_fqn;
my_fqn [CRS$B_ID] = CRX$K_STRINGLIST;
SELECTONE .member[CRM$B_ID] OF
SET
[CRX$K_MEMBER] : ! new FQN being made from member info
BEGIN
! allocate memory for the name string
$XPO_GET_MEM (CHARACTERS = .member [CRM$B_NAME_LENGTH],
RESULT = my_fqn [CRS$A_STRING],
FILL = ' ');
! copy member's name into new FQN string
CH$MOVE (.member [CRM$B_NAME_LENGTH],
CH$PTR (member [CRM$T_NAME]),
.my_fqn [CRS$A_STRING]);
! save name length
my_fqn [CRS$W_STRING_LENGTH] = .member [CRM$B_NAME_LENGTH];
END;
[CRX$K_STRINGLIST] : ! an FQN is being copied to a new FQN
BEGIN
! allocate memory for the name string
$XPO_GET_MEM (CHARACTERS = .fqn_node [CRS$W_STRING_LENGTH],
RESULT = my_fqn [CRS$A_STRING],
FILL = ' ');
! copy old FQN's name into new FQN's name string
CH$MOVE (.fqn_node [CRS$W_STRING_LENGTH],
.fqn_node [CRS$A_STRING],
.my_fqn [CRS$A_STRING]);
! save name length
my_fqn [CRS$W_STRING_LENGTH] = .fqn_node [CRS$W_STRING_LENGTH];
END;
TES;
RETURN;
END;
!++
! MAKE_TRANSFORM (MAKTRA)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine makes a transform node and marks the fields
! involved as participants in a transform.
!
! CALLING SEQUENCE:
!
! MAKE_TRANSFORM (source_fqn, dest_fqn, source_member,
! dest_member, source_dim, dest_dim, new_trans);
!
! PARAMETERS:
!
! source_fqn Source fully-qualified name
! dest_fqn Destination fully-qualified name
! source_member Address of source member node
! dest_member Address of destination member node
! source_dim Address of source dimension node
! dest_dim Address of destination dimension node
! new_trans Set to address of newly-created transform
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE MAKE_TRANSFORM (source_fqn, dest_fqn, source_member, dest_member,
source_dim, dest_dim, new_trans): NOVALUE =
BEGIN
MAP
source_fqn: REF crx_stringlist, ! Source name
dest_fqn: REF crx_stringlist, ! Destination name
source_member: REF crx_member, ! Source member node
dest_member: REF crx_member, ! Destination member node
source_dim: REF dims, ! Source dimension list
dest_dim: REF dims; ! Destination dimension list
LOCAL
my_trans: REF transform_str; ! New transform
! Make and fill a new transform node:
$XPO_GET_MEM (FULLWORDS = TRA_SIZE, FILL = 0, RESULT = .new_trans);
my_trans = ..new_trans;
my_trans [TRA_ID] = DIU$K_TRANSFORM;
my_trans [TRA_SRC_ADDR] = .source_member;
my_trans [TRA_SRC_NAM] = .source_fqn;
my_trans [TRA_SRC_DIMS] = .source_dim;
my_trans [TRA_DST_ADDR] = .dest_member;
my_trans [TRA_DST_NAM] = .dest_fqn;
my_trans [TRA_DST_DIMS] = .dest_dim;
! Mark source and destination fields as "used" in case we get a
! MOVE OTHERS MATCHING.
IF .source_member NEQ 0
THEN source_member [CRM$V_FACILITY_USE_2] = TRUE;
IF .dest_member NEQ 0
THEN dest_member [CRM$V_FACILITY_USE_2] = TRUE;
RETURN;
END;
!++
! NAME_SYNTAX (NAMSYN)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine checks that a field name has proper syntax.
! The following make a field name illegal:
! 1. It has 0 or more than 31 characters.
! 2. It contains characers other than A-Z, 0-9, '$', and '_'.
! 3. It begins with a character not in A-Z.
! 4. It ends with a character not in A-Z or 0-9.
! Note: '*' is legal for no-name fields.
!
! CALLING SEQUENCE:
!
! status = NAME_SYNTAX (length.rlu.v, ptr.ra.v, loc.rlu.v);
!
! INPUT PARAMETERS:
!
! length Length of the target field name
! ptr Character pointer to the target field name
! loc Source locator for field
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! FALSE Indicates an invalid field name
! SS$_NORMAL Indicates a valid field name
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE NAME_SYNTAX (length, ptr, loc) =
BEGIN
! States for state machine:
LITERAL
S_ERROR = 0, ! Error state
S_ERROR_1 = 1, ! Invalid character
S_ERROR_2 = 2, ! First character in name not A-Z
S_ERROR_3 = 3, ! Last character in name not A-Z or 0-9
S_ASTR = 4, ! * (no-name field)
S_START = 5, ! Start state
S_NORMAL = 6, ! Last character was A-Z or 0-9
S_SPEC = 7, ! Last character was '$' or '_'
S_END = 8, ! Halt (not in state table)
! Classes of characters that might appear in a field name:
F_NULL = 0, ! (an invalid character)
F_ASTR = 1, ! '*'
F_CHAR = 2, ! A-Z
F_NUMB = 3, ! 0-9
F_SPEC = 4, ! '$' and '_'
F_END = 5; ! (end of name)
STRUCTURE
TABLE [s, f] = [3*6] (TABLE+(S-S_START)*6 + (F-F_NULL))
%BLISS32 (<0, 8, 0>); ! In bytes on VAXen
! State table:
OWN
STATE_TABLE: TABLE PRESET (
[S_START, F_NULL] = S_ERROR_1,
[S_START, F_ASTR] = S_ASTR,
[S_START, F_CHAR] = S_NORMAL,
[S_START, F_NUMB] = S_ERROR_2,
[S_START, F_SPEC] = S_ERROR_2,
[S_START, F_END] = S_END,
[S_NORMAL, F_NULL] = S_ERROR_1,
[S_NORMAL, F_ASTR] = S_ERROR_1,
[S_NORMAL, F_CHAR] = S_NORMAL,
[S_NORMAL, F_NUMB] = S_NORMAL,
[S_NORMAL, F_SPEC] = S_SPEC,
[S_NORMAL, F_END] = S_END,
[S_SPEC, F_NULL] = S_ERROR_1,
[S_SPEC, F_ASTR] = S_ERROR_1,
[S_SPEC, F_CHAR] = S_NORMAL,
[S_SPEC, F_NUMB] = S_NORMAL,
[S_SPEC, F_SPEC] = S_SPEC,
[S_SPEC, F_END] = S_ERROR_3),
! Character type table:
CHAR_TABLE: VECTOR [%BLISS32 (256, BYTE)
%BLISS36 (128)] PRESET (
[%C'A'] = F_CHAR,
[%C'B'] = F_CHAR,
[%C'C'] = F_CHAR,
[%C'D'] = F_CHAR,
[%C'E'] = F_CHAR,
[%C'F'] = F_CHAR,
[%C'G'] = F_CHAR,
[%C'H'] = F_CHAR,
[%C'I'] = F_CHAR,
[%C'J'] = F_CHAR,
[%C'K'] = F_CHAR,
[%C'L'] = F_CHAR,
[%C'M'] = F_CHAR,
[%C'N'] = F_CHAR,
[%C'O'] = F_CHAR,
[%C'P'] = F_CHAR,
[%C'Q'] = F_CHAR,
[%C'R'] = F_CHAR,
[%C'S'] = F_CHAR,
[%C'T'] = F_CHAR,
[%C'U'] = F_CHAR,
[%C'V'] = F_CHAR,
[%C'W'] = F_CHAR,
[%C'X'] = F_CHAR,
[%C'Y'] = F_CHAR,
[%C'Z'] = F_CHAR,
[%C'1'] = F_NUMB,
[%C'2'] = F_NUMB,
[%C'3'] = F_NUMB,
[%C'4'] = F_NUMB,
[%C'5'] = F_NUMB,
[%C'6'] = F_NUMB,
[%C'7'] = F_NUMB,
[%C'8'] = F_NUMB,
[%C'9'] = F_NUMB,
[%C'0'] = F_NUMB,
[%C'$'] = F_SPEC,
[%C'_'] = F_SPEC,
[%C'*'] = F_ASTR);
LOCAL
CHAR,
CHAR_CNT,
FOUND,
POINTER,
STATE;
CHAR_CNT = 0;
POINTER = .PTR;
STATE = S_START;
INCR I FROM 1 TO .LENGTH DO ! Finite state machine
BEGIN
CHAR = CH$RCHAR_A (POINTER);
FOUND = .CHAR_TABLE [.CHAR];
STATE = .STATE_TABLE [.STATE, .FOUND];
CASE .STATE FROM S_ERROR TO S_END OF SET
[S_ERROR]:
BEGIN
LSLOCAL_SYNTAX_ERRORM (.loc, 'Illegal field name');
RETURN FALSE;
END;
[S_ERROR_1]:
BEGIN
LSLOCAL_SYNTAX_ERRORM
(.loc, 'Illegal character in name');
RETURN FALSE;
END;
[S_ERROR_2]:
BEGIN
LSLOCAL_SYNTAX_ERRORM
(.loc, 'First character in name invalid');
RETURN FALSE;
END;
[S_ERROR_3]:
BEGIN
LSLOCAL_SYNTAX_ERRORM
(.loc, 'Invalid last character in name');
RETURN FALSE;
END;
[S_START]: ;
[S_ASTR]:
IF .LENGTH EQLU 1
THEN RETURN SS$_NORMAL
ELSE BEGIN
LSLOCAL_SYNTAX_ERRORM
(.loc, 'Illegal character in name');
RETURN FALSE;
END;
[S_NORMAL]:
BEGIN
CHAR_CNT = .CHAR_CNT + 1;
IF .CHAR_CNT GTRU 31
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (.loc,
'Field name must be from 1 to 31 characters');
RETURN FALSE;
END;
END;
[S_SPEC]:
BEGIN
CHAR_CNT = .CHAR_CNT + 1;
IF .CHAR_CNT GTRU 31
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (.loc,
'Field name must be from 1 to 31 characters');
RETURN FALSE;
END;
END;
[INRANGE, OUTRANGE]:
BEGIN
LSLOCAL_SYNTAX_ERRORM
(.loc, 'Illegal field name');
RETURN FALSE;
END;
TES;
END; ! Finite state machine
IF .STATE_TABLE [.STATE, F_END] NEQU S_END
THEN IF .STATE_TABLE [.STATE, F_END] EQLU S_ERROR_3
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM
(.loc, 'Invalid last character in name');
RETURN FALSE;
END ELSE BEGIN
LSLOCAL_SYNTAX_ERRORM
(.loc, 'Illegal field name');
RETURN FALSE;
END;
RETURN SS$_NORMAL;
END;
!++
! PRODUCE_FQN (PRDFQN)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine makes a fully-qualified-name list (FQN) given a
! descriptor containing a field name which may be partially qualified.
!
! CALLING SEQUENCE:
!
! status = PRODUCE_FQN (name, fqn);
!
! PARAMETERS:
!
! name String descriptor of the field name
! fqn Address to set to fully-qualified-name list
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! TRUE if OK.
! FALSE if not OK.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE PRODUCE_FQN (name, fqn) =
BEGIN
MAP
name: REF $STR_DESCRIPTOR (), ! Field name
fqn: REF crx_stringlist; ! Fully-qualified-name list
LOCAL
latest_name: REF crx_stringlist,
name_end,
name_start,
new_name: REF crx_stringlist,
rem_length,
str_length;
! Get rid of old fully-qualified-name, if any.
IF ..fqn NEQA NULL_PTR
THEN FREE_STRINGLIST (.fqn);
.fqn = NULL_PTR;
! Get the individual names and place them in a list of stringlists.
name_start = .name [STR$A_POINTER];
name_end = .name_start;
WHILE (CH$DIFF (CH$PLUS (.name [STR$A_POINTER], .name [STR$H_LENGTH]),
.name_end) NEQ 0)
DO BEGIN ! Loop to get list of names
$XPO_GET_MEM (FULLWORDS = diu$s_crx_stringlist, RESULT = new_name,
FILL = 0);
INIT_STRINGLIST (.new_name);
IF (..fqn NEQA NULL_PTR)
THEN BEGIN ! Attach to end of list
new_name [CRS$A_PREVIOUS] = .latest_name;
latest_name [CRS$A_NEXT] = .new_name;
latest_name = .new_name;
END ! Attach to end of list
ELSE BEGIN ! Start new list
.fqn = .new_name;
latest_name = .new_name;
END; ! Start new list
rem_length = CH$DIFF (CH$PLUS (.name [STR$A_POINTER],
.name [STR$H_LENGTH]), .name_start);
name_end = CH$FIND_CH (.rem_length, .name_start, %C'.'); ! Find ending '.'
IF CH$FAIL (.name_end) ! Goes up to last character
THEN name_end = CH$PLUS (.name [STR$A_POINTER],
.name [STR$H_LENGTH]);
str_length = CH$DIFF (.name_end, .name_start);
new_name [CRS$W_STRING_LENGTH] = .str_length;
$XPO_GET_MEM (CHARACTERS = .str_length, RESULT = new_name [CRS$A_STRING]);
CH$MOVE (.str_length, .name_start, .new_name [CRS$A_STRING]);
name_start = CH$PLUS (.name_end, 1); ! Skip over '.'
END; ! Loop to get list of names
! Clear the name pointer block
$XPO_FREE_MEM (STRING = (.name [STR$H_LENGTH], .name [STR$A_POINTER]));
name [STR$H_LENGTH] = 0;
RETURN TRUE;
END;
!++
! VALIDATE_FQN (VLDFQN)
!
! FUNCTIONAL DSCRIPTION:
!
! Validates each name in a fully-qualified-name list (FQN).
!
! CALLING SEQUENCE:
!
! status = VALIDATE_FQN (fqn);
!
! PARAMETERS:
!
! fqn Head of fully-qualified-name list
!
! IMPLICIT INPUTS:
!
! PAT$TOKEN_CURRENT_PTR Pointer to current lexical token
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION STATUS:
!
! TRUE if OK.
! FALSE if not OK.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
GLOBAL ROUTINE VALIDATE_FQN (fqn) =
BEGIN
MAP
fqn: REF crx_stringlist; ! Fully-qualified-name list
LOCAL
current_fqn: REF crx_stringlist, ! Current fully-qual.-name list
status; ! Return status
! Walk the FQN calling NAME_SYNTAX for each name.
current_fqn = .fqn;
WHILE (.current_fqn NEQA NULL_PTR)
DO BEGIN ! Check each name in list for validity
status = NAME_SYNTAX (.current_fqn [CRS$W_STRING_LENGTH],
.current_fqn [CRS$A_STRING],
LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR));
IF NOT .status THEN RETURN .status;
current_fqn = .current_fqn [CRS$A_NEXT];
END;
RETURN TRUE; ! Entire list was valid
END;
END
ELUDOM