Trailing-Edge
-
PDP-10 Archives
-
tops20-v7-ft-dist1-clock
-
7-sources/diuacn.bli
There are 4 other files named diuacn.bli in the archive. Click here to see a list.
MODULE DIUACN (%require ('DIUPATSWITCH')
IDENT = '253') =
BEGIN
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1986.
! ALL RIGHTS RESERVED.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND
! COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
! THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR
! ANY OTHER COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
! AVAILABLE TO ANY OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE
! SOFTWARE IS HEREBY TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
! NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
! EQUIPMENT CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF
! ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
!++
!
! TITLE: ACTION DDL and Transform Action Routines
!
! FACILITY: DIU
!
! ABSTRACT:
!
! This module contains the parser action routines necessary to build
! the internal data structures.
!
! ENVIRONMENT:
!
! All routines run in user access mode.
!
! These routines are NOT AST reentrant.
!
! AUTHOR: Colleen Deininger, 31-JUL-81
!
!++
!
! MODIFICATION HISTORY:
!
! 253 Rename file to DIUACT.BLI
! Gregory A. Scott 1-Jul-86
!
! 241 In ACTION.BLI routine DEFINE_DTYPE (DEFTYP), add informational message
! for unsupported datatypes.
! Sandy Clemens 20-Jun-86
!
! 236 Change library of DIXLIB to DIUDIX.
! Sandy Clemens 19-Jun-86
!
! 2 Allow debug compilation without debug printout.
!
! 1 Fix to compile with new, larger version of DIXLIB with Bliss36
! Charlotte Richardson 17-July-85
! 4-Oct-84 (CLR) Convert to compatible Bliss and CRX structures for DIU.
!
! Edits made to CDDL:
!
! Version 3.0
! 2-Apr-84 01732 (CGM) Change SIGNAL_STOPS to SIGNALs.
! 23-Mar-84 01728 (CGM) Allow the scale to be larger than the number of
! digits in the DATATYPE clause.
! 12-Mar-84 01720 (CGM) Fix bug where the length of copied arrays is
! incorrectly computed.
! 23-Feb-84 01694 (CGM) Change FULLY_QUALIFIED_NAME to check for illegal
! version numbers in fully qualified field names.
! 23-Feb-84 01693 (CGM) Remove XPORT use from the CDDL.
! 6-Jan-84 01473 (CDD)
! 21-Dec-83 01263 (mrw)
! 9-Dec-83 01070 (mrw)
! 29-Nov-83 01043 (KJM) Check facility of signal. If CDDL, do not
! output CDDL$_CDDERROR message
! 23-Nov-83 01036 (KJM) NIT
! 23-Nov-83 01034 (KJM) CDDL$_RECNOTCRE message not being printed
! 21-Nov-83 00835 (CDD)
! 15-Nov-83 00815 (KJM) Move success messages to DDU$$C_CREATE_RECORD
! 2-Nov-83 00793 (MAB) Take relative version numbers out of CDDL
! 4-Oct-83 00771 (MRW) moved imbedded CDDL messages to message file
! 27-Sep-83 00770 (MAB) Make sure COPY_LIST gets the right version.
! 1-Sep-83 00755 (CGM) Adding the INDEXED FOR COBOL BY clause.
! 26-Aug-83 00751 (CGM) Adding support for the DSC$K_DTYPE_VT
! RTL datatype.
! 25-Jul-83 00728 (KJM) Added support for PL/I
! 22-Mar-83 00650 (MAB) Implement CDDL /COPY_LIST qualifier
! 17-Feb-83 00442 (CDD) Promote to a new version.
!
!--
! Version 2.2
! 24-Jan-83 00258 (KJM) Change DSC$K_DTYPE_V to DSC$K_DTYPE_VU
! 12-Jan-83 00083 (CDD) Change the version number
! 10-Jan-83 (KJM) Flag errors for records without a field
! description and structures without a sub-field
! description.
! 7-Dec-82 00044 (KJM) Validate field names
! 16-Sep-82 00022 (CDD)
! 17-Sep-82 (MIZ) Fixed bug in /RECOMPILE so the record being
! recompiled is always put back in the same
! place it was extracted from.
!--
! 29-Jul-82 (CGM) Changed error severities, names and messages.
! 22-Jul-82 (CGM) Added handling for the DBMS datatype synonyms.
! 23-Jun-82 (CGD) Added FULLY_QUALIFIED_NAME to handle fully
! qualified names of the form A.B.C where A
! is at a higher level than C.
! 11-Mar-82 (CGD) Fixed bug in global error recovery. FIELD_NAME
! was not being cleared during recovery.
! 3-Mar-82 (CGD) Changed DTR MISSING_VALUE and DEFAULT_VALUE's
! to append a " (for quoted strings) or D (for
! numbers) to the beginning of the value string.
! 8-FEB-82 (CGD) Fixed bug - BEGIN_RFA was not being initialized
! correctly when the DEFINE token was synthetic.
! 13-JAN-82 (CGD) Added /RECOMPILE option capabilities.
! 11-JAN-82 (CGD) Added locator parameter to DDU$$C_CREATE_RECORD
! routine call.
! 30-DEC-81 (CGD) Added checks for internal semantics,
! deleted message that tag values are not
! supported.
! 22-DEC-81 (CGD) Added DSC$K_DTYPE_ADT for dates.
! 15-DEC-81 (CGD) Bug fix -- reinitialized STACK_TOP to 0, in
! ACTION_RTN, when cleaning up a bad record.
! 11-DEC-81 (CGD) Added check for length of BIT, TEXT,
! UNSPECIFIED and VARYING STRING fields
! such that (0 < length < 65536).
!
!--
! INCLUDE FILES:
REQUIRE 'DIUPATPROLOG'; ! General module prologue
LIBRARY 'DIUPATTOKEN'; ! Token manipulation
LIBRARY 'DIUPATDATA'; ! Shared specification
LIBRARY 'DIUDEB'; ! Debugging
LIBRARY 'DIUPATLANGSP'; ! Language Specific function
LIBRARY 'DIUPATPARSER';
LIBRARY 'BLI:XPORT'; ! Transportable data structures
LIBRARY 'DIUACTION'; ! Structures unique to semantic actions
LIBRARY 'DIUDIX'; ! Define data conversion codes
UNDECLARE %QUOTE TRUE, %QUOTE FALSE,
%QUOTE STS$K_SEVERE, %QUOTE STS$K_ERROR, %QUOTE STS$K_WARNING,
%QUOTE STS$K_SUCCESS, %QUOTE SS$_NORMAL, %QUOTE STS$K_INFO;
LIBRARY 'DIU';
%IF %BLISS (BLISS32) %THEN
UNDECLARE %QUOTE $DESCRIPTOR; ! Clean up after XPORT
%FI
LIBRARY 'DIUCRX'; ! CRX record structures
%IF %BLISS (BLISS32) %THEN
UNDECLARE %QUOTE $DESCRIPTOR; ! Yet again...
%FI
LIBRARY 'DIUMLB'; ! Datatype mapping library
%IF %BLISS (BLISS32) %THEN
UNDECLARE %QUOTE $DESCRIPTOR; ! Yet again...
%FI
LIBRARY 'DIUTLB'; ! Transform data structures
%IF %BLISS (BLISS32) %THEN
UNDECLARE %QUOTE $DESCRIPTOR; ! Yet again...
LIBRARY 'SYS$LIBRARY:STARLET';
%FI
! External routines for debugging:
%if PATBLSEXT_DEBUGGING %then
EXTERNAL ROUTINE TREE: NOVALUE; ! Dump a record description tree
%fi
! External routines (to be found in ACTUTL):
EXTERNAL ROUTINE
COMPUTE_ARRAY_LENGTH: NOVALUE, ! Compute array length
COMPUTE_BYTE_SIZE, ! Compute byte size of field
COMPUTE_END_OFFSETS: NOVALUE, ! Compute offsets at end of field
COMPUTE_OFFSETS: NOVALUE, ! Compute field offsets
COMPUTE_STRIDES: NOVALUE, ! Compute array strides
COPY_RECORD, ! Copy a record template
DEAL_WITH_TRANSFORM_NAMES, ! Deal with field names used in transform
FIND_MATCHING_MEMBER, ! Find matching member block
FIND_NAMES_IN_TREES, ! Look up names used in transform
FIX_COPY_TEMPLATE: NOVALUE, ! Map datatypes in COPY template
FIX_VARIANTS: NOVALUE, ! Complete VARIANT blocks in tree
FREE_DIMENSIONS: NOVALUE, ! Free a list of dimensions
FREE_LITLIST: NOVALUE, ! Free a list of literal lists
FREE_MEMBERS: NOVALUE, ! Releases a crx_member and all subtrees
FREE_RECORD: NOVALUE, ! Free a record and all subtrees
FREE_STRINGLIST: NOVALUE, ! Free a stringlist and all subtrees
INIT_LITERAL: NOVALUE, ! Initialize a crx_literal_list node
INIT_MEMBER: NOVALUE, ! Initialize a crx_member node
INIT_STRINGLIST: NOVALUE, ! Initialize a crx_stringlist node
MAKE_TRANSFORM: NOVALUE, ! Make a transform node
NAME_SYNTAX, ! Check field name syntax
PRODUCE_FQN, ! Make fully-qualified name
VALIDATE_FQN; ! Validate fully-qualified name
! TABLE OF CONTENTS:
FORWARD ROUTINE
ACTION_RTN, ! Driver for semantic actions
CLEAR_ATTRIBUTE_FLAGS : NOVALUE,! Clears attribute flags
CREATE_STR_ATT, ! Creates string attribute structure
DEFINE_DIMENSION, ! Creates a dimension
DEFINE_DTYPE, ! Defines datatype and length
DEFINE_FIELD, ! Creates a field
DEFINE_GROUP_ATTS, ! Define group length and offsets
DEFINE_NUM_ATT, ! Defines numeric attributes
DEFINE_RECORD: NOVALUE, ! Defines record name and description
DEFINE_SCALE, ! Defines scale
DEFINE_TRANSFORM: NOVALUE, ! Complete a transform
END_SET, ! Cleans up at 'END' statement
EXTRACT_NAME: NOVALUE, ! Puts name from token into NAME_BLOCK
FULLY_QUALIFIED_NAME, ! Creates fully-qualified name
MM_STATEMENT, ! Process a MOVE MATCHING statement
MOM_STATEMENT, ! Process a MOVE OTHERS MATCHING
MOVE_STATEMENT, ! Process a MOVE statement
SAVE_COMPLEX_VALUE: NOVALUE, ! Stores part of complex number
SAVE_DEST: NOVALUE, ! Saves destination field name
SAVE_FIELDNAME: NOVALUE, ! Saves current field name
SAVE_LOWER_BOUND: NOVALUE, ! Saves lower bound for range
SAVE_SOURCE: NOVALUE, ! Saves source field name
SAVE_VALUES_LIST, ! Saves value list
SET_ATT, ! Sets some attributes
SET_CHARACTER_TYPE: NOVALUE, ! Sets the character type
SET_SYNCHRONIZED: NOVALUE, ! Handle SYNCHRONIZED clause
SETUP_VALUE_RANGE: NOVALUE; ! Saves a value
! OWN variables:
OWN
! DEST_NAME is a descriptor pointing to the destination for a
! transform.
DEST_NAME: $STR_DESCRIPTOR (CLASS=DYNAMIC),
! ERROR_CONDITION is a (long)word flag that determines if an error
! has been found.
ERROR_CONDITION : %BLISS32 (LONG) INITIAL (FALSE),
! FIELD_NAME is a descriptor pointing to the last field name
! that has been parsed.
FIELD_NAME : $STR_DESCRIPTOR (CLASS=DYNAMIC),
! NAME_BLOCK is a descriptor pointing to the last name that has
! been parsed. (i.e. given-name or path-name)
NAME_BLOCK : $STR_DESCRIPTOR (CLASS=DYNAMIC),
! RECORD_BLK is a pointer to a record block containing information
! about the current record.
RECORD_BLK : REF CRX_RECORD INITIAL (NULL_PTR),
! SIGN_LOC is a (long)word containing the location of the sign for
! the most current numeric string parsed. It is
! used by DEFINE_DTYPE to determine the datatype.
SIGN_LOC %BLISS32 (: LONG),
! SIGN_STATUS is a (long)word used to determine if the last datatype
! parsed was signed, unsigned, or zoned. It is
! used by DEFINE_DTYPE to determine the datatype.
SIGN_STATUS %BLISS32 (: LONG),
! SOURCE_NAME is a descriptor pointing to the source for a transform
SOURCE_NAME : $STR_DESCRIPTOR (CLASS=DYNAMIC),
! STACK_TOP is the address of the lowest level incomplete field.
! The first field is pointed to by RECORD_BLK and so can
! always be located.
STACK_TOP : REF CRX_MEMBER INITIAL (NULL_PTR),
! The following variables are used to store a field's or transform's
! attributes until the field or transform block is created:
ALIGNMENT: INITIAL (0), ! ALIGNED datatype
COMPUTE_TYPE, ! TRUE if computational
COPY_NAME: $STR_DESCRIPTOR
(CLASS=DYNAMIC), ! COPY name
DATATYPE: INITIAL (0), ! Datatype
DIGITS: INITIAL (0), ! DIGITS value
FIELD_BASE: INITIAL (0), ! BASE value
FIELD_LEN: INITIAL (0), ! Bits in field
FIRST_DIMENSION:REF crx_dimension
INITIAL (NULL_PTR), ! Head of dimension list
FIRST_VALUE_LIST:REF crx_stringlist
INITIAL (NULL_PTR), ! Head of value list
INITIAL_LENGTH: INITIAL (0), ! Characters in initial value
INITIAL_LENGTH_1: INITIAL (0), ! Length of real part
! of complex initial value
INITIAL_TYPE: INITIAL (0), ! Token type of initial value
INITIAL_TYPE_1: INITIAL (0), ! Token type of real part
! of complex initial value
INITIAL_TYPE_2: INITIAL (0), ! Token type of imaginary part
! of complex initial value
INITIAL_VALUE: INITIAL (NULL_PTR), ! Pointer to initial value
LAST_DIMENSION: REF crx_dimension
INITIAL (NULL_PTR), ! Most recent dimension
LAST_VALUE_LIST:REF crx_stringlist
INITIAL (NULL_PTR), ! Tail of value list
LOWER_TYPE , ! Type of SAVED_LOWERn
LOWER_TYPE1: INITIAL (0), ! Token type of SAVED_LOWER1
LOWER_TYPE2: INITIAL (0), ! Token type of SAVED_LOWER2
MAX_DIGITS: INITIAL (0), ! Maximum digits
OCCURS_MIN , ! Number of occurrences
! Temporary attribute storage, continued:
QUAL_NAME: REF crx_stringlist
INITIAL (NULL_PTR), ! Fully-qualified name
RECORD_NAME: $STR_DESCRIPTOR
(CLASS=DYNAMIC), ! Record name
SAVED_LOWER1: $STR_DESCRIPTOR
(CLASS=DYNAMIC), ! Saved lower bound
SAVED_LOWER2: $STR_DESCRIPTOR
(CLASS=DYNAMIC), ! ...
SAVED_TYPE , ! Type of SAVED_VALUEn
SAVED_TYPE1: INITIAL (0), ! Token type of SAVED_VALUE1
SAVED_TYPE2: INITIAL (0), ! Token type of SAVED_VALUE2
SAVED_VALUE1: $STR_DESCRIPTOR
(CLASS=DYNAMIC), ! Real part of value
SAVED_VALUE2: $STR_DESCRIPTOR
(CLASS=DYNAMIC), ! Imaginary part of value
SCALE: INITIAL (0), ! SCALE value
STRING_TYPE, ! TRUE if string data
STRING_UNITS, ! Characters in string
TAG_VALUES_LIST:REF crx_stringlist
INITIAL (NULL_PTR), ! Tag values list
TRANSFORM_HEAD: REF transform_str
INITIAL (NULL_PTR), ! Head of transform list
TRANSFORM_TAIL: REF transform_str
INITIAL (NULL_PTR), ! Tail of transform list
UPPER_BOUND: REF crx_stringlist
INITIAL (NULL_PTR), ! Upper bound
VALUE_LIST: REF crx_stringlist
INITIAL (NULL_PTR), ! Current value list
! Attribute existence flags:
ALIGNMENT_FL, ! TRUE if an alignment has been seen
BASE_FL, ! TRUE if a BASE has been seen
COLUMN_MAJOR_FL, ! TRUE if array is column-major
COPY_FL, ! TRUE if a COPY has been seen
DATATYPE_FL, ! TRUE if a DATATYPE has been seen
DIGITS_FL, ! TRUE if DIGITS has been seen
DIMENSION_FL, ! TRUE if a dimension has been seen
INITIAL_FL, ! TRUE if an initial value has been seen
JUSTIFIED_RIGHT_FL, ! TRUE if JUSTIFIED_RIGHT has been seen
LENGTH_FL, ! TRUE if a length has been seen
MAX_DIGITS_FL, ! TRUE if maximum digits have been determined
ONE_DIMENSION_FL, ! TRUE if array has only one dimension
SCALE_FL, ! TRUE if a SCALE has been seen
STRING_TYPE_FL, ! TRUE if a string type has been seen
SYNC_LEFT_FL, ! TRUE if SYNCHRONIZED LEFT
SYNC_RIGHT_FL, ! TRUE if SYNCHRONIZED RIGHT
TAG_VALUES_FL; ! TRUE if tag values have been seen
! External symbols:
EXTERNAL
srcrt, ! Root of source description tree for transform
dstrt; ! Root of destination description tree for transform
! External routines for transform processing:
EXTERNAL ROUTINE
CHECK_DIMS, ! Check for compatible dimensions
DIU$DEL_DIMS: NOVALUE, ! Delete a dims list
DIU$DEL_TRANS_LIST: NOVALUE, ! Delete a transform list
DIU$MOVE_MAT: NOVALUE; ! MOVE OTHERS or MOVE OTHERS MATCHING transform
!++
! ACTION_RTN
!
! FUNCTIONAL DESCRIPTION:
!
! This routine acts as a driver in deciding which action routines are
! to be called. It is called only via macro LS_REDUCE_ACTION in
! PATLANGSP.REQ.
!
! CALLING SEQUENCE:
!
! ACTION_RTN (code, left, right, sloc, right_token_ptr, result);
!
! INPUT PARAMETERS:
!
! code - A code indicating which action is to be performed
! (the action specified in the input to LALRPAT).
!
! left - The index into the semantic stack corresponding
! to the left hand end of the "handle", that is,
! the string of terminals and non-terminals
! corresponding to the right hand side of a production.
!
! Note that this stack index can be used to index a
! parallel semantics stack maintained by the semantics
! action routine.
!
! right - Similar to LEFT, but corresponding to the right hand
! end of the handle.
!
! sloc - Source locator (line and column).
!
! right_token_ptr - If the last symbol in the reduction is a terminal,
! this is a pointer to the token containing that
! symbol. If it is a non-terminal then this value is
! undefined.
!
! result - Address where action routines should put root of tree
! (also in RECORD_BLK or TRANSFORM_HEAD).
!
! IMPLICIT INPUTS:
!
! All globals in this module, plus PAT$TOKEN_CURRENT_PTR
!
! IMPLICIT OUTPUTS:
!
! All globals in this module
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
!
! FALSE indicated that there was some semantic error involved
! during the execution of an action routine.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
GLOBAL ROUTINE ACTION_RTN (CODE, LEFT, RIGHT, SLOC, RIGHT_TOKEN_PTR, RESULT) =
BEGIN
MAP
CODE %BLISS32 (: LONG),
LEFT %BLISS32 (: LONG),
RIGHT %BLISS32 (: LONG),
SLOC %BLISS32 (: LONG),
RIGHT_TOKEN_PTR %BLISS32 (: LONG);
LOCAL
LOCATOR : %BLISS32 (LONG) VOLATILE,
STATUS %BLISS32 (: LONG);
LOCATOR = .SLOC;
STATUS = TRUE;
IF .ERROR_CONDITION AND .CODE NEQU CREATE_THE_RECORD
AND .CODE NEQU TRANSFORM
THEN RETURN SS$_NORMAL;
DEB_EVENT ('Semantics actions',
PUT_MSG ('ACTION_RTN called with code = '),
%if PATBLSEXT_DEBUGGING %then
PUT_STRING (PAT$DATA_SEMACT_TEXT (.CODE)),
%fi
PUT_EOL ());
STATUS = SS$_NORMAL;
! To determine where the semantic actions occur in the grammar, consult the
! grammar file, DDL.PAT.
SELECTONE .CODE OF
SET
[LOWER_BND, UPPER_BND]: SETUP_VALUE_RANGE (.CODE);
[SAVE_COMPLEX1, SAVE_COMPLEX2]:
SAVE_COMPLEX_VALUE (.CODE);
[TAG_VALUES]: STATUS = SAVE_VALUES_LIST (.CODE);
[STORE_NAME]: EXTRACT_NAME (.SLOC);
[DEFINE_END_NO_NAME, DEFINE_END_NAME,
END_NO_NAME, END_NAME]: STATUS = END_SET (.CODE);
[DIGITS_ATT, ALIGNED_ATT]: STATUS = DEFINE_NUM_ATT (.CODE);
[JUSTIFIED_R]: STATUS = SET_ATT (.CODE);
[SAVE_FIELD_NAME]: SAVE_FIELDNAME ();
[SAVE_VAL_TYPE]: SAVE_LOWER_BOUND ();
[SET_LS]: SIGN_LOC = DDU$K_LEFT_SEPARATE;
[SET_LO]: SIGN_LOC = DDU$K_LEFT_OVERPNCH;
[SET_RS]: SIGN_LOC = DDU$K_RIGHT_SEPARATE;
[SET_RO]: SIGN_LOC = DDU$K_RIGHT_OVERPNCH;
[SET_UNSIGNED]: SIGN_STATUS = DDU$K_UNSIGNED;
[SET_SIGNED]: SIGN_STATUS = DDU$K_SIGNED;
[SET_ZONED]:
BEGIN
LSLOCAL_SYNTAX_ERRORM (.SLOC,
'ZONED not implemented -- ignored');
SIGN_STATUS = DDU$K_ZONED;
END;
[DEFINE_THE_RECORD]: DEFINE_RECORD (.result);
[FULLY_QUAL]: STATUS = FULLY_QUALIFIED_NAME ();
[NO_FIELD]:
BEGIN
LSLOCAL_SYNTAX_ERRORM (.SLOC, 'Empty record');
STATUS = FALSE;
END;
[NO_SUB_FIELD]:
BEGIN
LSLOCAL_SYNTAX_ERRORM (.SLOC, 'Empty structure');
STATUS = FALSE;
END;
[GROUP_SPECIFIED]:
LSLOCAL_SYNTAX_ERRORM (.SLOC,
'GROUP should be replaced by STRUCTURE');
[TYPE_SPECIFIED]:
LSLOCAL_SYNTAX_ERRORM (.SLOC,
'TYPE should be replaced by DATATYPE');
[ASSIGN_UPPER]:
BEGIN
LAST_DIMENSION [crd$v_upper_bound_fl] = TRUE;
LAST_DIMENSION [crd$l_upper_bound] = .OCCURS_MIN;
IF .OCCURS_MIN LEQ 0
THEN BEGIN
STATUS = FALSE;
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'OCCURS must be greater than 0');
END;
END;
[ASSIGN_MIN]:
BEGIN
LAST_DIMENSION [crd$v_min_occurs_fl] = TRUE;
LAST_DIMENSION [crd$l_min_occurs] = .OCCURS_MIN;
IF .LAST_DIMENSION [crd$l_upper_bound] LSS .OCCURS_MIN
THEN BEGIN
STATUS = FALSE;
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Maximum OCCURS must be greater than or equal to minimum');
END;
END;
[ARRAY_LOWER, OCCURS_N]:
STATUS = DEFINE_DIMENSION (.CODE, .SLOC);
[ROW_ARRAY]:
COLUMN_MAJOR_FL = FALSE;
[COLUMN_ARRAY]:
COLUMN_MAJOR_FL = TRUE;
[ARRAY_UPPER, OCCURS_UPPER]:
BEGIN
LAST_DIMENSION [crd$v_upper_bound_fl] = TRUE;
LAST_DIMENSION [crd$l_upper_bound] =
LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
END;
[SET_DIMENSION]:
DIMENSION_FL = TRUE;
[ARRAY_NO_LOWER]: ! Only one bound, so it is upper and lower is 1.
BEGIN
LAST_DIMENSION [crd$l_upper_bound] =
.LAST_DIMENSION [crd$l_lower_bound];
LAST_DIMENSION [crd$v_upper_bound_fl] = TRUE;
LAST_DIMENSION [crd$l_lower_bound] = 1;
END;
[DEPEND_ITEM]:
BEGIN
LAST_DIMENSION [crd$a_depend_item] = .QUAL_NAME;
QUAL_NAME [crs$a_previous] = .LAST_DIMENSION;
LAST_DIMENSION [crd$b_depend_item_cnt] = 1;
WHILE ((QUAL_NAME = .QUAL_NAME [crs$a_next]) NEQA NULL_PTR)
DO LAST_DIMENSION [crd$b_depend_item_cnt] =
.LAST_DIMENSION [crd$b_depend_item_cnt] + 1;
END; ! Leave QUAL_NAME as a null pointer
[FIRST_VAL_LIST]:
BEGIN
FIRST_VALUE_LIST = .VALUE_LIST;
LAST_VALUE_LIST = .VALUE_LIST;
VALUE_LIST = NULL_PTR;
END;
[NEXT_VALUE_LIST]:
BEGIN
LAST_VALUE_LIST [crs$a_next] = .VALUE_LIST;
LAST_VALUE_LIST = .VALUE_LIST;
VALUE_LIST = NULL_PTR;
END;
[CREATE_THE_RECORD]:
IF .ERROR_CONDITION
THEN BEGIN
ERROR_CONDITION = FALSE;
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Record description not created');
END
ELSE BEGIN
FIX_VARIANTS (.RECORD_BLK [crx$a_root]);
DEB_EVENT ('Semantics actions',
TREE (.RECORD_BLK)); ! Display what we made
RECORD_BLK = NULL_PTR;
END;
[SCALE_ATT]:
STATUS = DEFINE_SCALE
(LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR));
[FRACTIONS_ATT]:
BEGIN
! Make sure the number of fractions is less or equal to the number of digits.
IF .DIGITS LSSU LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR)
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Number of FRACTIONS must be less than DIGITS');
STATUS = FALSE;
END
ELSE
STATUS = DEFINE_SCALE
(-LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR));
END;
[DEFINE_ELEMENTARY, DEFINE_COPY,
DEFINE_STRUCTURE, DEFINE_VARIANT, DEFINE_VARIANTS]:
STATUS = DEFINE_FIELD (.CODE, .SLOC);
[COPY_PATHNAME, INIT_VALUE]:
STATUS = CREATE_STR_ATT (.CODE);
[BYTE_LENGTH, VARYING_LENGTH]:
BEGIN
LENGTH_FL = TRUE;
IF (LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) LEQ 0) OR
(LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) GEQ 65536)
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Field length must be between 0 and 65536');
STATUS = FALSE;
END;
FIELD_LEN = (IF .CODE EQLU BYTE_LENGTH
THEN (DIU$K_S_ASCII *
LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR))
ELSE (DIU$K_S_ASCII *
(LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) + 2)));
STRING_UNITS = LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
END;
[BASE_ATT]:
BEGIN
BASE_FL = TRUE;
FIELD_BASE = LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
END;
[GROUP_ATTS]:
BEGIN
LOCAL
TEMP_OFFSET %BLISS32 (: LONG),
TOTAL_OFFSET %BLISS32 (: LONG),
LENGTH %BLISS32 (: LONG);
TOTAL_OFFSET = 0;
TEMP_OFFSET = 0;
STATUS = DEFINE_GROUP_ATTS (.RECORD_BLK [CRX$A_ROOT],
TEMP_OFFSET, TOTAL_OFFSET, LENGTH);
END;
[BIT_DTYPE, BYTE_DTYPE, DATE_DTYPE, D_FLOAT_DTYPE, D_COMPLEX_DTYPE,
F_FLOAT_DTYPE, F_COMPLEX_DTYPE, G_FLOAT_DTYPE, G_COMPLEX_DTYPE,
H_FLOAT_DTYPE, H_COMPLEX_DTYPE, LONGWORD_DTYPE, NUMERIC_DTYPE,
OCTAWORD_DTYPE, PACKED_NUM_DTYPE, POINTER_DTYPE, QUADWORD_DTYPE,
TEXT_DTYPE, UNSPECIFIED_DTYPE, VARYING_STR_DTYPE, VIRTUAL_DTYPE,
WORD_DTYPE]:
STATUS = DEFINE_DTYPE (.CODE);
[TRANSFORM]:
BEGIN
DEFINE_TRANSFORM (.result);
IF .ERROR_CONDITION
THEN BEGIN
ERROR_CONDITION = FALSE;
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Transform not created');
END;
END;
[TYPE_ASCII_7, TYPE_ASCII_8,
TYPE_EBCDIC_8, TYPE_EBCDIC_9, TYPE_SIXBIT]:
SET_CHARACTER_TYPE (.CODE);
[TYPE_ASCII_9]:
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'ASCII_9 not implemented - ignored');
[SYNC_LEFT, SYNC_RIGHT]:
SET_SYNCHRONIZED (.CODE);
[MOVE_ST]: STATUS = MOVE_STATEMENT ();
[MM_ST]: STATUS = MM_STATEMENT ();
[MOM_ST]: STATUS = MOM_STATEMENT ();
[ROUNDED]: ! Should set conversion-flag to ROUNDED
LSLOCAL_SYNTAX_ERRORM (.SLOC,
'ROUNDED not implemented -- ignored');
[TRUNC]: ! Should set conversion-flag to TRUNCATED
LSLOCAL_SYNTAX_ERRORM (.SLOC,
'TRUNCATED not implemented -- ignored');
[SOURCE]: SAVE_SOURCE ();
[DEST]: SAVE_DEST ();
[OTHERWISE]: SS$_NORMAL;
TES;
IF (.CODE EQLU ARRAY_NO_LOWER OR .CODE EQLU ARRAY_UPPER) AND
.LAST_DIMENSION [crd$l_lower_bound]
GTR .LAST_DIMENSION [crd$l_upper_bound]
THEN BEGIN
STATUS = FALSE;
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Improper array bounds');
END;
IF NOT .STATUS OR .CODE EQLU ERROR_MARK
! Unrecoverable error - clean out everything.
THEN BEGIN
IF .RECORD_BLK NEQA NULL_PTR
THEN FREE_RECORD (.RECORD_BLK);
IF .TRANSFORM_HEAD NEQA NULL_PTR
THEN DIU$DEL_TRANS_LIST (.TRANSFORM_HEAD);
TRANSFORM_HEAD = NULL_PTR;
TRANSFORM_TAIL = NULL_PTR;
IF .DEST_NAME [STR$H_LENGTH] NEQU 0
THEN $XPO_FREE_MEM (STRING = DEST_NAME);
IF .SOURCE_NAME [STR$H_LENGTH] NEQU 0
THEN $XPO_FREE_MEM (STRING = SOURCE_NAME);
.RESULT = NULL_PTR;
IF .FIELD_NAME [STR$H_LENGTH] NEQU 0
THEN $XPO_FREE_MEM (STRING = FIELD_NAME);
FIELD_NAME [STR$H_LENGTH] = 0;
CLEAR_ATTRIBUTE_FLAGS ();
STRING_UNITS = 0;
COPY_NAME [STR$H_LENGTH] = 0;
IF .VALUE_LIST NEQA NULL_PTR
THEN FREE_STRINGLIST (.VALUE_LIST);
VALUE_LIST = NULL_PTR;
IF .FIRST_VALUE_LIST NEQA NULL_PTR
THEN FREE_STRINGLIST (.FIRST_VALUE_LIST);
FIRST_VALUE_LIST = NULL_PTR;
IF .FIRST_DIMENSION NEQA NULL_PTR
THEN FREE_DIMENSIONS (.FIRST_DIMENSION);
FIRST_DIMENSION = NULL_PTR;
LAST_DIMENSION = NULL_PTR;
STACK_TOP = NULL_PTR;
IF .RECORD_NAME [STR$H_LENGTH] NEQU 0
THEN $XPO_FREE_MEM (STRING = RECORD_NAME);
RECORD_NAME [STR$H_LENGTH] = 0;
IF .QUAL_NAME NEQA NULL_PTR
THEN FREE_STRINGLIST (.QUAL_NAME);
QUAL_NAME = NULL_PTR;
IF .CODE NEQU CREATE_THE_RECORD
AND .CODE NEQU TRANSFORM
THEN ERROR_CONDITION = TRUE;
END;
RETURN .STATUS
END;
!++
! CREATE_STR_ATT (CRESTR)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine stores an initial value or a copy pathname.
! It is called for COPY_PATHNAME and INIT_VALUE.
!
! CALLING SEQUENCE:
!
! CREATE_STR_ATT (code.rlu.v);
!
! INPUT PARAMETERS:
!
! code is a (long)word value that determines which attribute is
! to be initialized.
!
! IMPLICIT INPUTS:
!
! COPY_FL Copy-seen flag
! INITIAL_FL Initial-value-seen flag
! NAME_BLOCK Name for COPY
! PAT$TOKEN_CURRENT_PTR Current token
!
! IMPLICIT OUTPUTS:
!
! COPY_FL Copy-seen flag, set if appropriate
! COPY_NAME Pointer to COPY stringlist
! INITIAL_FL Initial-value-seen flag, set if appropriate
! INITIAL_LENGTH Length of initial value
! INITIAL_LENGTH_1 Length of real part of complex initial value
! INITIAL_TYPE Datatype of initial value
! INITIAL_TYPE_1 Token type of real part of complex initial value
! INITIAL_TYPE_2 Token type of imaginary part
! INITIAL_VALUE Pointer to initial value
! NAME_BLOCK Name for COPY, cleared if appropriate
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
! FALSE indicates that the attribute was multiply-defined.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE CREATE_STR_ATT (CODE) =
BEGIN
%BLISS32 ( MAP
CODE : LONG;)
BIND
TERM = (LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR)),
TOKEN = (LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR)) : $STR_DESCRIPTOR ();
! Handle COPY pathname:
IF .CODE EQLU COPY_PATHNAME
THEN IF .COPY_FL
THEN BEGIN ! Duplicate copy pathnames
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Multiple COPY templates - ignored');
RETURN FALSE;
END ELSE BEGIN ! New copy pathname
COPY_FL = TRUE;
COPY_NAME [STR$H_LENGTH] = .NAME_BLOCK [STR$H_LENGTH];
COPY_NAME [STR$A_POINTER] = .NAME_BLOCK [STR$A_POINTER];
NAME_BLOCK [STR$H_LENGTH] = 0;
RETURN SS$_NORMAL;
END;
! Handle INIT_VALUE:
IF .INITIAL_FL
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Multiple initial values - ignored');
RETURN FALSE;
END ELSE BEGIN
INITIAL_FL = TRUE;
IF .SAVED_VALUE1 [STR$H_LENGTH] EQLU 0
THEN ! Not complex initial value
BEGIN
INITIAL_TYPE = TERM;
INITIAL_LENGTH = .TOKEN [STR$H_LENGTH];
$XPO_GET_MEM (CHARACTERS = .INITIAL_LENGTH,
RESULT = INITIAL_VALUE);
CH$MOVE (.INITIAL_LENGTH, .TOKEN [STR$A_POINTER],
.INITIAL_VALUE);
END
ELSE
BEGIN ! Complex initial value
INITIAL_TYPE = NT_COMPLEX_NUMBER;
INITIAL_LENGTH_1 = .SAVED_VALUE1 [STR$H_LENGTH];
INITIAL_LENGTH = .SAVED_VALUE1 [STR$H_LENGTH] +
.SAVED_VALUE2 [STR$H_LENGTH] + 1;
INITIAL_TYPE_1 = .SAVED_TYPE1;
INITIAL_TYPE_2 = .SAVED_TYPE2;
$XPO_GET_MEM (CHARACTERS = .INITIAL_LENGTH,
RESULT = INITIAL_VALUE);
CH$MOVE (.SAVED_VALUE1 [STR$H_LENGTH],
.SAVED_VALUE1 [STR$A_POINTER], .INITIAL_VALUE);
CH$WCHAR (%C' ', CH$PLUS (.INITIAL_VALUE,
.SAVED_VALUE1 [STR$H_LENGTH]));
CH$MOVE (.SAVED_VALUE2 [STR$H_LENGTH],
.SAVED_VALUE2 [STR$A_POINTER],
CH$PLUS (.INITIAL_VALUE,
.SAVED_VALUE1 [STR$H_LENGTH] + 1));
SAVED_VALUE1 [STR$H_LENGTH] = 0;
SAVED_VALUE2 [STR$H_LENGTH] = 0;
END;
RETURN SS$_NORMAL
END;
END;
!++
! DEFINE_DIMENSION (DEFDIM)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine creates a dimension block and defines the associated
! numeric values (i.e. stride, lower bound, upper bound and min_occurs).
! It is called for ARRAY_LOWER and OCCURS_N.
!
! CALLING SEQUENCE:
!
! DEFINE_DIMENSION (code.rlu.v, locator.rlu.v);
!
! INPUT PARAMETERS:
!
! code is a (long)word value sent from the parser. It is used
! to determine numeric values to be defined.
!
! locator is the (long)word value of the source locator.
!
! IMPLICIT INPUTS:
!
! FIRST_DIMENSION Head of list of dimension blocks
! LAST_DIMENSION Pointer to most recent dimension block
! PAT$TOKEN_CURRENT_PTR Current token
!
! IMPLICIT OUTPUTS:
!
! FIRST_DIMENSION Head of list of dimension blocks, updated
! LAST_DIMENSION Updated to point to new dimension block
! OCCURS_MIN Number of occurrences of one-dimensional array
! ONE_DIMENSION_FL Set if array has only one dimension
! DIMENSION_FL Dimension-seen flag, set
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
! FALSE Indicates that an arrary was multiply-dimensionned.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE DEFINE_DIMENSION (CODE, LOCATOR) =
BEGIN
%BLISS32 ( MAP
CODE : LONG,
LOCATOR : LONG;)
LOCAL
DCB_PTR : REF crx_dimension;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called DEFINE_DIMENSION'));
DIMENSION_FL = TRUE;
$XPO_GET_MEM (FULLWORDS = diu$s_crx_dimension, RESULT = DCB_PTR, FILL = 0);
DCB_PTR [crd$b_id] = CRX$K_DIMENSION;
IF .FIRST_DIMENSION EQLU NULL_PTR
THEN FIRST_DIMENSION = .DCB_PTR;
! Hook this dimension on to the end of the list of dimensions:
IF .LAST_DIMENSION NEQA NULL_PTR
THEN LAST_DIMENSION [crd$a_next] = .DCB_PTR;
DCB_PTR [crd$a_previous] = .LAST_DIMENSION;
LAST_DIMENSION = .DCB_PTR;
IF .CODE EQLU OCCURS_N
THEN BEGIN
ONE_DIMENSION_FL = TRUE;
OCCURS_MIN = LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
END;
DCB_PTR [crd$l_lower_bound] = (IF .CODE EQLU ARRAY_LOWER
THEN LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) ELSE 1);
DCB_PTR [crd$v_lower_bound_fl] = TRUE;
RETURN SS$_NORMAL
END;
!++
! DEFINE_DTYPE (DEFTYP)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine defines the datatype and length (except for packed and
! numeric datatypes) for the field whose attributes are currently being
! parsed.
! It is called for BIT_DTYPE, BYTE_DTYPE, DATE_DTYPE, D_FLOAT_DTYPE,
! D_COMPLEX_DTYPE, F_FLOAT_DTYPE, F_COMPLEX_DTYPE, G_FLOAT_DTYPE,
! G_COMPLEX_DTYPE, H_FLOAT_DTYPE, H_COMPLEX_DTYPE, LONGWORD_DTYPE,
! NUMERIC_DTYPE, OCTAWORD_DTYPE, PACKED_NUM_DTYPE, POINTER_DTYPE,
! QUADWORD_DTYPE, TEXT_DTYPE, UNSPECIFIED_DTYPE, VARYING_STR_DTYPE,
! VIRTUAL_DTYPE, and WORD_DTYPE.
!
! CALLING SEQUENCE:
!
! DEFINE_DTYPE (code.rlu.v);
!
! INPUT PARAMETERS:
!
! code is a (long)word value sent from the parser. It is used
! to define the datatype of the field to be described.
!
! IMPLICIT INPUTS:
!
! DATATYPE_FL Datatype-seen flag
! PAT$TOKEN_CURRENT_PTR Current token
! SIGN_LOC Sign location
! SIGN_STATUS Sign status
!
! IMPLICIT OUTPUTS:
!
! BASE_FL Base-seen flag, set if appropriate
! COMPUTE_TYPE Computational datatype flag, set if appropriate
! DATATYPE Datatype
! DATATYPE_FL Datatype-seen flag, set
! DIGITS DIGITS value, set if appropriate
! DIGITS_FL DIGITS-seen flag, set if appropriate
! FIELD_BASE BASE value, set if appropriate
! FIELD_LEN Field length
! LENGTH_FL Length-seen flag, set if appropriate
! MAX_DIGITS Maximum digits, set if appropriate
! MAX_DIGITS_FL Maximum-digits-computed flag, set if appropriate
! SIGN_LOC Sign location, set to unspecified
! SIGN_STATUS Sign status, set to unspecified
! STRING_TYPE String datatype flag, set if appropriate
! STRING_UNITS String units, set if appropriate
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
! FALSE Indicates that the field had multiple datatypes or that
! a bit string was not between 0 and 65536 bits long.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE DEFINE_DTYPE (CODE) =
BEGIN
%BLISS32 ( MAP
CODE : LONG;)
LOCAL
s_ascii, s_byte, s_date, s_d_float,
s_d_complex, s_f_float, s_f_complex, s_g_float,
s_g_complex, s_h_float, s_h_complex, s_longword,
s_octaword, s_packed, s_pointer, s_quadword,
s_word,
d_byte_s, d_byte_u, d_d_float, d_d_complex,
d_f_float, d_f_complex, d_g_float, d_g_complex,
d_h_float, d_h_complex, d_longword_s, d_longword_u,
d_octaword_s, d_octaword_u, d_quadword_s, d_quadword_u,
d_word_s, d_word_u;
LOCAL error_desc : $STR_DESCRIPTOR(CLASS = DYNAMIC); ! for error messages
$STR_DESC_INIT (DESC = error_desc, CLASS = DYNAMIC);
! Precompute sizes and digits to reduce size of generated code (common
! subexpression elimination isn't this smart). This should prevent running
! out of heap space while compiling this module with Bliss36.
s_ascii = diu$k_S_ASCII;
s_byte = DIU$K_S_BYTE;
s_date = DIU$K_S_DATE;
s_d_float = DIU$K_S_D_FLOAT;
s_d_complex = DIU$K_S_D_COMPLEX;
s_f_float = DIU$K_S_F_FLOAT;
s_f_complex = DIU$K_S_F_COMPLEX;
s_g_float = DIU$K_S_G_FLOAT;
s_g_complex = DIU$K_S_G_COMPLEX;
s_h_float = DIU$K_S_H_FLOAT;
s_h_complex = DIU$K_S_H_COMPLEX;
s_longword = DIU$K_S_LONGWORD;
s_octaword = DIU$K_S_OCTAWORD;
s_packed = DIU$K_S_PACKED;
s_pointer = DIU$K_S_POINTER;
s_quadword = DIU$K_S_QUADWORD;
s_word = DIU$K_S_WORD;
d_byte_s = DIU$K_D_BYTE_S;
d_byte_u = DIU$K_D_BYTE_U;
d_d_float = DIU$K_D_D_FLOAT;
d_d_complex = DIU$K_D_D_COMPLEX;
d_f_float = DIU$K_D_F_FLOAT;
d_f_complex = DIU$K_D_F_COMPLEX;
d_g_float = DIU$K_D_G_FLOAT;
d_g_complex = DIU$K_D_G_COMPLEX;
d_h_float = DIU$K_D_H_FLOAT;
d_h_complex = DIU$K_D_H_COMPLEX;
d_longword_s = DIU$K_D_LONGWORD_S;
d_longword_u = DIU$K_D_LONGWORD_U;
d_octaword_s = DIU$K_D_OCTAWORD_S;
d_octaword_u = DIU$K_D_OCTAWORD_U;
d_quadword_s = DIU$K_D_QUADWORD_S;
d_quadword_u = DIU$K_D_QUADWORD_U;
d_word_s = DIU$K_D_WORD_S;
d_word_u = DIU$K_D_WORD_U;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called DEFINE_DTYPE'));
IF .DATATYPE_FL
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Multiple data type');
RETURN FALSE;
END;
DATATYPE_FL = TRUE;
! The datatype defines the length, except for text, unspecified,
! and varying-string fields.
IF .CODE NEQU TEXT_DTYPE AND .CODE NEQU UNSPECIFIED_DTYPE AND
.CODE NEQU VARYING_STR_DTYPE
THEN LENGTH_FL = TRUE;
! Set text flag for the crx_member node, if appropriate:
IF .CODE EQLU TEXT_DTYPE OR .CODE EQLU VARYING_STR_DTYPE
OR .CODE EQLU NUMERIC_DTYPE OR .CODE EQLU PACKED_NUM_DTYPE
THEN STRING_TYPE = TRUE;
! Set the computational flag for the crx_member node, if appropriate:
IF (.CODE NEQU BIT_DTYPE) AND (.CODE NEQU DATE_DTYPE) AND
(.CODE NEQU POINTER_DTYPE) AND (.CODE NEQU UNSPECIFIED_DTYPE) AND
(.CODE NEQU VIRTUAL_DTYPE) AND (.CODE NEQU TEXT_DTYPE)
THEN COMPUTE_TYPE = TRUE;
! For binary fields, set base to 2 by default, and indicate that base,
! digits, and max_digits will all be set.
IF (.CODE NEQU BIT_DTYPE) AND
(.CODE NEQU DATE_DTYPE) AND
(.CODE NEQU NUMERIC_DTYPE) AND
(.CODE NEQU PACKED_NUM_DTYPE) AND
(.CODE NEQU POINTER_DTYPE) AND
(.CODE NEQU TEXT_DTYPE) AND
(.CODE NEQU UNSPECIFIED_DTYPE) AND
(.CODE NEQU VARYING_STR_DTYPE) AND
(.CODE NEQU VIRTUAL_DTYPE)
THEN BEGIN
FIELD_BASE = 2;
BASE_FL = TRUE;
DIGITS_FL = TRUE;
MAX_DIGITS_FL = TRUE;
END;
! Handle each datatype:
SELECTONE .CODE OF
SET
[BIT_DTYPE]:
BEGIN
! DATATYPE = DIU$K_DTYPE_VU;
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Bit fields not implemented');
$STR_COPY(TARGET = error_desc,
STRING = 'Bit fields not implemented -- ignored');
SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
IF (LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) LEQ 0) OR
(LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR) GEQ 65536)
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Bit field length must be between 0 and 65536');
RETURN FALSE;
END;
FIELD_LEN = LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
END;
[BYTE_DTYPE]:
BEGIN
IF .SIGN_STATUS EQLU DDU$K_SIGNED
THEN BEGIN
DATATYPE = DIU$K_DTYPE_B;
DIGITS = .d_byte_s;
MAX_DIGITS = .d_byte_s;
END
ELSE BEGIN
DATATYPE = DIU$K_DTYPE_BU;
DIGITS = .d_byte_u;
MAX_DIGITS = .d_byte_u;
END;
FIELD_LEN = .s_byte;
END;
[DATE_DTYPE]:
BEGIN
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'DATE datatype not implemented');
$STR_COPY(TARGET = error_desc,
STRING = 'DATE datatype not implemented -- ignored');
SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
! DATATYPE = DIU$K_DTYPE_ADT;
FIELD_LEN = .s_date;
END;
[D_FLOAT_DTYPE]:
BEGIN
DATATYPE = DIU$K_DTYPE_D;
FIELD_LEN = .s_d_float;
DIGITS = .d_d_float;
MAX_DIGITS = .d_d_float;
END;
[D_COMPLEX_DTYPE]:
BEGIN
DATATYPE = DIU$K_DTYPE_DC;
FIELD_LEN = .s_d_complex;
DIGITS = .d_d_complex;
MAX_DIGITS = .d_d_complex;
END;
[F_FLOAT_DTYPE]:
BEGIN
DATATYPE = DIU$K_DTYPE_F;
FIELD_LEN = .s_f_float;
DIGITS = .d_f_float;
MAX_DIGITS = .d_f_float;
END;
[F_COMPLEX_DTYPE]:
BEGIN
DATATYPE = DIU$K_DTYPE_FC;
FIELD_LEN = .s_f_complex;
DIGITS = .d_f_complex;
MAX_DIGITS = .d_f_complex;
END;
[G_FLOAT_DTYPE]:
BEGIN
DATATYPE = DIU$K_DTYPE_G;
FIELD_LEN = .s_g_float;
DIGITS = .d_g_float;
MAX_DIGITS = .d_g_float;
END;
[G_COMPLEX_DTYPE]:
BEGIN
DATATYPE = DIU$K_DTYPE_GC;
FIELD_LEN = .s_g_complex;
DIGITS = .d_g_complex;
MAX_DIGITS = .d_g_complex;
END;
[H_FLOAT_DTYPE]:
BEGIN
DATATYPE = DIU$K_DTYPE_H;
FIELD_LEN = .s_h_float;
DIGITS = .d_h_float;
MAX_DIGITS = .d_h_float;
END;
[H_COMPLEX_DTYPE]:
BEGIN
DATATYPE = DIU$K_DTYPE_HC;
FIELD_LEN = .s_h_complex;
DIGITS = .d_h_complex;
MAX_DIGITS = .d_h_complex;
END;
[LONGWORD_DTYPE]:
BEGIN
IF .SIGN_STATUS EQLU DDU$K_SIGNED
THEN BEGIN
DATATYPE = DIU$K_DTYPE_L;
DIGITS = .d_longword_s;
MAX_DIGITS = .d_longword_s;
END
ELSE BEGIN
DATATYPE = DIU$K_DTYPE_LU;
DIGITS = .d_longword_u;
MAX_DIGITS = .d_longword_u;
END;
FIELD_LEN = .s_longword;
END;
[NUMERIC_DTYPE]:
IF .SIGN_LOC EQLU DDU$K_UNSPECIFIED
THEN BEGIN
DATATYPE =
(IF (.SIGN_STATUS EQLU DDU$K_SIGNED OR
.SIGN_STATUS EQLU DDU$K_ZONED)
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (
LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'ZONED datatype not supported');
$STR_COPY(TARGET = error_desc,
STRING='ZONED datatype not supported -- ignored');
SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
! DIU$K_DTYPE_NZ
0
END
ELSE
DIU$K_DTYPE_NU);
FIELD_LEN = .DIGITS * .s_ascii;
STRING_UNITS = .DIGITS;
END
ELSE
BEGIN
DATATYPE = (SELECTONE .SIGN_LOC OF
SET
[DDU$K_LEFT_SEPARATE]: DIU$K_DTYPE_NL;
[DDU$K_LEFT_OVERPNCH]: DIU$K_DTYPE_NLO;
[DDU$K_RIGHT_SEPARATE]: DIU$K_DTYPE_NR;
[DDU$K_RIGHT_OVERPNCH]: DIU$K_DTYPE_NRO;
TES);
SELECTONE .SIGN_LOC OF
SET
[DDU$K_LEFT_SEPARATE,DDU$K_RIGHT_SEPARATE]:
BEGIN
FIELD_LEN = (.DIGITS + 1) *
DIU$K_S_ASCII;
STRING_UNITS = .DIGITS + 1;
END;
[DDU$K_LEFT_OVERPNCH,DDU$K_RIGHT_OVERPNCH]:
BEGIN
FIELD_LEN = .DIGITS * .s_ascii;
STRING_UNITS = .DIGITS;
END;
TES;
END;
[OCTAWORD_DTYPE]:
BEGIN
IF .SIGN_STATUS EQLU DDU$K_SIGNED
THEN BEGIN
DATATYPE = DIU$K_DTYPE_O;
DIGITS = .d_octaword_s;
MAX_DIGITS = .d_octaword_s;
END
ELSE BEGIN
DATATYPE = DIU$K_DTYPE_OU;
DIGITS = .d_octaword_u;
MAX_DIGITS = .d_octaword_u;
END;
FIELD_LEN = .s_octaword;
END;
[PACKED_NUM_DTYPE]:
BEGIN
DATATYPE = DIU$K_DTYPE_P;
FIELD_LEN = ((.DIGITS / 2) + 1) * .s_packed;
STRING_UNITS = (.DIGITS/2) + 1;
END;
[POINTER_DTYPE]:
BEGIN
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'POINTER datatype not supported');
$STR_COPY(TARGET = error_desc,
STRING = 'POINTER datatype not supported -- ignored');
SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
! DATATYPE = CDD$K_DTYPE_PTR;
FIELD_LEN = .s_pointer;
END;
[QUADWORD_DTYPE]:
BEGIN
IF .SIGN_STATUS EQLU DDU$K_SIGNED
THEN BEGIN
DATATYPE = DIU$K_DTYPE_Q;
DIGITS = .d_quadword_s;
MAX_DIGITS = .d_quadword_s;
END
ELSE BEGIN
DATATYPE = DIU$K_DTYPE_QU;
DIGITS = .d_quadword_u;
MAX_DIGITS = .d_quadword_u;
END;
FIELD_LEN = .s_quadword;
END;
[TEXT_DTYPE]:
DATATYPE = DIU$K_DTYPE_T;
[UNSPECIFIED_DTYPE]:
BEGIN
! DATATYPE = DIU$K_DTYPE_Z;
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Unspecified datatype not implemented');
$STR_COPY(TARGET = error_desc,
STRING = 'Unspecified datatype not implemented -- ignored');
SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
END;
[VARYING_STR_DTYPE]:
BEGIN
! DATATYPE = DIU$K_DTYPE_VT;
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'VARYING STRING datatype not implemented');
$STR_COPY(TARGET = error_desc,
STRING = 'VARYING STRING datatype not implemented -- ignored');
SIGNAL(DIU$_PAR_INFO, 1, error_desc, 0);
END;
[VIRTUAL_DTYPE]:
BEGIN
! DATATYPE = CDD$K_DTYPE_VRT;
FIELD_LEN = 0;
END;
[WORD_DTYPE]:
BEGIN
IF .SIGN_STATUS EQLU DDU$K_SIGNED
THEN BEGIN
DATATYPE = DIU$K_DTYPE_W;
DIGITS = .d_word_s;
MAX_DIGITS = .d_word_s;
END
ELSE BEGIN
DATATYPE = DIU$K_DTYPE_WU;
DIGITS = .d_word_u;
MAX_DIGITS = .d_word_u;
END;
FIELD_LEN = .s_word;
END;
[OTHERWISE]:
SIGNAL(DIU$_INVDATTYP, 1, .code, 0);
TES;
$XPO_FREE_MEM(STRING = error_desc);
! Clear sign location and sign status.
SIGN_LOC = DDU$K_UNSPECIFIED;
SIGN_STATUS = DDU$K_UNSPECIFIED;
RETURN SS$_NORMAL
END;
!++
! DEFINE_FIELD (DEFFLD)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine creates and initializes the field block for the current
! field and places it into the block structure.
!
! The PARENT_PTR is used to keep track of the field blocks (which are
! missing pointers to children, attributes, etc.) until their missing
! values are initialized. The END_FLAG is used to determine if a
! field's children have all been parsed (which helps differentiate
! between siblings and children).
!
! This routine is called for DEFINE_ELEMENTARY, DEFINE_COPY,
! DEFINE_STRUCTURE, DEFINE_VARIANT, and DEFINE_VARIANTS.
!
! CALLING SEQUENCE:
!
! DEFINE_FIELD (code.rlu.v, source_loc.rlu.v);
!
! INPUT PARAMETERS:
!
! code is a (long)word value sent from the parser. It is used
! to define the type of field to be described.
!
! source_loc is a (long)word containing the locator to the source for
! the field being defined.
!
! IMPLICIT INPUTS:
!
! BASE_FL Base-seen flag
! COLUMN_MAJOR_FL Column-major-array flag
! COMPUTE_TYPE Computational datatype flag
! COPY_NAME COPY stringlist
! DATATYPE DATATYPE setting
! DATATYPE_FL Datatype-seen flag
! DIGITS DIGITS setting
! DIGITS_FL Digits-seen flag
! DIMENSION_FL Dimension-seen flag
! FIELD_BASE BASE setting
! FIELD_LEN Length of field in bits
! FIELD_NAME Field name
! INITIAL_FL Initial-value-seen flag
! INITIAL_LENGTH Length of initial value
! INITIAL_LENGTH_1 Length of real part of complex initial value
! INITIAL_TYPE Token type of initial value
! INITIAL_TYPE_1 Token type of real part of complex initial value
! INITIAL_TYPE_2 Token type of imaginary part of complex initial value
! INITIAL_VALUE Pointer to initial value
! JUSTIFIED_RIGHT_FL Justified-righted-seen flag
! LENGTH_FL Length-seen flag
! MAX_DIGITS Maximum digits
! MAX_DIGITS_FL Maximum-digits-seen flag
! SCALE SCALE setting
! SCALE_FL Scale-seen flag
! STACK_TOP Current rx_member
! STRING_TYPE String datatype flag
! STRING_UNITS Characters in string
! SYNC_LEFT_FL Synchronized-left flag
! SYNC_RIGHT_FL Synchronized-right flag
! TAG_VALUES_FL Tag-values-seen flag
! TAG_VALUES_LIST Tag values list
!
! IMPLICIT OUTPUTS:
!
! COMPUTE_TYPE Computational datatype flag, cleared
! COPY_NAME COPY stringlist, cleared
! FIELD_NAME Field name, cleared
! STACK_TOP Updated
! STRING_TYPE String datatype flag, cleared
! STRING_UNITS Characters in string, cleared
!
! COMPLETION STATUS:
!
! SS$_NORMAL Indicates that the routine completed successfully
! FALSE Indicates that the field name has invalid syntax
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE DEFINE_FIELD (CODE, SOURCE_LOC) =
BEGIN
%BLISS32 ( MAP
CODE : LONG,
SOURCE_LOC : LONG;)
LOCAL
PARENT_PTR: REF CRX_MEMBER,
CHILD_PTR: REF CRX_MEMBER,
FIELD_PTR: REF CRX_MEMBER,
DIM_PTR: REF CRX_DIMENSION,
STATUS %BLISS32 (: LONG),
ADDITIONAL_BLK : REF crx_additional;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called DEFINE_FIELD'));
! Create new crx_member node.
$XPO_GET_MEM (FULLWORDS = diu$s_crx_member, fill = 0, result = FIELD_PTR);
INIT_MEMBER (.field_ptr, NULL_PTR, FIELD_NAME, .SOURCE_LOC);
ADDITIONAL_BLK = .FIELD_PTR [crm$a_facility];
! Store collected information:
IF .COLUMN_MAJOR_FL
THEN FIELD_PTR [crm$v_column_major] = TRUE;
IF .SCALE_FL
THEN FIELD_PTR [crm$w_scale] = .SCALE;
IF .DATATYPE_FL
THEN FIELD_PTR [crm$w_datatype] = .DATATYPE;
IF .LENGTH_FL
THEN BEGIN
FIELD_PTR [crm$l_length] = .FIELD_LEN;
ADDITIONAL_BLK [cra$v_length_set] = TRUE;
! COMPUTE_ARRAY_LENGTH may change member length, but set up the default:
FIELD_PTR [crm$l_member_length] = .FIELD_LEN;
FIELD_PTR [crm$l_string_units] = .STRING_UNITS;
END;
IF .DIGITS_FL
THEN FIELD_PTR [crm$w_digits] = .DIGITS;
IF .BASE_FL
THEN FIELD_PTR [crm$b_base] = .FIELD_BASE;
IF .MAX_DIGITS_FL
THEN FIELD_PTR [crm$w_max_digits] = .MAX_DIGITS;
IF .COPY_FL
THEN BEGIN
FIELD_PTR [crm$a_source_type] = .COPY_NAME [str$a_pointer];
FIELD_PTR [crm$w_source_length] = .COPY_NAME [str$h_length];
COPY_NAME [str$h_length] = 0;
END;
IF .INITIAL_FL
THEN BEGIN
FIELD_PTR [crm$a_initial_value] = .INITIAL_VALUE;
FIELD_PTR [crm$w_initial_length] = .INITIAL_LENGTH;
INITIAL_VALUE = NULL_PTR;
ADDITIONAL_BLK [cra$l_initial_type] = .INITIAL_TYPE;
ADDITIONAL_BLK [cra$l_initial_type_1] = .INITIAL_TYPE_1;
ADDITIONAL_BLK [cra$l_initial_type_2] = .INITIAL_TYPE_2;
ADDITIONAL_BLK [cra$l_initial_length_1] = .INITIAL_LENGTH_1;
END;
FIELD_PTR [crm$v_string_type] = .STRING_TYPE;
FIELD_PTR [crm$v_compute_type] = .COMPUTE_TYPE;
IF .ALIGNMENT_FL
THEN BEGIN
ADDITIONAL_BLK [cra$l_alignment] = .ALIGNMENT;
ADDITIONAL_BLK [cra$v_alignment_exists] = TRUE;
END;
IF .JUSTIFIED_RIGHT_FL
THEN FIELD_PTR [crm$v_right_justified] = TRUE;
IF .DIMENSION_FL
THEN BEGIN
FIELD_PTR [crm$a_dimensions] = .FIRST_DIMENSION;
FIRST_DIMENSION [crd$a_previous] = .FIELD_PTR;
ADDITIONAL_BLK [cra$v_dimension] = TRUE;
FIRST_DIMENSION = NULL_PTR;
! Count number of dimensions:
FIELD_PTR [crm$b_dimensions_cnt] = 1;
DIM_PTR = .FIELD_PTR [crm$a_dimensions];
WHILE ((DIM_PTR = .DIM_PTR [crd$a_next]) NEQA NULL_PTR)
DO FIELD_PTR [crm$b_dimensions_cnt] =
.FIELD_PTR [crm$b_dimensions_cnt] + 1;
END;
IF .TAG_VALUES_FL
THEN BEGIN
LOCAL
TAG_LITLIST: REF crx_literal_list;
$XPO_GET_MEM (FULLWORDS = diu$s_crx_literal_list, RESULT = TAG_LITLIST,
FILL = 0);
INIT_LITERAL (.TAG_LITLIST);
FIELD_PTR [crm$a_tag_variable] = .TAG_LITLIST;
TAG_LITLIST [crl$a_previous] = .FIELD_PTR;
TAG_LITLIST [crl$a_literals] = .TAG_VALUES_LIST;
TAG_VALUES_LIST [crs$a_previous] = .TAG_LITLIST;
IF .TAG_VALUES_LIST [crs$a_next] NEQA NULL_PTR
THEN TAG_LITLIST [crl$w_literals_cnt] = 2 ! A range
ELSE TAG_LITLIST [crl$w_literals_cnt] = 1; ! A value
END;
! Set up field type and fully-qualified name:
SELECTONE .CODE OF SET
[DEFINE_COPY]:
ADDITIONAL_BLK [cra$l_type] = FLD$K_COPY;
[DEFINE_ELEMENTARY]:
ADDITIONAL_BLK [cra$l_type] = FLD$K_ELEMENTARY;
[DEFINE_STRUCTURE]:
BEGIN
FIELD_PTR [crm$w_datatype] = DIU$K_DT_STRUCTURE;
ADDITIONAL_BLK [cra$l_type] = FLD$K_STRUCTURE;
END;
[DEFINE_VARIANT]:
ADDITIONAL_BLK [cra$l_type] = FLD$K_VARIANT;
[DEFINE_VARIANTS]:
BEGIN
ADDITIONAL_BLK [cra$l_type] = FLD$K_VARIANTS;
FIELD_PTR [crm$w_datatype] = DIU$K_DT_OVERLAY;
FIELD_PTR [crm$a_tag_variable] = .QUAL_NAME;
IF .QUAL_NAME NEQA NULL_PTR
THEN BEGIN ! VARIANTS OF has a tag here
QUAL_NAME [crs$a_previous] = .FIELD_PTR;
FIELD_PTR [crm$b_tag_variable_cnt] = 1;
WHILE ((QUAL_NAME = .QUAL_NAME [crs$a_next])
NEQA NULL_PTR)
DO FIELD_PTR [crm$b_tag_variable_cnt] =
.FIELD_PTR [crm$b_tag_variable_cnt] + 1;
END; ! VARIANTS has no tag - nothing to do
END; ! Leave QUAL_NAME a null pointer
TES;
! Check syntax of field name:
IF .CODE NEQU DEFINE_VARIANT AND .CODE NEQU DEFINE_VARIANTS
THEN BEGIN ! VARIANTS and each VARIANT have no names
STATUS = NAME_SYNTAX (.FIELD_NAME [STR$H_LENGTH],
.FIELD_NAME [STR$A_POINTER],
.ADDITIONAL_BLK [cra$l_locator]);
IF NOT .STATUS
THEN RETURN FALSE;
END;
! Put in field name and clear out FIELD_NAME:
IF .FIELD_NAME [str$h_length] NEQ 0
THEN BEGIN ! VARIANTS and each VARIANT have no names
FIELD_PTR [crm$b_name_length] = .FIELD_NAME [str$h_length];
ch$move ((IF .FIELD_NAME [str$h_length] leq 31
THEN .FIELD_NAME [str$h_length] ELSE 31),
.FIELD_NAME [str$a_pointer], ch$ptr (FIELD_PTR [crm$t_name]));
$XPO_FREE_MEM (string = FIELD_NAME);
END;
! Verify SYNCHRONIZED clause, if any:
! 1. SYNCHRONIZED applies only to elementary fields.
! 2. BIT and BYTE alignment are ignored for SYNCHRONIZED fields.
! 3. SYNCHRONIZED applies only to string types: character string, display
! numeric, packed decimal, and zoned fields.
IF .SYNC_LEFT_FL OR .SYNC_RIGHT_FL
THEN BEGIN
LOCAL
OK_SYNC: INITIAL (TRUE);
IF .ADDITIONAL_BLK [cra$l_type] NEQ FLD$K_ELEMENTARY
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
'SYNCHRONIZED ignored for non-elementary fields');
OK_SYNC = FALSE;
END;
IF .ADDITIONAL_BLK [cra$v_alignment_exists]
AND (.ADDITIONAL_BLK [cra$l_alignment] EQL T_BIT)
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
'Bit alignment ignored for SYNCHRONIZED field');
ADDITIONAL_BLK [cra$v_alignment_exists] = FALSE;
END;
IF .ADDITIONAL_BLK [cra$v_alignment_exists]
AND (.ADDITIONAL_BLK [cra$l_alignment] EQL T_BYTE)
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
'Byte alignment ignored for SYNCHRONIZED field');
ADDITIONAL_BLK [cra$v_alignment_exists] = FALSE;
END;
IF NOT .FIELD_PTR [crm$v_string_type]
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
'SYNCHRONIZED does not apply to this datatype - ignored');
OK_SYNC = FALSE;
END;
IF .OK_SYNC
THEN BEGIN
ADDITIONAL_BLK [cra$v_sync_left] = .SYNC_LEFT_FL;
ADDITIONAL_BLK [cra$v_sync_right] = .SYNC_RIGHT_FL;
END;
END;
! Clean up temporary storage for field attributes.
CLEAR_ATTRIBUTE_FLAGS ();
STRING_UNITS = 0;
COPY_NAME [STR$H_LENGTH] = 0;
IF .VALUE_LIST NEQA NULL_PTR
THEN FREE_STRINGLIST (.VALUE_LIST);
VALUE_LIST = NULL_PTR;
IF .FIRST_VALUE_LIST NEQA NULL_PTR
THEN FREE_STRINGLIST (.FIRST_VALUE_LIST);
FIRST_VALUE_LIST = NULL_PTR;
IF .FIRST_DIMENSION NEQA NULL_PTR
THEN FREE_DIMENSIONS (.FIRST_DIMENSION);
FIRST_DIMENSION = NULL_PTR;
LAST_DIMENSION = NULL_PTR;
FIELD_NAME [STR$H_LENGTH] = 0;
IF .QUAL_NAME NEQA NULL_PTR
THEN FREE_STRINGLIST (.QUAL_NAME);
QUAL_NAME = NULL_PTR;
TAG_VALUES_LIST = NULL_PTR;
! Figure out where to hook this field into the structure.
! If this is the first member in a record, point to/from the record node:
IF .STACK_TOP EQLA NULL_PTR
THEN BEGIN
FIELD_PTR [crm$v_first_child] = TRUE;
RECORD_BLK [crx$a_root] = .FIELD_PTR;
FIELD_PTR [crm$a_previous] = .RECORD_BLK;
END
ELSE
! If the current top node is a leaf, then the new node is a sibling.
! If the current top node is an aggregate, then the new one is a child.
! When we are through processing an aggregate, we set its leaf flag.
! See the code in END_SET, below.
IF .STACK_TOP [crm$v_facility_use_1] ! A sibling of the top field
THEN BEGIN
FIELD_PTR [crm$a_previous] = .STACK_TOP;
STACK_TOP [crm$a_next] = .FIELD_PTR;
! Find parent of sibling group and increment its child count.
CHILD_PTR = .STACK_TOP;
PARENT_PTR = .STACK_TOP [crm$a_previous];
WHILE (.PARENT_PTR [crm$a_children] NEQA .CHILD_PTR)
DO BEGIN
CHILD_PTR = .PARENT_PTR;
PARENT_PTR = .CHILD_PTR [crm$a_previous];
END;
PARENT_PTR [crm$w_children_cnt] =
.PARENT_PTR [crm$w_children_cnt] + 1;
END
ELSE ! First child of the top node
BEGIN
FIELD_PTR [crm$a_previous] = .STACK_TOP;
STACK_TOP [crm$a_children] = .FIELD_PTR;
STACK_TOP [crm$w_children_cnt] = 1;
FIELD_PTR [crm$v_first_child] = TRUE;
END;
! This is now the top field.
STACK_TOP = .FIELD_PTR;
! Set flag if this is a leaf. Clear flag if it is an aggregate.
! A COPY field counts as a leaf because it is already a completed aggregate.
IF .CODE EQLU DEFINE_ELEMENTARY OR .CODE EQLU DEFINE_COPY
THEN FIELD_PTR [crm$v_facility_use_1] = TRUE
ELSE FIELD_PTR [crm$v_facility_use_1] = FALSE;
RETURN SS$_NORMAL
END;
!++
! DEFINE_GROUP_ATTS (DEFGRP)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine defines the length attribute for the group level fields
! and the offset attribute for all fields for the record currently being
! parsed.
! It also materializes the fields of a COPY template.
! It is called for GROUP_ATTS.
!
! CALLING SEQUENCE:
!
! DEFINE_GROUP_ATTS (field_blk.ra.v, field_offset.mlu.a,
! total_offset.mlu.a, fld_length.mlu.a);
!
! INPUT PARAMETERS:
!
! field_blk is the address of the field block whose attributes
! are to be defined.
!
! field_offset is the address of a (long)word containing the offset
! from the beginning of the parent field where the
! prior field ended.
!
! total_offset is the address of a (long)word containing the offset
! from the beginning of the record to where the prior
! field ended.
!
! OUTPUT PARAMETERS:
!
! field_offset is the address of a (long)word to be set to the offset
! of the end of the current field from the beginning
! of the parent field.
!
! total_offset is the address of a (long)word to be set to the offset
! of the end of the current field from the beginning of
! the record.
!
! fld_length is the address of a (long)word to be set to the length
! of the current field.
!
! IMPLICIT INPUTS:
!
! none
!
! IMPLICIT OUTPUTS:
!
! none
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
! FALSE indicates an undefined group attribute, invalid group
! attributes of a variants or structure field, or length
! of a structure or variants was invalid.
! Status of COPY_RECORD, if this is a copy field.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE DEFINE_GROUP_ATTS (FIELD_BLK, FIELD_OFFSET, TOTAL_OFFSET, FLD_LENGTH) =
BEGIN
MAP
FIELD_BLK : REF CRX_MEMBER;
BIND
ADDITIONAL_BLK = .FIELD_BLK [crm$a_facility]: crx_additional,
OFFSET = .FIELD_OFFSET %BLISS32 (: LONG),
MEMBER_OFFSET = .TOTAL_OFFSET %BLISS32 (: LONG),
TOTAL_LENGTH = .FLD_LENGTH %BLISS32 (: LONG);
LOCAL
CHILD_BLK : REF CRX_MEMBER,
CHILD_OFFSET %BLISS32 (: LONG),
CHILD_MEMBER_OFFSET %BLISS32 (: LONG),
CHILD_LENGTH %BLISS32 (: LONG),
COPY_NAME: $STR_DESCRIPTOR (CLASS = DYNAMIC),
COPY_FIELD %BLISS32 (: LONG),
MAX_CHILD_LENGTH %BLISS32 (: LONG),
MAX_CHILD_MEMBER_LENGTH %BLISS32 (: LONG),
LENGTH %BLISS32 (: LONG),
STATUS %BLISS32 (: LONG);
LITERAL
THIS_SYS = %BLISS32 (SYS_8BIT) %BLISS36 (SYS_LCG);
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called DEFINE_GROUP_ATTS'));
! Handle a COPY template.
COPY_FIELD = FALSE;
IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_COPY
THEN BEGIN
$STR_DESC_INIT (DESCRIPTOR = COPY_NAME, CLASS = DYNAMIC);
$STR_COPY (STRING = (.field_blk [crm$w_source_length],
.field_blk [crm$a_source_type]),
TARGET = COPY_NAME);
STATUS = COPY_RECORD (.FIELD_BLK, COPY_NAME);
IF NOT .STATUS
THEN RETURN .STATUS;
COPY_FIELD = TRUE;
FIX_COPY_TEMPLATE (.FIELD_BLK, 0);
END;
COMPUTE_OFFSETS (offset, member_offset, .field_blk, this_sys);
! Figure out offsets.
FIELD_BLK [crm$l_offset] = .OFFSET;
FIELD_BLK [crm$l_member_offset] = .MEMBER_OFFSET;
ADDITIONAL_BLK [cra$v_offset_set] = TRUE;
IF .COPY_FIELD
THEN BEGIN ! Offsets here only work if COPY is from CDD
OFFSET = .OFFSET + .FIELD_BLK [crm$l_length];
MEMBER_OFFSET = .MEMBER_OFFSET + .FIELD_BLK [crm$l_member_length];
IF .ADDITIONAL_BLK [cra$v_dimension]
THEN COMPUTE_ARRAY_LENGTH (OFFSET, MEMBER_OFFSET, .FIELD_BLK,
this_sys);
TOTAL_LENGTH = .FIELD_BLK [crm$l_length];
RETURN SS$_NORMAL;
END;
! Elementary fields must have lengths.
IF (.ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_ELEMENTARY) AND
(NOT .ADDITIONAL_BLK [cra$v_length_set])
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
'Field length not determined');
RETURN FALSE;
END;
! Handle VARIANTS field.
! The length of a VARIANTS field is the length of the longest VARIANT.
IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_VARIANTS
THEN BEGIN
CHILD_BLK = .FIELD_BLK [crm$a_children];
WHILE .CHILD_BLK NEQA NULL_PTR DO
BEGIN
CHILD_OFFSET = .OFFSET;
CHILD_MEMBER_OFFSET = .MEMBER_OFFSET;
STATUS = DEFINE_GROUP_ATTS (.CHILD_BLK, CHILD_OFFSET,
CHILD_MEMBER_OFFSET, CHILD_LENGTH);
IF NOT .STATUS
THEN RETURN FALSE;
IF .CHILD_LENGTH GTRU .FIELD_BLK [crm$l_length]
THEN FIELD_BLK [crm$l_length] = .CHILD_LENGTH;
CHILD_BLK = .CHILD_BLK [crm$a_next];
END;
ADDITIONAL_BLK [cra$v_length_set] = TRUE;
FIELD_BLK [crm$l_member_length] = .FIELD_BLK [crm$l_length];
END;
! For VARIANT and STRUCTURE, walk the children:
IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_VARIANT OR
.ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_STRUCTURE
THEN BEGIN
IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_STRUCTURE
THEN CHILD_OFFSET = 0 ! Start new structure
ELSE CHILD_OFFSET = .OFFSET; ! The VARIANT is not a structure
CHILD_MEMBER_OFFSET = .MEMBER_OFFSET;
CHILD_BLK = .FIELD_BLK [crm$a_children];
MAX_CHILD_LENGTH = 0;
MAX_CHILD_MEMBER_LENGTH = 0;
WHILE .CHILD_BLK NEQA NULL_PTR DO
BEGIN
STATUS = DEFINE_GROUP_ATTS (.CHILD_BLK, CHILD_OFFSET,
CHILD_MEMBER_OFFSET, CHILD_LENGTH);
IF NOT .STATUS
THEN RETURN FALSE;
IF .CHILD_BLK [crm$l_length] GTR
.MAX_CHILD_LENGTH
THEN MAX_CHILD_LENGTH = .CHILD_BLK [crm$l_length];
IF .CHILD_BLK [crm$l_member_length] GTR
.MAX_CHILD_MEMBER_LENGTH
THEN MAX_CHILD_MEMBER_LENGTH =
.CHILD_BLK [crm$l_member_length];
LENGTH = .CHILD_BLK [crm$l_offset] +
.CHILD_BLK [crm$l_member_length];
CHILD_BLK = .CHILD_BLK [crm$a_next];
END;
IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_VARIANT
THEN LENGTH = .LENGTH - .OFFSET;
IF NOT .ADDITIONAL_BLK [cra$v_length_set]
THEN BEGIN
FIELD_BLK [crm$l_member_length] = .LENGTH;
IF .ADDITIONAL_BLK [cra$l_type] EQLU FLD$K_STRUCTURE
THEN FIELD_BLK [crm$l_length] = .LENGTH
ELSE BEGIN
FIELD_BLK [crm$l_length] = .MAX_CHILD_LENGTH;
ADDITIONAL_BLK [cra$l_max_member_length] =
.MAX_CHILD_MEMBER_LENGTH;
END;
ADDITIONAL_BLK [cra$v_length_set] = TRUE;
END
ELSE
IF .FIELD_BLK [crm$l_length] LSSU .LENGTH
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (.ADDITIONAL_BLK [cra$l_locator],
'Invalid length');
RETURN FALSE;
END;
END;
! Update offsets to those of end of field for return from this routine:
COMPUTE_END_OFFSETS (OFFSET, MEMBER_OFFSET, .FIELD_BLK, THIS_SYS);
! Update offsets to add additional length caused by dimensions:
IF .ADDITIONAL_BLK [cra$v_dimension]
THEN COMPUTE_ARRAY_LENGTH (OFFSET, MEMBER_OFFSET, .FIELD_BLK, THIS_SYS);
! Compute total length of field:
TOTAL_LENGTH = .FIELD_BLK [crm$l_length];
RETURN SS$_NORMAL
END;
!++
! DEFINE_NUM_ATT (DEFNUM)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine defines the aligned or digits attributes for the field
! whose attributes are currently being parsed.
! It is called for DIGITS_ATT and ALIGNED_ATT.
!
! CALLING SEQUENCE:
!
! DEFINE_NUM_ATT (code.rlu.v);
!
! INPUT PARAMETERS:
!
! code is a (long)word value sent from the parser. It is used
! to define the type of attribute to be described.
!
! IMPLICIT INPUTS:
!
! ALIGNMENT_FL Alignment-seen flag
! DIGITS_FL Digits-seen flag
! PAT$TOKEN_CURRENT_PTR Current token
!
! IMPLICIT OUTPUTS:
!
! ALIGNMENT ALIGNED value
! ALIGNMENT_FL Alignment-seen flag, set
! BASE_FL Base-seen flag, set
! DIGITS DIGITS value
! DIGITS_FL Digits-seen flag, set
! FIELD_BASE Base value, set to 10 by default
! MAX_DIGITS Maximum-digits value
! MAX_DIGITS_FL Maximum-digits-seen flag
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
! FALSE Indicates a multiply-defined attribute.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE DEFINE_NUM_ATT (CODE) =
BEGIN
%BLISS32 ( MAP
CODE : LONG;)
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called DEFINE_NUM_ATT'));
! Handle ALIGNED_ATT:
IF .CODE EQLU ALIGNED_ATT
THEN IF .ALIGNMENT_FL
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Multiple ALIGNED attributes');
RETURN FALSE;
END
ELSE BEGIN
ALIGNMENT_FL = TRUE;
ALIGNMENT = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);
END
! Handle DIGITS_ATT:
ELSE IF .DIGITS_FL
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Multiple DIGITS attributes');
RETURN FALSE;
END
ELSE BEGIN
DIGITS_FL = TRUE;
DIGITS = LS_LEX_INTVALUE (PAT$TOKEN_CURRENT_PTR);
MAX_DIGITS_FL = TRUE;
MAX_DIGITS = .DIGITS;
BASE_FL = TRUE;
FIELD_BASE = 10;
END;
RETURN SS$_NORMAL
END;
!++
! DEFINE_RECORD (DEFREC)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine defines the name and description for the record being
! described. It initializes the crx_record RECORD_BLK.
! It is called for DEFINE_THE_RECORD when the end of the DEFINE
! RECORD clause is seen.
!
! CALLING SEQUENCE:
!
! DEFINE_RECORD (root);
!
! INPUT PARAMETERS:
!
! root Address where caller wants root of record tree
! (also in RECORD_BLK)
!
! IMPLICIT INPUTS:
!
! RECORD_BLK Current (old) record block, if any
!
! IMPLICIT OUTPUTS:
!
! NAME_BLOCK Name of record, cleared
! RECORD_BLK Initialized
! RECORD_NAME Name of record
! STACK_TOP Reset to a null pointer
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE DEFINE_RECORD (root) : NOVALUE =
BEGIN
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called DEFINE_RECORD'));
! If there was a record block already, get rid of it and anything it
! points to.
IF ..ROOT NEQA NULL_PTR
THEN FREE_RECORD (..ROOT);
! Reset STACK_TOP, in case there is some old address in there:
STACK_TOP = NULL_PTR;
! Set up record block:
$XPO_GET_MEM (FULLWORDS = diu$S_CRX_RECORD, FILL = 0, RESULT = RECORD_BLK);
! Set record root where caller wants it:
.root = .record_blk;
! Initialize the new record block:
RECORD_BLK [crx$l_mbz] = NULL_PTR; ! Must be zero
RECORD_BLK [crx$b_id] = crx$k_record; ! Block id
RECORD_BLK [crx$b_core_level] = 4; ! Core level (must be 4)
ch$move (10, ch$ptr (uplit ('CDD$RECORD')),
ch$ptr (RECORD_BLK [crx$t_protocol])); ! Protocol name
RECORD_BLK [crx$w_facility_code] = 0; ! Facility code
RECORD_BLK [crx$b_description_cnt] = 0; ! Description count
RECORD_BLK [crx$a_facility] = NULL_PTR; ! Facility code
RECORD_BLK [crx$l_format] = CDD$K_REC_FIXED; ! Fixed or Variable
RECORD_BLK [crx$a_description] = NULL_PTR; ! Pointer to description
! Save record name:
$STR_DESC_INIT (DESCRIPTOR = RECORD_NAME, CLASS = DYNAMIC);
RECORD_NAME [str$a_pointer] = .NAME_BLOCK [str$a_pointer];
RECORD_NAME [str$h_length] = .NAME_BLOCK [str$h_length];
NAME_BLOCK [STR$H_LENGTH] = 0;
! Clean up attribute flags.
CLEAR_ATTRIBUTE_FLAGS ();
END;
!++
! DEFINE_SCALE (DEFSCL)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine defines the scale attribute for the field currently being
! defined.
! For fractions, the scale value is the negative of the number of
! fractional digits.
! It is called for SCALE_ATT and FRACTIONS_ATT.
!
! CALLING SEQUENCE:
!
! DEFINE_SCALE (scale_value.rlu.v);
!
! INPUT PARAMETERS:
!
! scale_value is a (long)word value representing the scale.
!
! IMPLICIT INPUTS:
!
! PAT$TOKEN_CURRENT_PTR Current token
! SCALE_FL Scale-seen flag
!
! IMPLICIT OUTPUTS:
!
! BASE_FL Base-seen flag, set
! FIELD_BASE Base value, set to 10 by default
! SCALE Scale value
! SCALE_FL Scale-seen flag, updated
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
! FALSE Indicates multiple scale factors.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE DEFINE_SCALE (SCALE_VALUE) =
BEGIN
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called DEFINE_SCALE'));
IF NOT .SCALE_FL
THEN BEGIN
SCALE = .SCALE_VALUE;
SCALE_FL = TRUE;
BASE_FL = TRUE;
FIELD_BASE = 10;
RETURN SS$_NORMAL;
END;
IF .SCALE NEQU .SCALE_VALUE
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Inconsistent scale factors not allowed');
RETURN FALSE;
END;
RETURN SS$_NORMAL
END;
!++
! END_SET (ENDSET)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine does the necessary flag setting in the field block when
! an end statement has been encountered. It also verifies that the name
! used in an end statement matches the corresponding defined name, if one
! was specified.
! It is called for DEFINE_END_NO_NAME, DEFINE_END_NAME, END_NO_NAME,
! and END_NAME.
!
! CALLING SEQUENCE:
!
! END_SET (code.rlu.v);
!
! INPUT PARAMETERS:
!
! code is a (long)word value that determines if a name was
! supplied in the end statement.
!
! IMPLICIT INPUTS:
!
! NAME_BLOCK Descriptor to name in END clause, if any
! PAT$TOKEN_CURRENT_PTR Current token
! STACK_TOP Current crx_member
!
! IMPLICIT OUTPUTS:
!
! STACK_TOP Reset to top crx_member in structure
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
! FALSE Indicates that the name in the END statement does
! not match.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE END_SET (CODE) =
BEGIN
%BLISS32 ( MAP
CODE : LONG;)
LITERAL
L_PAREN = %C'(',
R_PAREN = %C')',
DOT = %C'.';
LOCAL
CURRENT: REF CRX_MEMBER,
REF_CHAR %BLISS32 (: LONG),
LAST_CHAR %BLISS32 (: LONG);
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called END_SET'));
! Reset the stack top if it was pointing to the field's child.
IF .STACK_TOP NEQA NULL_PTR AND .STACK_TOP [crm$v_facility_use_1]
AND .STACK_TOP NEQA .RECORD_BLK [crx$a_root] ! Not the only field
THEN BEGIN ! Look for field who is parent rather than sibling
CURRENT = .STACK_TOP [crm$a_previous];
WHILE (.CURRENT [crm$a_children] NEQA .STACK_TOP)
DO BEGIN
STACK_TOP = .CURRENT;
CURRENT = .STACK_TOP [crm$a_previous];
END;
STACK_TOP = .CURRENT;
END;
! Close off the aggregate. After this, treat it as a leaf.
! See the code in DEFINE_FIELD for uses of this flag.
IF .STACK_TOP NEQA NULL_PTR
THEN STACK_TOP [crm$v_facility_use_1] = TRUE;
! Check if a structure name was specified. If not, then return.
IF (.CODE EQLU END_NO_NAME) OR (.CODE EQLU DEFINE_END_NO_NAME)
OR (.CODE EQLU DEFINE_END_NAME)
THEN RETURN SS$_NORMAL;
IF .STACK_TOP NEQA NULL_PTR
THEN BEGIN
IF CH$EQL (.STACK_TOP [crm$b_name_length],
ch$ptr (STACK_TOP [crm$t_name]),
.NAME_BLOCK [str$h_length],
.NAME_BLOCK [STR$A_POINTER], %C' ')
THEN RETURN SS$_NORMAL
ELSE
BEGIN
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Structure names do not match');
RETURN FALSE;
END;
END;
! If the defined name is a path-name, then extract the given name for
! comparison. (i.e. Trim any password and preceding node names.)
REF_CHAR = ch$plus (.RECORD_NAME [str$a_pointer],
.RECORD_NAME [str$h_length]);
IF CH$RCHAR (.REF_CHAR) EQLU R_PAREN
THEN BEGIN
WHILE CH$RCHAR (.REF_CHAR) NEQU L_PAREN DO
REF_CHAR = ch$plus (.REF_CHAR, -1);
REF_CHAR = ch$plus (.REF_CHAR, -1);
END;
LAST_CHAR = .REF_CHAR;
WHILE (CH$DIFF (.REF_CHAR, .RECORD_NAME [str$a_pointer]) GTR 0)
AND CH$RCHAR (ch$plus (.REF_CHAR, -1)) NEQU DOT
DO
REF_CHAR = ch$plus (.REF_CHAR, -1);
IF CH$EQL (ch$diff (.LAST_CHAR, .REF_CHAR) + 1, .REF_CHAR,
.NAME_BLOCK [STR$H_LENGTH], .NAME_BLOCK [STR$A_POINTER], %C' ')
THEN RETURN SS$_NORMAL;
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Record name mismatch');
RETURN FALSE
END;
!++
! EXTRACT_NAME (EXTNAM)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine extracts a path name or CDD name from the present token
! block and places it in the NAME_BLOCK. If a pathname contains a
! relative version number, the semicolon and version number are
! stripped off the pathname before it is placed in the NAME_BLOCK,
! and a warning is issued.
! This routine is called for STORE_NAME.
!
! CALLING SEQUENCE:
!
! EXTRACT_NAME (locator.rlu.v);
!
! INPUT PARAMETERS:
!
! locator is the (long)word value of the source locator.
!
! IMPLICIT INPUTS:
!
! NAME_BLOCK Old name block, if any (freed)
! PAT$TOKEN_CURRENT_PTR Pointer to the most recently read lexical token.
!
! IMPLICIT OUTPUTS:
!
! NAME_BLOCK Name block, created
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE EXTRACT_NAME (LOCATOR) : NOVALUE =
BEGIN
%BLISS32 ( MAP
LOCATOR : LONG;)
LITERAL
SEMI = %C';',
MINUS = %C'-',
ZERO = %C'0',
L_PAREN = %C'(';
LOCAL
SEMI_PTR %BLISS32 (: LONG),
VERNUM_PTR %BLISS32 (: LONG),
L_PAREN_PTR %BLISS32 (: LONG),
LAST_CHAR_PTR %BLISS32 (: LONG),
NEXT_CHAR %BLISS32 (: BYTE),
REL_VER_NUM %BLISS32 (: BYTE),
PASSWORD_LENG %BLISS32 (: WORD),
PATHNAME_LENG %BLISS32 (: WORD),
LENGTH %BLISS32 (: WORD);
BIND TOKEN = (LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR)): $STR_DESCRIPTOR ();
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called EXTRACT_NAME'));
! See if the name in PAT$TOKEN_CURRENT_PTR contains a relative version number.
SEMI_PTR = CH$FIND_CH (.TOKEN [STR$H_LENGTH],
.TOKEN [STR$A_POINTER], SEMI);
REL_VER_NUM = FALSE;
IF NOT CH$FAIL (.SEMI_PTR)
THEN BEGIN
LAST_CHAR_PTR = ch$plus (.TOKEN [STR$A_POINTER],
.TOKEN [STR$H_LENGTH] - 1);
PATHNAME_LENG = ch$diff (.SEMI_PTR, .TOKEN [STR$A_POINTER]);
VERNUM_PTR = .SEMI_PTR;
NEXT_CHAR = CH$A_RCHAR (VERNUM_PTR);
REL_VER_NUM = FALSE;
IF .NEXT_CHAR EQLU MINUS
THEN REL_VER_NUM = TRUE
ELSE IF .NEXT_CHAR EQLU ZERO
THEN BEGIN
REL_VER_NUM = TRUE;
WHILE (.NEXT_CHAR NEQU L_PAREN) AND
(ch$diff (.LAST_CHAR_PTR, .VERNUM_PTR) GTR 0)
AND .REL_VER_NUM DO BEGIN
NEXT_CHAR = CH$A_RCHAR (VERNUM_PTR);
IF .NEXT_CHAR NEQU ZERO
THEN REL_VER_NUM = FALSE;
END;
END;
END;
! If the name contains a relative version number, see if it also contains
! a password.
IF .REL_VER_NUM
THEN BEGIN
L_PAREN_PTR = CH$FIND_CH (.TOKEN [STR$H_LENGTH],
.TOKEN [STR$A_POINTER], L_PAREN);
IF NOT CH$FAIL (.L_PAREN_PTR)
THEN PASSWORD_LENG = ch$diff (.LAST_CHAR_PTR, .L_PAREN_PTR) + 1
ELSE PASSWORD_LENG = 0;
END;
! Set up NAME_BLOCK.
IF .REL_VER_NUM
THEN LENGTH = .PATHNAME_LENG + .PASSWORD_LENG
ELSE LENGTH = .TOKEN [STR$H_LENGTH];
IF .NAME_BLOCK [STR$H_LENGTH] NEQU 0
THEN $XPO_FREE_MEM (STRING = NAME_BLOCK);
NAME_BLOCK [STR$H_LENGTH] = .LENGTH;
$STR_DESC_INIT (DESCRIPTOR = NAME_BLOCK, CLASS = DYNAMIC);
$XPO_GET_MEM (CHARACTERS = .LENGTH,
DESCRIPTOR = NAME_BLOCK);
! Move the name to NAME_BLOCK, without the version number if it is relative.
! And don't forget the password!
IF .REL_VER_NUM
THEN BEGIN
LAST_CHAR_PTR = CH$MOVE (.PATHNAME_LENG,
.TOKEN [STR$A_POINTER], .NAME_BLOCK [STR$A_POINTER]);
IF .PASSWORD_LENG NEQU 0
THEN CH$MOVE (.PASSWORD_LENG, .L_PAREN_PTR, .LAST_CHAR_PTR);
END
ELSE
CH$MOVE (.LENGTH, .TOKEN [STR$A_POINTER],
.NAME_BLOCK [STR$A_POINTER]);
END;
!++
! FULLY_QUALIFIED_NAME (FULQUL)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine creates and initializes the stringlist blocks for a fully
! qualified name.
! QUAL_NAME is set to point to the resulting stringlists.
! It is called for FULLY_QUAL.
! The fully-qualified name is either the variable name in an OCCURS
! DEPENDING or the tag name in VARIANTS OF.
!
! CALLING SEQUENCE:
!
! FULLY_QUALIFIED_NAME ();
!
! INPUT PARAMETERS:
!
! none
!
! IMPLICIT INPUTS:
!
! NAME_BLOCK Current name
!
! IMPLICIT OUTPUTS:
!
! NAME_BLOCK Current name, cleared
! QUAL_NAME Pointer to stringlist of fully-qualified name
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
! FALSE Indicates that the name contained passwords or a
! version number
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE FULLY_QUALIFIED_NAME =
BEGIN
LOCAL
NEW_NAME : REF crx_stringlist,
LATEST_NAME : REF crx_stringlist,
STR_LENGTH %BLISS32 (: WORD),
REM_LENGTH %BLISS32 (: WORD),
NAME_START %BLISS32 (: LONG),
NAME_END %BLISS32 (: LONG);
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called FULLY_QUALIFIED_NAME'));
IF .NAME_BLOCK [STR$H_LENGTH] EQLU 0
THEN RETURN SS$_NORMAL;
! Make sure that no passwords are in the pathname. Print an error and return
! if it contains passwords.
NAME_END = CH$FIND_CH (
.NAME_BLOCK [STR$H_LENGTH], .NAME_BLOCK [STR$A_POINTER], %C'(');
IF NOT CH$FAIL (.NAME_END)
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Illegal fully qualified name');
RETURN FALSE;
END;
! Make sure that no version number is in the pathname. Print an error
! and return if it contains a version number.
NAME_END = CH$FIND_CH (
.NAME_BLOCK [STR$H_LENGTH], .NAME_BLOCK [STR$A_POINTER], %C';');
IF NOT CH$FAIL (.NAME_END)
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Illegal fully qualified name');
RETURN FALSE;
END;
NAME_START = .NAME_BLOCK [STR$A_POINTER];
NAME_END = .NAME_START;
! Get the names and place them in a list of stringlists.
WHILE (ch$diff (
ch$plus (.NAME_BLOCK [STR$A_POINTER], .NAME_BLOCK [STR$H_LENGTH]),
.NAME_END)
NEQ 0)
DO BEGIN
$XPO_GET_MEM (FULLWORDS = diu$s_crx_stringlist, RESULT = NEW_NAME,
FILL = 0);
INIT_STRINGLIST (.NEW_NAME);
IF (.QUAL_NAME NEQA NULL_PTR)
THEN BEGIN ! Attach new piece to end of list
NEW_NAME [crs$a_previous] = .LATEST_NAME;
LATEST_NAME [crs$a_next] = .NEW_NAME;
LATEST_NAME = .NEW_NAME;
END
ELSE BEGIN ! Start list of stringlists
QUAL_NAME = .NEW_NAME;
LATEST_NAME = .NEW_NAME;
END;
REM_LENGTH = ch$diff
(ch$plus (.NAME_BLOCK [STR$A_POINTER],
.NAME_BLOCK [STR$H_LENGTH]),
.NAME_START);
NAME_END = CH$FIND_CH (.REM_LENGTH, .NAME_START, %C'.');
IF CH$FAIL (.NAME_END) ! Point to last char. in name string
THEN NAME_END = ch$plus (.NAME_BLOCK [STR$A_POINTER],
.NAME_BLOCK [STR$H_LENGTH]);
STR_LENGTH = ch$diff (.NAME_END, .NAME_START);
NEW_NAME [crs$w_string_length] = .STR_LENGTH;
$XPO_GET_MEM (CHARACTERS = .STR_LENGTH,
RESULT = NEW_NAME [crs$a_string]);
CH$MOVE (.STR_LENGTH, .NAME_START, .NEW_NAME [crs$a_string]);
NAME_START = ch$plus (.NAME_END, 1); ! Skip over the '.'.
END;
! Clear the name pointer block.
$XPO_FREE_MEM (STRING = NAME_BLOCK);
NAME_BLOCK [STR$H_LENGTH] = 0;
RETURN SS$_NORMAL
END;
!++
! SAVE_COMPLEX_VALUE (SAVCPX)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine stores part of a complex number in SAVED_VALUE1 (real part)
! or SAVED_VALUE2 (imaginary part) for future use.
! It is called for SAVE_COMPLEX1 and SAVE_COMPLEX2.
! The complex value is either an initial value (see CREATE_STR_ATT)
! or a tag value in a VARIANT (see SETUP_VALUE_RANGE, SAVE_LOWER_BOUND,
! and SAVE_VALUES_LIST).
!
! CALLING SEQUENCE:
!
! SAVE_COMPLEX_VALUE (code.rlu.v);
!
! INPUT PARAMETERS:
!
! code is a (long)word flag used to determine whether the
! first or second half of the complex number is being
! defined.
!
! IMPLICIT INPUTS:
!
! PAT$TOKEN_CURRENT_PTR Current lexical token
!
! IMPLICIT OUTPUTS:
!
! SAVED_TYPE Datatype of SAVED_VALUE
! SAVED_TYPE1 Token type of real part of complex value
! SAVED_TYPE2 Token type of imaginary part
! SAVED_VALUE1 Real part of complex value
! SAVED_VALUE2 Imaginary part of complex value
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE SAVE_COMPLEX_VALUE (CODE) : NOVALUE =
BEGIN
%BLISS32 ( MAP
CODE : LONG;)
LOCAL
VALUE : REF $STR_DESCRIPTOR (CLASS=DYNAMIC);
BIND
TOKEN = (LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR)): $STR_DESCRIPTOR (),
TERM = (LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR));
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called SAVE_COMPLEX_VALUE'));
VALUE = (IF .CODE EQLU SAVE_COMPLEX1 THEN SAVED_VALUE1 ELSE SAVED_VALUE2);
IF .CODE EQL SAVE_COMPLEX1
THEN SAVED_TYPE1 = TERM
ELSE SAVED_TYPE2 = TERM;
SAVED_TYPE = NT_COMPLEX_NUMBER;
VALUE [STR$H_LENGTH] = .TOKEN [STR$H_LENGTH];
$STR_DESC_INIT (DESCRIPTOR = .VALUE, CLASS = DYNAMIC);
$XPO_GET_MEM (CHARACTERS = .TOKEN [STR$H_LENGTH], DESCRIPTOR = .VALUE);
CH$MOVE (.TOKEN [STR$H_LENGTH], .TOKEN [STR$A_POINTER],
.VALUE [STR$A_POINTER]);
END;
!++
! SAVE_FIELDNAME (SAVFLD)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine saves the current field name.
! The field name is in NAME_BLOCK. The data is moved to FIELD_NAME
! and NAME_BLOCK is cleared.
! Ths routine is called for SAVE_FIELD_NAME.
!
! CALLING SEQUENCE:
!
! SAVE_FIELDNAME ();
!
! INPUT PARAMETERS:
!
! none
!
! IMPLICIT INPUTS:
!
! NAME_BLOCK: Descriptor for the name
!
! IMPLICIT OUTPUTS:
!
! FIELD_NAME: Descriptor for the field name
! NAME_BLOCK: Cleared
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE SAVE_FIELDNAME : NOVALUE =
BEGIN
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_ROUTINE called SAVE_FIELDNAME'));
IF .FIELD_NAME [STR$H_LENGTH] NEQU 0
THEN RETURN;
$STR_DESC_INIT (DESCRIPTOR = FIELD_NAME, CLASS = DYNAMIC);
FIELD_NAME [STR$H_LENGTH] = .NAME_BLOCK [STR$H_LENGTH];
FIELD_NAME [STR$A_POINTER] = .NAME_BLOCK [STR$A_POINTER];
NAME_BLOCK [STR$H_LENGTH] = 0;
END;
!++
! SAVE_SOURCE (SAVSRC)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine saves the current name as the source field name. The
! current field name is in NAME_BLOCK. The data is moved to
! SOURCE_NAME and NAME_BLOCK is cleared.
! This routine is called for SOURCE.
!
! CALLING SEQUENCE:
!
! SAVE_SOURCE ();
!
! INPUT PARAMETERS:
!
! none
!
! IMPLICIT INPUTS:
!
! NAME_BLOCK: Descriptor for the name
!
! IMPLICIT OUTPUTS:
!
! SOURCE_NAME: Descriptor for the source name
! NAME_BLOCK: Cleared
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE SAVE_SOURCE : NOVALUE =
BEGIN
DEB_EVENT ('Semantic actions',
PUT_MSG_EOL ('ACTION_RTN called SAVE_SOURCE'));
IF .SOURCE_NAME [STR$H_LENGTH] NEQU 0
THEN RETURN;
$STR_DESC_INIT (DESCRIPTOR = SOURCE_NAME, CLASS = DYNAMIC);
SOURCE_NAME [STR$H_LENGTH] = .NAME_BLOCK [STR$H_LENGTH];
SOURCE_NAME [STR$A_POINTER] = .NAME_BLOCK [STR$A_POINTER];
NAME_BLOCK [STR$H_LENGTH] = 0;
END;
!++
! SAVE_DEST (SAVDST)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine saves the current name as the destination field name.
! The current name is in NAME_BLOCK. The data is moved to DEST_NAME
! and NAME_BLOCK is cleared.
! This routine is called for DEST.
!
! CALLING SEQUENCE:
!
! SAVE_DEST ();
!
! INPUT PARAMETERS:
!
! none
!
! IMPLICIT INPUTS:
!
! NAME_BLOCK: descriptor for the name
!
! IMPLICIT OUTPUTS:
!
! DEST_NAME: Descriptor for the destination name
! NAME_BLOCK: Cleared
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! COMPLETION STATUS:
!
! none
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE SAVE_DEST : NOVALUE =
BEGIN
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called SAVE_DEST'));
IF .DEST_NAME [STR$H_LENGTH] NEQU 0
THEN RETURN;
$STR_DESC_INIT (DESCRIPTOR = DEST_NAME, CLASS = DYNAMIC);
DEST_NAME [STR$H_LENGTH] = .NAME_BLOCK [STR$H_LENGTH];
DEST_NAME [STR$A_POINTER] = .NAME_BLOCK [STR$A_POINTER];
NAME_BLOCK [STR$H_LENGTH] = 0;
END;
!++
! SAVE_LOWER_BOUND (SAVLWR)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine saves the current lower bound of a range of values in
! SAVED_LOWERn.
! It is called for SAVE_VAL_TYPE.
!
! CALLING SEQUENCE:
!
! SAVE_LOWER_BOUND ();
!
! INPUT PARAMETERS:
!
! none
!
! IMPLICIT INPUTS:
!
! PAT$TOKEN_CURRENT_PTR Current token
! SAVED_TYPE Datatype of SAVED_VALUEn
! SAVED_TYPE1 Token type of SAVED_VALUE1
! SAVED_TYPE2 Token type of SAVED_VALUE2
! SAVED_VALUE1 Saved value
! SAVED_VALUE2 ...
!
! IMPLICIT OUTPUTS:
!
! LOWER_TYPE Datatype of SAVED_LOWER
! LOWER_TYPE1 Token type of SAVED_LOWER1
! LOWER_TYPE2 Token type of SAVED_LOWER2
! SAVED_LOWER1 Saved lower bound, cleared
! SAVED_LOWER2 ...
! SAVED_VALUE1 Saved value
! SAVED_VALUE2 ...
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE SAVE_LOWER_BOUND : NOVALUE =
BEGIN
BIND TOKEN = (LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR)): $STR_DESCRIPTOR ();
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called SAVE_LOWER_BOUND'));
IF .SAVED_VALUE1 [STR$H_LENGTH] NEQU 0 ! Complex value
THEN BEGIN
$STR_DESC_INIT (DESCRIPTOR = SAVED_LOWER1, CLASS = DYNAMIC);
SAVED_LOWER1 [STR$H_LENGTH] = .SAVED_VALUE1 [STR$H_LENGTH];
SAVED_LOWER1 [STR$A_POINTER] = .SAVED_VALUE1 [STR$A_POINTER];
$STR_DESC_INIT (DESCRIPTOR = SAVED_LOWER2, CLASS = DYNAMIC);
SAVED_LOWER2 [STR$H_LENGTH] = .SAVED_VALUE2 [STR$H_LENGTH];
SAVED_LOWER2 [STR$A_POINTER] = .SAVED_VALUE2 [STR$A_POINTER];
LOWER_TYPE = .SAVED_TYPE;
LOWER_TYPE1 = .SAVED_TYPE1;
LOWER_TYPE2 = .SAVED_TYPE2;
SAVED_VALUE1 [STR$H_LENGTH] = 0;
SAVED_VALUE2 [STR$H_LENGTH] = 0;
END
ELSE ! Not complex value
BEGIN
SAVED_LOWER1 [STR$H_LENGTH] = .TOKEN [STR$H_LENGTH];
$STR_DESC_INIT (DESCRIPTOR = SAVED_LOWER1, CLASS = DYNAMIC);
$XPO_GET_MEM (CHARACTERS = .TOKEN [STR$H_LENGTH],
DESCRIPTOR = SAVED_LOWER1);
CH$MOVE (.TOKEN [STR$H_LENGTH], .TOKEN [STR$A_POINTER],
.SAVED_LOWER1 [STR$A_POINTER]);
LOWER_TYPE = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);
END;
END;
!++
! SAVE_VALUES_LIST (SAVVAL)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine puts the tag values list into TAG_VALUES_LIST.
! It is called for TAG_VALUES.
!
! CALLING SEQUENCE:
!
! SAVE_VALUES_LIST (code.rlu.v);
!
! INPUT PARAMETERS:
!
! code is a (long)word value that determines which value list
! is to be initialized.
!
! IMPLICIT INPUTS:
!
! FIRST_VALUE_LIST Head of values list
! PAT$TOKEN_CURRENT_PTR Current token
! TAG_VALUES_FL Tag-values-seen flag
!
! IMPLICIT OUTPUTS:
!
! FIRST_VALUE_LIST Head of values list, cleared
! LAST_VALUE_LIST Tail of values list, cleared
! TAG_VALUES_FL Tag-values-seen flag, updated
! TAG_VALUES_LIST Tag values list pointer
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
! FALSE Indicates that there were multiple value lists.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE SAVE_VALUES_LIST (CODE) =
BEGIN
%BLISS32 ( MAP
CODE : LONG;)
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called SAVE_VALUES_LIST'));
IF .TAG_VALUES_FL
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Multiple tag value lists');
RETURN FALSE;
END
ELSE TAG_VALUES_FL = TRUE;
TAG_VALUES_LIST = .FIRST_VALUE_LIST;
FIRST_VALUE_LIST = NULL_PTR;
LAST_VALUE_LIST = NULL_PTR;
RETURN SS$_NORMAL
END;
!++
! SET_SYNCHRONIZED (SETSYN)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine handles the SYNCHRONIZED clause.
!
! CALLING SEQUENCE:
!
! SET_SYNCHRONIZED (code);
!
! INPUT PARAMETERS:
!
! code Value indicating which flag to set
!
! IMPLICIT INPUTS:
!
! PAT$TOKEN_CURRENT_PTR Current lexical token
! SYNC_LEFT_FL Synchronized-left flag
! SYNC_RIGHT_FL Synchronized-right flag
!
! IMPLICIT OUTPUTS:
!
! SYNC_LEFT_FL Synchronized-left flag, set if appropriate
! SYNC_RIGHT_FL Synchronized-right flag, set if appropriate
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
ROUTINE SET_SYNCHRONIZED (CODE): NOVALUE =
BEGIN
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called SET_SYNCHRONIZED'));
IF .SYNC_LEFT_FL OR .SYNC_RIGHT_FL
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Multiple SYNCHRONIZED clauses - ignored');
RETURN;
END;
IF .CODE EQL SYNC_LEFT
THEN SYNC_LEFT_FL = TRUE
ELSE SYNC_RIGHT_FL = TRUE;
RETURN;
END;
!++
! SET_ATT (SETATT)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine is called for JUSTIFIED_R.
!
! CALLING SEQUENCE:
!
! SET_ATT (code.rlu.v);
!
! INPUT PARAMETERS:
!
! code is a (long)word value used to determine the flag to
! be set.
!
! IMPLICIT INPUTS:
!
! JUSTIFIED_RIGHT_FL Justified-right-seen flag
! PAT$TOKEN_CURRENT_PTR Current token
!
! IMPLICIT OUTPUTS:
!
! JUSTIFIED_RIGHT_FL Justified-right-seen flag, set
!
! COMPLETION STATUS:
!
! SS$_NORMAL indicates that the routine completed successfully.
! FALSE if the attribute was multiply-defined.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE SET_ATT (CODE) =
BEGIN
%BLISS32 ( MAP
CODE : LONG;)
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called SET_ATT'));
IF .JUSTIFIED_RIGHT_FL
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Multiple JUSTIFIED_RIGHT clauses');
RETURN FALSE;
END;
JUSTIFIED_RIGHT_FL = TRUE;
RETURN SS$_NORMAL
END;
!++
! SETUP_VALUE_RANGE (SETRNG)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine creates and initializes a SAB block for the next value in
! the value list for the current attribute.
! It is called for LOWER_BND and UPPER_BND.
!
! CALLING SEQUENCE:
!
! SETUP_VALUE_RANGE (code.rlu.v);
!
! INPUT PARAMETERS:
!
! code is a (long)word value that determines which value is to
! be initialized.
!
! IMPLICIT INPUTS:
!
! LOWER_TYPE Datatype of SAVED_LOWERn
! PAT$TOKEN_CURRENT_PTR Pointer to current token
! SAVED_LOWER1 Saved lower bound
! SAVED_LOWER2 ...
! SAVED_TYPE Datatype of SAVED_VALUEn
! SAVED_VALUE1 Saved value
! SAVED_VALUE2 ...
! UPPER_BOUND Upper bound
!
! IMPLICIT OUTPUTS:
!
! SAVED_LOWER1 Saved lower bound, cleared
! SAVED_LOWER2 ...
! SAVED_VALUE1 Saved value, cleared
! SAVED_VALUE2 ...
! UPPER_BOUND Upper bound
! VALUE_LIST Pointer to value list
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE SETUP_VALUE_RANGE (CODE) : NOVALUE =
BEGIN
%BLISS32 ( MAP
CODE : LONG;)
BIND TOKEN = (LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR)): $STR_DESCRIPTOR ();
LOCAL
LENGTH %BLISS32 (: WORD),
SAB_PTR : REF crx_stringlist;
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called SETUP_VALUE_RANGE'));
LENGTH = diu$s_crx_stringlist;
$XPO_GET_MEM (FULLWORDS = .LENGTH, RESULT = SAB_PTR, FILL = 0);
INIT_STRINGLIST (.SAB_PTR);
! Set binary string flag:
SAB_PTR [crs$v_binary_string] = TRUE;
! Upper bound (complex):
IF .CODE EQLU UPPER_BND AND .SAVED_VALUE1 [STR$H_LENGTH] EQLU 0
THEN BEGIN
LENGTH = .TOKEN [STR$H_LENGTH];
SAB_PTR [crs$w_string_length] = .LENGTH;
$XPO_GET_MEM (CHARACTERS = .LENGTH,
RESULT = SAB_PTR [crs$a_string]);
CH$MOVE (.LENGTH, .TOKEN [STR$A_POINTER],
.SAB_PTR [crs$a_string]);
UPPER_BOUND = .SAB_PTR;
RETURN;
END;
! Upper bound (not complex):
IF .CODE EQLU UPPER_BND
THEN BEGIN
SAB_PTR [crs$w_string_length] = .SAVED_VALUE1 [STR$H_LENGTH];
SAB_PTR [crs$a_string] = .SAVED_VALUE1 [STR$A_POINTER];
UPPER_BOUND = .SAB_PTR;
SAVED_VALUE1 [STR$H_LENGTH] = 0;
SAVED_VALUE2 [STR$H_LENGTH] = 0;
END
! Lower bound:
ELSE
BEGIN
SAB_PTR [crs$w_string_length] = .SAVED_LOWER1 [STR$H_LENGTH];
SAB_PTR [crs$a_string] = .SAVED_LOWER1 [STR$A_POINTER];
VALUE_LIST = .SAB_PTR;
SAB_PTR [crs$a_next] = .UPPER_BOUND;
UPPER_BOUND = NULL_PTR;
SAVED_LOWER1 [STR$H_LENGTH] = 0;
SAVED_LOWER2 [STR$H_LENGTH] = 0;
END;
END;
!++
! MOVE_STATEMENT (MOVEST)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine creates a transform for a MOVE statement.
! It is called for MOVE_ST.
!
! CALLING SEQUENCE:
!
! STATUS = MOVE_STATEMENT ();
!
! INPUT PARAMETERS:
!
! none
!
! IMPLICIT INPUTS:
!
! DEST_NAME: Destination field name
! DSTRT Root of destination record description tree
! SOURCE_NAME: Source field name
! SRCRT Root of source record description tree
! TRANSFORM_HEAD Head of transform list
! TRANSFORM_TAIL Tail of transform list
!
! IMPLICIT OUTPUTS:
!
! TRANSFORM_HEAD Head of transform list
! TRANSFORM_TAIL Tail of transorm list
!
! COMPLETION STATUS:
!
! TRUE if OK.
! FALSE if not OK.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
ROUTINE MOVE_STATEMENT =
BEGIN
LOCAL
source_fqn: REF crx_stringlist
INITIAL (NULL_PTR), ! Fully-qualified name of source field
dest_fqn: REF crx_stringlist
INITIAL (NULL_PTR), ! Fully-qualified name of destination
status, ! Return status
source_member: REF crx_member
INITIAL (NULL_PTR), ! Source field's member block
dest_member: REF crx_member
INITIAL (NULL_PTR), ! Destination field's member block
source_dim: REF dims
INITIAL (NULL_PTR), ! Source field's dimension list
dest_dim: REF dims
INITIAL (NULL_PTR), ! Destination field's dimension list
new_trans: REF transform_str
INITIAL (NULL_PTR); ! New transform
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called MOVE_STATEMENT'));
status = DEAL_WITH_TRANSFORM_NAMES (source_name, source_fqn, dest_name,
dest_fqn);
IF NOT .status THEN RETURN .status;
status = FIND_NAMES_IN_TREES (.source_fqn, .srcrt, .dest_fqn, .dstrt,
source_member, dest_member, source_dim, dest_dim);
IF NOT .status THEN RETURN .status;
IF CHECK_DIMS (.source_dim, .dest_dim)
THEN RETURN FALSE; ! Dimensions do not match
MAKE_TRANSFORM (.source_fqn, .dest_fqn, .source_member, .dest_member,
.source_dim, .dest_dim, new_trans);
! Hook in transform:
! NOTE: A MOVE statement will only make one transform node, so there is no
! need to walk the list to find the transform tail.
IF .transform_head EQLA NULL_PTR
THEN BEGIN ! First transform in list
transform_head = .new_trans;
transform_tail = .transform_head;
END
ELSE BEGIN ! Add transform to list
transform_tail [TRA_NEXT] = .new_trans;
transform_tail = .new_trans;
END;
RETURN TRUE;
END;
!++
! MM_STATEMENT (MMST)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine creates transforms for a MOVE MATCHING statement.
! It is called for MM_ST.
!
! CALLING SEQUENCE:
!
! STATUS = MM_STATEMENT ();
!
! INPUT PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! DEST_NAME: Destination field name
! DSTRT Root of destination record description tree
! SOURCE_NAME: Source field name
! SRCRT Root of source record description tree
! TRANSFORM_HEAD Head of transform list
! TRANSFORM_TAIL Tail of transform list
!
! IMPLICIT OUTPUTS:
!
! TRANSFORM_HEAD Head of transform list
! TRANSFORM_TAIL Tail of transform list
!
! COMPLETION STATUS:
!
! TRUE if OK.
! FALSE if not OK.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
ROUTINE MM_STATEMENT =
BEGIN
LOCAL
status, ! Return status
new_trans: REF transform_str
INITIAL (NULL_PTR), ! New transform
source_fqn: REF crx_stringlist
INITIAL (NULL_PTR), ! Fully-qualified name for source field
dest_fqn: REF crx_stringlist
INITIAL (NULL_PTR), ! Fully-qualified name for destination
source_member: REF crx_member
INITIAL (NULL_PTR), ! Source field's member block
dest_member: REF crx_member
INITIAL (NULL_PTR), ! Destination field's member block
source_dim: REF dims
INITIAL (NULL_PTR), ! Source field's dimension list
dest_dim: REF dims
INITIAL (NULL_PTR); ! Destination field's dimension list
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called MM_STATEMENT'));
status = DEAL_WITH_TRANSFORM_NAMES (source_name, source_fqn, dest_name,
dest_fqn);
IF NOT .status THEN RETURN .status;
status = FIND_NAMES_IN_TREES (.source_fqn, .srcrt, .dest_fqn, .dstrt,
source_member, dest_member, source_dim, dest_dim);
IF NOT .status THEN RETURN .status;
IF CHECK_DIMS (.source_dim, .dest_dim)
THEN RETURN FALSE; ! Dimensions do not match
DIU$MOVE_MAT (DIU$K_MOV_MAT, source_member, dest_member, new_trans,
.source_dim, .dest_dim);
! Hook the result into the transform list:
! NOTE: A MOVE MATCHING may generate several nodes, so the list must be walked
! after the new piece or pieces has/have been added to find the tail.
IF .transform_head EQLA NULL_PTR
THEN ! First transform(s) in list
transform_head = .new_trans
ELSE ! Add transform(s) to end of list
transform_tail [TRA_NEXT] = .new_trans;
WHILE (.new_trans NEQA NULL_PTR)
DO BEGIN ! Walk the new part looking for the tail of list
transform_tail = .new_trans;
new_trans = .new_trans [TRA_NEXT];
END;
RETURN TRUE;
END;
!++
! MOM_STATEMENT (MOMST)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine creates transforms for MOVE OTHERS MATCHING.
! It is called for MOM_ST.
!
! CALLING SEQUENCE:
!
! STATUS = MOM_STATEMENT ();
!
! INPUT PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! DEST_NAME Destination field name, if any
! DSTRT Root of destination record description tree
! PAT$TOKEN_CURRENT_PTR Current lexical token
! SOURCE_NAME Source field name, if any
! SRCRT Root of source record description tree
! TRANSFORM_HEAD Head of transform list
! TRANSFORM_TAIL Tail of transform list
!
! IMPLICIT OUTPUTS:
!
! TRANSFORM_HEAD Head of transform list
! TRANSFORM_TAIL Tail of transform list
!
! COMPLETION STATUS:
!
! TRUE if OK.
! FALSE if not OK.
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
ROUTINE MOM_STATEMENT =
BEGIN
LOCAL
source_member: REF crx_member
INITIAL (NULL_PTR), ! Source member at root, if any
dest_member: REF crx_member
INITIAL (NULL_PTR), ! Destination member at root, if any
source_fqn: REF crx_stringlist
INITIAL (NULL_PTR), ! Source name, if any
dest_fqn: REF crx_stringlist
INITIAL (NULL_PTR), ! Destination name, if any
source_dim: REF dims
INITIAL (NULL_PTR), ! Source dimensions, if any
dest_dim: REF dims
INITIAL (NULL_PTR), ! Destination dimensions, if any
source, ! Source root
dest, ! Destination root
new_trans: REF transform_str
INITIAL (NULL_PTR), ! New transform
status; ! Completion status
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called MOM_STATEMENT'));
! Check for explicit source name.
IF .source_name [STR$H_LENGTH] NEQ 0
THEN BEGIN ! Source name exists
status = PRODUCE_FQN (source_name, source_fqn);
IF NOT .status
THEN BEGIN
FREE_STRINGLIST (.source_fqn);
RETURN FALSE;
END;
status = VALIDATE_FQN (.source_fqn);
IF NOT.status
THEN BEGIN
FREE_STRINGLIST (.source_fqn);
RETURN FALSE;
END;
status = FIND_MATCHING_MEMBER (.source_fqn, .srcrt, source_member,
source_dim);
IF NOT .status
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Field name not found in source record description');
DIU$DEL_DIMS (.source_dim);
FREE_STRINGLIST (.source_fqn);
RETURN FALSE;
END;
source = source_member;
END ! Explicit source given
ELSE source = srcrt; ! No explicit source given
! Check for explicit destination name.
IF .dest_name [STR$H_LENGTH] NEQ 0
THEN BEGIN ! Destination name exists
status = PRODUCE_FQN (dest_name, dest_fqn);
IF NOT .status
THEN BEGIN
FREE_STRINGLIST (.dest_fqn);
RETURN FALSE;
END;
status = VALIDATE_FQN (.dest_fqn);
IF NOT.status
THEN BEGIN
FREE_STRINGLIST (.dest_fqn);
RETURN FALSE;
END;
status = FIND_MATCHING_MEMBER (.dest_fqn, .dstrt, dest_member,
dest_dim);
IF NOT .status
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Field name not found in destination record description');
DIU$DEL_DIMS (.dest_dim);
FREE_STRINGLIST (.dest_fqn);
RETURN FALSE;
END;
dest = dest_member;
END ! Explicit destination given
ELSE dest = dstrt; ! No explicit destination given
IF CHECK_DIMS (.source_dim, .dest_dim)
THEN RETURN FALSE; ! Dimensions do not match
! Generate list of transforms.
DIU$MOVE_MAT (DIU$K_MOV_OTHERS, .source, .dest, new_trans,
.source_dim, .dest_dim);
! Hook the result on the transform list:
! NOTE: A MOVE OTHERS MATCHING may generate several nodes, so the transform
! list must be walked after the new piece or pieces has/have been added to
! find the tail.
IF .transform_head EQLA NULL_PTR
THEN ! First transform(s) in list
transform_head = .new_trans
ELSE ! Add transform(s) to end of list
transform_tail [TRA_NEXT] = .new_trans;
WHILE (.new_trans NEQA NULL_PTR)
DO BEGIN ! Walk the new part of the list to end
transform_tail = .new_trans;
new_trans = .new_trans [TRA_NEXT];
END;
RETURN TRUE;
END;
!++
! DEFINE_TRANSFORM (DEFTRN)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine finishes a completed transform.
! It is called for TRANSFORM.
!
! CALLING SEQUENCE:
!
! DEFINE_TRANSFORM (root);
!
! INPUT PARAMETERS:
!
! root Address where caller wants root of transform list
! (currently located in TRANSFORM_HEAD)
!
! IMPLICIT INPUTS:
!
! TRANSFORM_HEAD Head of transform list
!
! IMPLICIT OUTPUTS:
!
! TRANSFORM_HEAD Head of transform list, cleared
! TRANSFORM_TAIL Tail of transform list, cleared
!
! COMPLETION STATUS:
!
! None
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! None
!
!--
ROUTINE DEFINE_TRANSFORM (root) : NOVALUE =
BEGIN
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called DEFINE_TRANSFORM'));
! If there was a transform list already, get rid of it.
IF ..root NEQA NULL_PTR
THEN DIU$DEL_TRANS_LIST (..root);
! Set transform root where the caller wants it.
.root = .transform_head;
! Clear transform information.
transform_head = NULL_PTR;
transform_tail = NULL_PTR;
RETURN;
END;
!++
! CLEAR_ATTRIBUTE_FLAGS (CLRATT)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine clears all the attribute-existence flags.
!
! CALLING SEQUENCE:
!
! CLEAR_ATTRIBUTE_FLAGS ();
!
! INPUT PARAMETERS:
!
! none
!
! IMPLICIT INPUTS:
!
! none
!
! IMPLICIT OUTPUTS:
!
! ALIGNMENT_FL Alignment-seen flag, cleared
! BASE_FL Base-seen flag, cleared
! COLUMN_MAJOR_FL Column-major-array flag, cleared
! COMPUTE_TYPE Computational datatype flag, cleared
! COPY_FL Copy-seen flag, cleared
! DATATYPE_FL Datatype-seen flag, cleared
! DIGITS_FL Digits-seen flag, cleared
! DIMENSION_FL Dimension-seen flag, cleared
! INITIAL_FL Initial-value seen flag, cleared
! JUSTIFIED_RIGHT_FL Justified-right-seen flag, cleared
! LENGTH_FL Length-seen flag, cleared
! MAX_DIGITS_FL Maximum-digits-computed flag, cleared
! ONE_DIMENSION_FL One-dimensional-array flag, cleared
! SCALE_FL Scale-seen flag, cleared
! STRING_TYPE String datatype flag, cleared
! STRING_TYPE_FL String-type-seen flag, cleared
! SYNC_LEFT_FL Synchronized-left flag, cleared
! SYNC_RIGHT_FL Synchronized-right flag, cleared
! TAG_VALUES_FL Tag-values-seen flag, cleared
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE CLEAR_ATTRIBUTE_FLAGS: NOVALUE =
BEGIN
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called CLEAR_ATTRIBUTE_FLAGS'));
ALIGNMENT_FL = FALSE;
BASE_FL = FALSE;
COLUMN_MAJOR_FL = FALSE;
COMPUTE_TYPE = FALSE;
COPY_FL = FALSE;
DATATYPE_FL = FALSE;
DIGITS_FL = FALSE;
DIMENSION_FL = FALSE;
INITIAL_FL = FALSE;
JUSTIFIED_RIGHT_FL = FALSE;
LENGTH_FL = FALSE;
MAX_DIGITS_FL = FALSE;
ONE_DIMENSION_FL = FALSE;
SCALE_FL = FALSE;
STRING_TYPE = FALSE;
STRING_TYPE_FL = FALSE;
SYNC_LEFT_FL = FALSE;
SYNC_RIGHT_FL = FALSE;
TAG_VALUES_FL = FALSE;
END;
!++
! SET_CHARACTER_TYPE (SETCHR)
!
! FUNCTIONAL DESCRIPTION:
!
! This routine sets the character type of a string item and fixes up its
! length to reflect the new character type.
! It is called for TYPE_ASCII_7, TYPE_ASCII_8, TYPE_EBCDIC_8,
! TYPE_EBCDIC_9, TYPE_SIXBIT.
!
! CALLING SEQUENCE:
!
! SET_CHARACTER_TYPE (.code);
!
! INPUT PARAMETERS:
!
! code Value of semantics action code
!
! IMPLICIT INPUTS:
!
! DATATYPE Current datatype
! FIELD_LEN Current field length
! PAT$TOKEN_CURRENT_PTR Current token
! STRING_TYPE_FL String-type-seen flag
!
! IMPLICIT OUTPUTS:
!
! DATATYPE New datatype
! FIELD_LEN New field length
! STRING_TYPE_FL String-type-seen flag, set
!
! COMPLETION STATUS:
!
! none
!
! SIGNALLED STATUS:
!
! This routine does not intercept signals sent by routines it calls.
!
! SIDE EFFECTS:
!
! none
!
!--
ROUTINE SET_CHARACTER_TYPE (code): NOVALUE =
BEGIN
DEB_EVENT ('Semantics actions',
PUT_MSG_EOL ('ACTION_RTN called SET_CHARACTER_TYPE'));
IF .STRING_TYPE_FL
THEN BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Multiple character types ignored');
RETURN;
END;
SELECTONE .DATATYPE OF SET
[DIU$K_DTYPE_NU]: ! Numeric unsigned
SELECTONE .CODE OF SET
[TYPE_ASCII_7]: DATATYPE = DIX$K_DT_DN7U;
[TYPE_ASCII_8]: DATATYPE = DIX$K_DT_DN8U;
! [TYPE_ASCII_9]: ?
[TYPE_EBCDIC_8]: DATATYPE = DIX$K_DT_EBCDIC_8;
[TYPE_EBCDIC_9]: DATATYPE = DIX$K_DT_EBCDIC_9;
[TYPE_SIXBIT]: DATATYPE = DIX$K_DT_DN6U;
TES;
[DIU$K_DTYPE_NL]: ! Signed left separate
SELECTONE .CODE OF SET
[TYPE_ASCII_7]: DATATYPE = DIX$K_DT_DN7LS;
[TYPE_ASCII_8]: DATATYPE = DIX$K_DT_DN8LS;
! [TYPE_ASCII_9]: ?
[TYPE_EBCDIC_8]: DATATYPE = DIX$K_DT_EBCDIC_8;
[TYPE_EBCDIC_9]: DATATYPE = DIX$K_DT_EBCDIC_9;
[TYPE_SIXBIT]: DATATYPE = DIX$K_DT_DN6LS;
TES;
[DIU$K_DTYPE_NLO]: ! Signed left overpunched
SELECTONE .CODE OF SET
[TYPE_ASCII_7]: DATATYPE = DIX$K_DT_DN7LO;
[TYPE_ASCII_8]: DATATYPE = DIX$K_DT_DN8LO;
! [TYPE_ASCII_9]: ?
[TYPE_EBCDIC_8]: DATATYPE = DIX$K_DT_EBCDIC_8;
[TYPE_EBCDIC_9]: DATATYPE = DIX$K_DT_EBCDIC_9;
[TYPE_SIXBIT]: DATATYPE = DIX$K_DT_DN6LO;
TES;
[DIU$K_DTYPE_NR]: ! Signed right separate
SELECTONE .CODE OF SET
[TYPE_ASCII_7]: DATATYPE = DIX$K_DT_DN7TS;
[TYPE_ASCII_8]: DATATYPE = DIX$K_DT_DN8TS;
! [TYPE_ASCII_9]: ?
[TYPE_EBCDIC_8]: DATATYPE = DIX$K_DT_EBCDIC_8;
[TYPE_EBCDIC_9]: DATATYPE = DIX$K_DT_EBCDIC_9;
[TYPE_SIXBIT]: DATATYPE = DIX$K_DT_DN6TS;
TES;
[DIU$K_DTYPE_NRO]: ! Signed right overpunched
SELECTONE .CODE OF SET
[TYPE_ASCII_7]: DATATYPE = DIX$K_DT_DN7TO;
[TYPE_ASCII_8]: DATATYPE = DIX$K_DT_DN8TO;
! [TYPE_ASCII_9]: ?
[TYPE_EBCDIC_8]: DATATYPE = DIX$K_DT_EBCDIC_8;
[TYPE_EBCDIC_9]: DATATYPE = DIX$K_DT_EBCDIC_9;
[TYPE_SIXBIT]: DATATYPE = DIX$K_DT_DN6LO;
TES;
[DIU$K_DTYPE_P]: ! Packed
SELECTONE .CODE OF SET
[TYPE_ASCII_8]: DATATYPE = DIX$K_DT_PD8;
[TYPE_EBCDIC_8]: DATATYPE = DIX$K_DT_PD8;
[TYPE_EBCDIC_9]: DATATYPE = DIX$K_DT_PD9;
[TYPE_ASCII_7,
TYPE_ASCII_9,
TYPE_SIXBIT]:
BEGIN
LSLOCAL_SYNTAX_ERRORM
(LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Character type not valid for PACKED -- ignored');
RETURN;
END;
TES;
[DIU$K_DTYPE_T]: ! Text
SELECTONE .CODE OF SET
[TYPE_ASCII_7]: DATATYPE = DIX$K_DT_ASCII_7;
[TYPE_ASCII_8]: DATATYPE = DIX$K_DT_ASCII_8;
! [TYPE_ASCII_9]: ?
[TYPE_EBCDIC_8]: DATATYPE = DIX$K_DT_EBCDIC_8;
[TYPE_EBCDIC_9]: DATATYPE = DIX$K_DT_EBCDIC_9;
[TYPE_SIXBIT]: DATATYPE = DIX$K_DT_SIXBIT;
TES;
! [DIU$K_DTYPE_VT]: ! Varying text
! SELECTONE .CODE OF SET
! [TYPE_ASCII_7]: DATATYPE = DIX$K_DT_ASCII_7;
! [TYPE_ASCII_8]: DATATYPE = DIX$K_DT_ASCII_8;
! [TYPE_ASCII_9]: ?
! [TYPE_EBCDIC_8]: DATATYPE = DIX$K_DT_EBCDIC_8;
! [TYPE_EBCDIC_9]: DATATYPE = DIX$K_DT_EBCDIC_9;
! [TYPE_SIXBIT]: DATATYPE = DIX$K_DT_SIXBIT;
! TES;
[OTHERWISE]:
BEGIN
LSLOCAL_SYNTAX_ERRORM (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR),
'Character type not allowed here - ignored');
RETURN;
END;
TES;
SELECTONE .CODE OF SET
[TYPE_ASCII_7]: FIELD_LEN = (.FIELD_LEN /
DIU$K_S_ASCII) * SIZE_OF (DIX$K_DT_ASCII_7);
[TYPE_ASCII_8]: FIELD_LEN = (.FIELD_LEN /
DIU$K_S_ASCII) * SIZE_OF (DIX$K_DT_ASCII_8);
! [TYPE_ASCII_9]: FIELD_LEN = (.FIELD_LEN /
! DIU$K_S_ASCII) * SIZE_OF (DIX$K_DT_ASCII_9);
[TYPE_EBCDIC_8]: FIELD_LEN = (.FIELD_LEN /
DIU$K_S_ASCII) *
SIZE_OF (DIX$K_DT_EBCDIC_8);
[TYPE_EBCDIC_9]: FIELD_LEN = (.FIELD_LEN /
DIU$K_S_ASCII) *
SIZE_OF (DIX$K_DT_EBCDIC_9);
[TYPE_SIXBIT]: FIELD_LEN = (.FIELD_LEN /
DIU$K_S_ASCII) * SIZE_OF (DIX$K_DT_SIXBIT);
TES;
END;
END
ELUDOM