void end_select_semantics (void)
{
int i;
int il_idx;
int ir_idx;
int next_il_idx;
TRACE (Func_Entry, "end_select_semantics", NULL);
if (! SH_ERR_FLG(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))) {
ir_idx = SH_IR_IDX(SH_PARENT_BLK_IDX(curr_stmt_sh_idx));
SH_IR_IDX(SH_PARENT_BLK_IDX(curr_stmt_sh_idx)) = IR_IDX_L(ir_idx);
il_idx = IR_IDX_R(ir_idx);
for (i = 1; i <= IR_LIST_CNT_R(ir_idx); i++) {
next_il_idx = IL_NEXT_LIST_IDX(il_idx);
FREE_IR_LIST_NODE(il_idx);
il_idx = next_il_idx;
}
FREE_IR_NODE(ir_idx);
}
TRACE (Func_Exit, "end_select_semantics", NULL);
return;
} /* end_select_semantics */
void type_init_semantics (void)
{
int attr_idx;
int col;
expr_arg_type expr_desc;
opnd_type init_opnd;
int ir_idx;
int line;
int list_idx;
int opnd_column;
int opnd_line;
int sh_idx;
int type_idx;
TRACE (Func_Entry, "type_init_semantics", NULL);
/* set comp_gen_expr to TRUE. This forces the fold of REAL */
/* constant expressions. When -Oieeeconform is specified, */
/* the folding of Real and Complex expressions is prevented. */
comp_gen_expr = TRUE;
ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
attr_idx = IR_IDX_L(ir_idx);
COPY_OPND(init_opnd, IR_OPND_R(ir_idx));
line = IR_LINE_NUM_L(ir_idx);
col = IR_COL_NUM_L(ir_idx);
/* Constraint checks: */
/* * A variable that is a member of blank common should not be */
/* initialized. */
/* * A variable that is a member of a named common block should only be */
/* initialized in a block data program unit. */
/* * A variable that is a member of a task common block must not be */
/* initialized. */
/* * From a CF77 SPR: If an object in a Block Data program unit is NOT */
/* in a common block (and is not equivalenced to an object in common) */
/* but IS initialized, issue a warning. */
if (ATD_IN_COMMON(attr_idx)) {
if (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Common) {
if (SB_BLANK_COMMON(ATD_STOR_BLK_IDX(attr_idx))) {
PRINTMSG(line, 1109, Ansi, col);
}
else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Blockdata) {
# if defined(_ALLOW_DATA_INIT_OF_COMMON)
PRINTMSG(line, 692, Ansi, col);
# else
PRINTMSG(line, 1542, Warning, col);
# endif
}
}
else if (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Task_Common) {
PRINTMSG(line, 851, Error, col);
goto EXIT;
}
}
else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Blockdata &&
! (ATD_EQUIV(attr_idx) &&
SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx)))) {
PRINTMSG(line, 825, Warning, col);
}
/* There is no way to initialize a CRI character pointer. */
type_idx = ATD_TYPE_IDX(attr_idx);
if (TYP_TYPE(type_idx) == CRI_Ch_Ptr) {
PRINTMSG(line, 695, Error, col);
goto EXIT;
}
if (AT_DCL_ERR(attr_idx)) {
/* don't do anything else */
goto EXIT;
}
OPND_FLD(init_target_opnd) = AT_Tbl_Idx;
OPND_IDX(init_target_opnd) = attr_idx;
OPND_LINE_NUM(init_target_opnd) = line;
OPND_COL_NUM(init_target_opnd) = col;
target_array_idx = ATD_ARRAY_IDX(attr_idx);
if (TYP_TYPE(type_idx) == Integer ||
TYP_TYPE(type_idx) == Real ||
TYP_TYPE(type_idx) == Complex) {
check_type_conversion = TRUE;
target_type_idx = type_idx;
}
else if (TYP_TYPE(type_idx) == Character) {
if (TYP_CHAR_CLASS(type_idx) == Const_Len_Char) {
check_type_conversion = TRUE;
target_type_idx = Character_1;
target_char_len_idx = TYP_IDX(type_idx);
}
}
expr_mode = Initialization_Expr;
xref_state = CIF_Symbol_Reference;
if (expr_semantics(&init_opnd, &expr_desc)) {
if (ATD_POINTER(attr_idx) &&
(OPND_FLD(init_opnd) == AT_Tbl_Idx ||
OPND_FLD(init_opnd) == CN_Tbl_Idx ||
(OPND_FLD(init_opnd) == IR_Tbl_Idx &&
IR_OPR(OPND_IDX(init_opnd)) != Null_Intrinsic_Opr))) {
PRINTMSG(line, 1559, Error, col,
AT_OBJ_NAME_PTR(attr_idx));
goto EXIT;
}
if (! expr_desc.foldable) {
/* The initialization expression must be a constant. */
if (ATD_POINTER(attr_idx) &&
OPND_FLD(init_opnd) == IR_Tbl_Idx &&
IR_OPR(OPND_IDX(init_opnd)) == Null_Intrinsic_Opr) {
goto EXIT;
}
#ifdef KEY /* Bug 6845 */
else if ((AT_OBJ_CLASS(TYP_IDX(ATD_TYPE_IDX(attr_idx)))
== Derived_Type) &&
ATT_ALLOCATABLE_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
find_opnd_line_and_column(&init_opnd, &opnd_line, &opnd_column);
PRINTMSG(opnd_line, 1680, Error, opnd_column,
AT_OBJ_NAME_PTR(attr_idx));
goto EXIT;
}
#endif /* KEY Bug 6845 */
else {
find_opnd_line_and_column(&init_opnd, &opnd_line, &opnd_column);
PRINTMSG(opnd_line, 842, Error, opnd_column);
goto EXIT;
}
}
while (OPND_FLD(init_opnd) == IR_Tbl_Idx) {
COPY_OPND(init_opnd, IR_OPND_L(OPND_IDX(init_opnd)));
}
}
else {
goto EXIT;
}
if (OPND_FLD(init_opnd) == AT_Tbl_Idx) {
if (attr_init_semantics(&init_opnd, attr_idx, ir_idx, &expr_desc)) {
/* pull this init out of stmts. don't need it any more */
sh_idx = curr_stmt_sh_idx;
SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx);
SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx);
curr_stmt_sh_idx = SH_PREV_IDX(sh_idx);
FREE_IR_NODE(ir_idx);
FREE_SH_NODE(sh_idx);
}
}
else {
if (const_init_semantics(&init_opnd, attr_idx, ir_idx)) {
find_opnd_line_and_column(&init_opnd, &opnd_line, &opnd_column);
NTR_IR_LIST_TBL(list_idx);
IR_FLD_R(ir_idx) = IL_Tbl_Idx;
IR_IDX_R(ir_idx) = list_idx;
IR_LIST_CNT_R(ir_idx) = 3;
COPY_OPND(IL_OPND(list_idx), init_opnd);
NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
list_idx = IL_NEXT_LIST_IDX(list_idx);
IL_FLD(list_idx) = CN_Tbl_Idx;
IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
IL_LINE_NUM(list_idx) = opnd_line;
IL_COL_NUM(list_idx) = opnd_column;
NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
list_idx = IL_NEXT_LIST_IDX(list_idx);
IL_FLD(list_idx) = CN_Tbl_Idx;
IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
IL_LINE_NUM(list_idx) = opnd_line;
IL_COL_NUM(list_idx) = opnd_column;
}
}
EXIT:
expr_mode = Regular_Expr;
check_type_conversion = FALSE;
target_array_idx = NULL_IDX;
init_target_opnd = null_opnd;
/* reset comp_gen_expr to FALSE. end of compiler generated expression */
comp_gen_expr = FALSE;
TRACE (Func_Exit, "type_init_semantics", NULL);
return;
} /* type_init_semantics */
