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 */