void end_forall_semantics (void)
{
int ir_idx;
int list_idx;
int sh_idx;
TRACE (Func_Entry, "end_forall_semantics", NULL);
sh_idx = SH_PARENT_BLK_IDX(curr_stmt_sh_idx);
if (SH_ERR_FLG(curr_stmt_sh_idx) || SH_ERR_FLG(sh_idx)) {
goto EXIT;
}
# ifdef _DEBUG
if (sh_idx == NULL_IDX) {
PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 626, Internal,
SH_COL_NUM(curr_stmt_sh_idx),
"SH_PARENT_BLK_IDX", "end_forall_semantics");
}
# endif
ir_idx = SH_IR_IDX(sh_idx);
# ifdef _DEBUG
if (IR_OPR(ir_idx) != Forall_Opr) {
PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 626, Internal,
SH_COL_NUM(curr_stmt_sh_idx),
"Forall_Opr", "end_forall_semantics");
}
# endif
list_idx = IR_IDX_R(ir_idx);
while (list_idx &&
IL_FLD(list_idx) == IL_Tbl_Idx) {
AT_ATTR_LINK(IL_IDX(IL_IDX(list_idx))) = NULL_IDX;
AT_IGNORE_ATTR_LINK(IL_IDX(IL_IDX(list_idx))) = FALSE;
list_idx = IL_NEXT_LIST_IDX(list_idx);
}
EXIT:
active_forall_sh_idx = SH_PARENT_BLK_IDX(active_forall_sh_idx);
if (active_forall_sh_idx == NULL_IDX) {
within_forall_construct = FALSE;
}
TRACE (Func_Exit, "end_forall_semantics", NULL);
return;
} /* end_forall_semantics */
void end_if_semantics (void)
{
int if_ir_idx;
int if_sh_idx;
int il_idx;
int ir_idx;
int lbl_idx;
int sh_idx;
opnd_type tmp_opnd;
TRACE (Func_Entry, "end_if_semantics", NULL);
/* Walk back through the IF construct to find the IF construct SH. */
/* If it's marked in error, bail. */
if_sh_idx = SH_PARENT_BLK_IDX(curr_stmt_sh_idx);
while (SH_STMT_TYPE(if_sh_idx) != If_Cstrct_Stmt) {
if (SH_STMT_TYPE(if_sh_idx) == Else_Stmt) {
if_sh_idx = IR_IDX_L(SH_IR_IDX(if_sh_idx));
}
else {
if_sh_idx = IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(SH_IR_IDX(if_sh_idx))));
}
}
if (SH_ERR_FLG(if_sh_idx)) {
goto EXIT;
}
lbl_idx = IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(SH_IR_IDX(if_sh_idx))));
AT_DEFINED(lbl_idx) = TRUE;
AT_DEF_LINE(lbl_idx) = stmt_start_line;
ATL_DEF_STMT_IDX(lbl_idx) = curr_stmt_sh_idx;
AT_REFERENCED(lbl_idx) = Referenced;
/* If the last clause of the IF construct is an ELSE IF, generate a */
/* CONTINUE statement to define its branch-around label. */
if (SH_STMT_TYPE(SH_PARENT_BLK_IDX(curr_stmt_sh_idx)) == Else_If_Stmt) {
gen_sh(Before, Continue_Stmt, stmt_start_line, stmt_start_col,
FALSE,
TRUE, /* Labeled. */
TRUE); /* Compiler-generated */
sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
NTR_IR_TBL(ir_idx);
SH_IR_IDX(sh_idx) = ir_idx;
IR_OPR(ir_idx) = Label_Opr;
IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
IR_LINE_NUM(ir_idx) = stmt_start_line;
IR_COL_NUM(ir_idx) = stmt_start_col;
IR_LINE_NUM_L(ir_idx) = stmt_start_line;
IR_COL_NUM_L(ir_idx) = stmt_start_col;
IR_FLD_L(ir_idx) = AT_Tbl_Idx;
lbl_idx =
IL_IDX(IR_IDX_R(SH_IR_IDX(SH_PARENT_BLK_IDX(curr_stmt_sh_idx))));
IR_IDX_L(ir_idx) = lbl_idx;
AT_DEFINED(lbl_idx) = TRUE;
AT_DEF_LINE(lbl_idx) = stmt_start_line;
ATL_DEF_STMT_IDX(lbl_idx) = sh_idx;
AT_REFERENCED(lbl_idx) = Referenced;
}
/* Generate a CONTINUE statement to define the "end IF" label. */
/* If there were no ELSE IF's and no ELSE, get the label from the first IL */
/* attached to the right operand of the If_Opr IR attached to the If_Cstrct*/
/* SH. Otherwise, get the label from the second IL. */
gen_sh(Before, Continue_Stmt, stmt_start_line, stmt_start_col,
FALSE,
TRUE, /* Labeled. */
TRUE); /* Compiler-generated */
sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
NTR_IR_TBL(ir_idx);
SH_IR_IDX(sh_idx) = ir_idx;
IR_OPR(ir_idx) = Label_Opr;
IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
IR_LINE_NUM(ir_idx) = stmt_start_line;
IR_COL_NUM(ir_idx) = stmt_start_col;
IR_LINE_NUM_L(ir_idx) = stmt_start_line;
IR_COL_NUM_L(ir_idx) = stmt_start_col;
IR_FLD_L(ir_idx) = AT_Tbl_Idx;
if_ir_idx = SH_IR_IDX(if_sh_idx);
if (SH_STMT_TYPE(SH_PARENT_BLK_IDX(curr_stmt_sh_idx)) == If_Cstrct_Stmt) {
lbl_idx = IL_IDX(IR_IDX_R(if_ir_idx));
}
else {
lbl_idx = IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(if_ir_idx)));
}
IR_IDX_L(ir_idx) = lbl_idx;
AT_DEFINED(lbl_idx) = TRUE;
AT_DEF_LINE(lbl_idx) = stmt_start_line;
ATL_DEF_STMT_IDX(lbl_idx) = sh_idx;
AT_REFERENCED(lbl_idx) = Referenced;
/* Walk back through the IF construct and transfer the branch around label */
/* for each ELSE IF and for the IF itself to the right operand of each */
/* Br_True IR (replacing the IL list). The IL_OPND is copied to a temp */
/* first because sometimes assignments get a little funky using these */
/* macros if the target is also being used to access the source. */
/* LRR: If we're gettting tight on space, could also delete the IL nodes. */
if_sh_idx = SH_PARENT_BLK_IDX(curr_stmt_sh_idx);
while (SH_STMT_TYPE(if_sh_idx) != If_Cstrct_Stmt) {
if (SH_STMT_TYPE(if_sh_idx) == Else_Stmt) {
sh_idx = if_sh_idx;
if_sh_idx = IR_IDX_L(SH_IR_IDX(if_sh_idx));
SH_IR_IDX(sh_idx) = NULL_IDX;
}
else {
il_idx = IL_NEXT_LIST_IDX(IR_IDX_R(SH_IR_IDX(if_sh_idx)));
COPY_OPND(tmp_opnd, IL_OPND(IR_IDX_R(SH_IR_IDX(if_sh_idx))));
COPY_OPND(IR_OPND_R(SH_IR_IDX(if_sh_idx)), tmp_opnd);
if_sh_idx = IL_IDX(il_idx);
}
}
COPY_OPND(tmp_opnd, IL_OPND(IR_IDX_R(if_ir_idx)));
COPY_OPND(IR_OPND_R(if_ir_idx), tmp_opnd);
EXIT:
TRACE (Func_Exit, "end_if_semantics", NULL);
return;
} /* end_if_semantics */
void end_function_semantics (void)
{
int idx;
int ir_idx;
int new_end_idx;
size_offset_type new_size;
int new_start_idx;
int ptr;
int rslt_idx;
size_offset_type result;
size_offset_type size;
TRACE (Func_Entry, "end_function_semantics", NULL);
rslt_idx = ATP_RSLT_IDX(SCP_ATTR_IDX(curr_scp_idx));
if (!ATD_IM_A_DOPE(rslt_idx) &&
ATD_ARRAY_IDX(rslt_idx) == NULL_IDX &&
TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) != Structure &&
TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) != Character) {
ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
# ifdef _SEPARATE_FUNCTION_RETURNS
if (SCP_ALT_ENTRY_CNT(curr_scp_idx) != 0 &&
SCP_RETURN_LABEL(curr_scp_idx) != NULL_IDX) {
/* change return to goto to multiple return code block */
IR_OPR(ir_idx) = Br_Uncond_Opr;
IR_FLD_R(ir_idx) = AT_Tbl_Idx;
IR_IDX_R(ir_idx) = SCP_RETURN_LABEL(curr_scp_idx);
IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx);
IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx);
}
else {
IR_FLD_R(ir_idx) = AT_Tbl_Idx;
IR_IDX_R(ir_idx) = rslt_idx;
IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx);
IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx);
}
# else
IR_FLD_R(ir_idx) = AT_Tbl_Idx;
IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx);
IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx);
if (SCP_ENTRY_IDX(curr_scp_idx)) {
idx = SCP_ENTRY_IDX(curr_scp_idx);
size = stor_bit_size_of(rslt_idx, TRUE, FALSE);
/* KAY - Do not allow n$pes in alternate entry function results */
while (idx != NULL_IDX) {
new_size = stor_bit_size_of(ATP_RSLT_IDX(AL_ATTR_IDX(idx)),
TRUE,
FALSE);
size_offset_logical_calc(&new_size, &size, Gt_Opr, &result);
if (THIS_IS_TRUE(result.constant, result.type_idx)) {
size = new_size;
rslt_idx = ATP_RSLT_IDX(AL_ATTR_IDX(idx));
}
idx = AL_NEXT_IDX(idx);
}
}
IR_IDX_R(ir_idx) = rslt_idx;
# endif
}
else {
/* Set the function result even if this ends up looking like a */
/* subroutine. This lets PDGCS get function not defined messages right.*/
ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
IR_FLD_R(ir_idx) = AT_Tbl_Idx;
IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx);
IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx);
IR_IDX_R(ir_idx) = rslt_idx;
}
ptr = SCP_EXIT_IR_SH_IDX(curr_scp_idx);
if (ptr) {
while (SH_NEXT_IDX(ptr) != NULL_IDX) {
ptr = SH_NEXT_IDX(ptr);
}
copy_entry_exit_sh_list(SCP_EXIT_IR_SH_IDX(curr_scp_idx), ptr,
&new_start_idx, &new_end_idx);
insert_sh_chain_before(new_start_idx);
}
if (opt_flags.inline_lvl > Inline_Lvl_0 ||
opt_flags.modinline || dump_flags.preinline) {
ir_idx = gen_directive_ir(Inline_Cdir_Opr);
}
if (cdir_switches.bounds) {
ir_idx = gen_directive_ir(Nobounds_Cdir_Opr);
}
TRACE (Func_Exit, "end_function_semantics", NULL);
return;
} /* end_function_semantics */
void gen_default_init_code(int attr_idx)
{
expr_arg_type expr_desc;
operator_type operator;
opnd_type opnd;
TRACE (Func_Entry, "gen_default_init_code", NULL);
if (AT_DCL_ERR(attr_idx)) {
goto EXIT;
}
if (SB_RUNTIME_INIT(ATD_STOR_BLK_IDX(attr_idx))) {
/* The var is on the stack, or is automatic, a darg or a func */
/* result. Generate runtime code for the initialization. */
operator = Asg_Opr;
}
else if (ATD_IN_COMMON(attr_idx)) {
operator = Init_Opr;
# if 0
# if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
func = gen_common_dv_init;
# else
func = gen_static_dv_whole_def;
# endif
# endif
}
else {
operator = Init_Opr;
}
if (!ATD_IM_A_DOPE(attr_idx) &&
TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure &&
ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx))) &&
!AT_DCL_ERR(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
OPND_FLD(opnd) = AT_Tbl_Idx;
OPND_IDX(opnd) = attr_idx;
OPND_LINE_NUM(opnd) = AT_DEF_LINE(attr_idx);
OPND_COL_NUM(opnd) = AT_DEF_COLUMN(attr_idx);
# if defined(_F_MINUS_MINUS)
if (ATD_ARRAY_IDX(attr_idx) || ATD_PE_ARRAY_IDX(attr_idx)) {
# else
if (ATD_ARRAY_IDX(attr_idx)) {
# endif
gen_whole_subscript(&opnd, &expr_desc);
}
process_all_initialized_cpnts(&opnd,
TYP_IDX(ATD_TYPE_IDX(attr_idx)),
operator);
}
EXIT:
TRACE (Func_Exit, "gen_default_init_code", NULL);
return;
} /* gen_default_init_code */
/******************************************************************************\
|* *|
|* Description: *|
|* recursively go through all components of a structure to look for *|
|* default initialization. Then call the supplied routine func for *|
|* processing. *|
|* *|
|* Input parameters: *|
|* left_opnd - current base of sub-object reference. *|
|* type_idx - defined type attr. *|
|* operator - Whether to use Init_Opr or Asg_Opr. *|
|* *|
|* Output parameters: *|
|* NONE *|
|* *|
|* Returns: *|
|* NOTHING *|
|* *|
\******************************************************************************/
static void process_all_initialized_cpnts(opnd_type *left_opnd,
int type_idx,
operator_type operator)
{
int attr_idx;
expr_arg_type expr_desc;
opnd_type expr_opnd;
int init_idx;
int ir_idx;
int list_idx;
opnd_type opnd;
int sn_idx;
TRACE (Func_Entry, "process_all_initialized_cpnts", NULL);
sn_idx = ATT_FIRST_CPNT_IDX(type_idx);
while (sn_idx != NULL_IDX) {
attr_idx = SN_ATTR_IDX(sn_idx); /* A component */
if (ATD_CPNT_INIT_IDX(attr_idx) != NULL_IDX) {
NTR_IR_TBL(ir_idx);
IR_OPR(ir_idx) = Struct_Opr;
IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
IR_LINE_NUM(ir_idx) = AT_DEF_LINE(attr_idx);
IR_COL_NUM(ir_idx) = AT_DEF_COLUMN(attr_idx);
COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
IR_FLD_R(ir_idx) = AT_Tbl_Idx;
IR_IDX_R(ir_idx) = attr_idx;
IR_LINE_NUM_R(ir_idx) = AT_DEF_LINE(attr_idx);
IR_COL_NUM_R(ir_idx) = AT_DEF_COLUMN(attr_idx);
if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx));
}
NTR_IR_TBL(init_idx);
IR_OPR(init_idx) = operator;
IR_LINE_NUM(init_idx) = AT_DEF_LINE(attr_idx);
IR_COL_NUM(init_idx) = AT_DEF_COLUMN(attr_idx);
IR_TYPE_IDX(init_idx) = TYPELESS_DEFAULT_TYPE;
IR_FLD_L(init_idx) = IR_Tbl_Idx;
IR_IDX_L(init_idx) = ir_idx;
IR_LINE_NUM_L(init_idx)= AT_DEF_LINE(attr_idx);
IR_COL_NUM_L(init_idx) = AT_DEF_COLUMN(attr_idx);
if (operator == Asg_Opr) {
if (ATD_FLD(attr_idx) == IR_Tbl_Idx) {
/* This should be an Init_Opr */
if (IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Init_Opr) {
PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
AT_DEF_COLUMN(attr_idx),
"An Init Opr",
"process_all_initialized_cpnts");
}
COPY_OPND(IR_OPND_R(init_idx),
IL_OPND(IR_IDX_R(ATD_CPNT_INIT_IDX(attr_idx))));
}
else {
IR_IDX_R(init_idx) = ATD_CPNT_INIT_IDX(attr_idx);
IR_FLD_R(init_idx) = (fld_type) ATD_FLD(attr_idx);
IR_LINE_NUM_R(init_idx) = AT_DEF_LINE(attr_idx);
IR_COL_NUM_R(init_idx) = AT_DEF_COLUMN(attr_idx);
}
if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX ||
TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
xref_state = CIF_No_Usage_Rec;
expr_desc.rank = 0;
OPND_FLD(expr_opnd) = IR_Tbl_Idx;
OPND_IDX(expr_opnd) = ir_idx;;
if (expr_semantics(&expr_opnd, &expr_desc)) {
COPY_OPND(IR_OPND_L(init_idx), expr_opnd);
}
}
gen_sh(After,
Assignment_Stmt,
AT_DEF_LINE(attr_idx),
AT_DEF_COLUMN(attr_idx),
FALSE,
FALSE,
TRUE);
}
else { /* Init_Opr */
if (ATD_FLD(attr_idx) == IR_Tbl_Idx) {
/* This should be an Init_Opr */
if (IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Init_Opr) {
PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
AT_DEF_COLUMN(attr_idx),
"An Init Opr",
"process_all_initialized_cpnts");
}
IR_FLD_R(init_idx) = IL_Tbl_Idx;
IR_IDX_R(init_idx) = IR_IDX_R(ATD_CPNT_INIT_IDX(attr_idx));
IR_LIST_CNT_R(init_idx) = 3;
}
else {
NTR_IR_LIST_TBL(list_idx);
IR_FLD_R(init_idx) = IL_Tbl_Idx;
IR_IDX_R(init_idx) = list_idx;
IR_LIST_CNT_R(init_idx) = 3;
IL_IDX(list_idx) = ATD_CPNT_INIT_IDX(attr_idx);
IL_FLD(list_idx) = (fld_type) ATD_FLD(attr_idx);
IL_LINE_NUM(list_idx) = AT_DEF_LINE(attr_idx);
IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx);
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) = AT_DEF_LINE(attr_idx);
IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx);
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) = AT_DEF_LINE(attr_idx);
IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx);
}
gen_sh(After,
Type_Init_Stmt,
AT_DEF_LINE(attr_idx),
AT_DEF_COLUMN(attr_idx),
FALSE,
FALSE,
TRUE);
}
SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
SH_IR_IDX(curr_stmt_sh_idx) = init_idx;
}
else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure &&
ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
NTR_IR_TBL(ir_idx);
IR_OPR(ir_idx) = Struct_Opr;
IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
IR_LINE_NUM(ir_idx) = AT_DEF_LINE(attr_idx);
IR_COL_NUM(ir_idx) = AT_DEF_COLUMN(attr_idx);
COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
IR_FLD_R(ir_idx) = AT_Tbl_Idx;
IR_IDX_R(ir_idx) = attr_idx;
IR_LINE_NUM_R(ir_idx) = AT_DEF_LINE(attr_idx);
IR_COL_NUM_R(ir_idx) = AT_DEF_COLUMN(attr_idx);
OPND_FLD(opnd) = IR_Tbl_Idx;
OPND_IDX(opnd) = ir_idx;
if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx));
}
if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
gen_whole_subscript(&opnd, &expr_desc);
}
process_all_initialized_cpnts(&opnd,
TYP_IDX(ATD_TYPE_IDX(attr_idx)),
operator);
}
sn_idx = SN_SIBLING_LINK(sn_idx);
}
TRACE (Func_Exit, "process_all_initialized_cpnts", NULL);
return;
} /* process_all_initialized_cpnts */
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 */
/******************************************************************************\
|* *|
|* Description: *|
|* Do semantics for type declaration initializations. *|
|* *|
|* Input parameters: *|
|* NONE *|
|* *|
|* Output parameters: *|
|* NONE *|
|* *|
|* Returns: *|
|* NOTHING *|
|* *|
\******************************************************************************/
void default_init_semantics(int attr_idx)
{
int column;
expr_arg_type expr_desc;
opnd_type init_opnd;
int line;
int next_sh_idx;
boolean null_init;
int old_curr_stmt_sh_idx;
opnd_type opnd;
int sh_idx;
int type_idx;
int type_init_sh_idx;
TRACE (Func_Entry, "default_init_semantics", NULL);
# ifdef _DEBUG
if (ATD_CPNT_INIT_IDX(attr_idx) == NULL_IDX ||
ATD_FLD(attr_idx) != IR_Tbl_Idx ||
(IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Init_Opr &&
IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Null_Opr)) {
PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
AT_DEF_COLUMN(attr_idx),
"Init_Opr or Null_Opr", "default_init_semantics");
}
# endif
/* Generate a type init statement so that expression semantics gets */
/* anything it generates in the correct order. This statement will */
/* be removed. */
old_curr_stmt_sh_idx = curr_stmt_sh_idx;
gen_sh(After,
Type_Init_Stmt,
AT_DEF_LINE(attr_idx),
AT_DEF_COLUMN(attr_idx),
FALSE,
FALSE,
TRUE);
type_init_sh_idx = curr_stmt_sh_idx;
target_array_idx = ATD_ARRAY_IDX(attr_idx);
type_idx = ATD_TYPE_IDX(attr_idx);
null_init = FALSE;
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;
expr_desc.rank = 0;
COPY_OPND(init_opnd, IR_OPND_R(ATD_CPNT_INIT_IDX(attr_idx)));
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))) {
find_opnd_line_and_column(&init_opnd, &line, &column);
PRINTMSG(line, 1559, Error, column, AT_OBJ_NAME_PTR(attr_idx));
AT_DCL_ERR(attr_idx) = TRUE;
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) {
/* Pointer components are null'd by default, so we */
/* do not need to keep the null information around. */
null_init = TRUE;
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, &line, &column);
PRINTMSG(line, 1680, Error, column, AT_OBJ_NAME_PTR(attr_idx));
AT_DCL_ERR(attr_idx) = TRUE;
goto EXIT;
}
#endif /* KEY Bug 6845 */
find_opnd_line_and_column(&init_opnd, &line, &column);
PRINTMSG(line, 842, Error, column);
AT_DCL_ERR(attr_idx) = TRUE;
}
/* The assumption is that if this is IR, we will */
/* never end up with a CN_Tbl_Idx on the left side. */
if (OPND_FLD(init_opnd) == CN_Tbl_Idx) {
if (!const_init_semantics(&init_opnd,
attr_idx,
ATD_CPNT_INIT_IDX(attr_idx))) {
AT_DCL_ERR(attr_idx) = TRUE;
}
}
else {
COPY_OPND(opnd, init_opnd);
while (OPND_FLD(opnd) == IR_Tbl_Idx && OPND_IDX(opnd) != NULL_IDX) {
COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
}
if (OPND_FLD(opnd) == AT_Tbl_Idx) {
if (!attr_init_semantics(&opnd,
attr_idx,
ATD_CPNT_INIT_IDX(attr_idx),
&expr_desc)) {
AT_DCL_ERR(attr_idx) = TRUE;
}
}
else {
PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
AT_DEF_COLUMN(attr_idx),
"AT_Tbl_Idx",
"default_init_semantics");
}
}
}
else { /* The initialization expression has an error */
AT_DCL_ERR(attr_idx) = TRUE;
}
EXIT:
expr_mode = Regular_Expr;
check_type_conversion = FALSE;
target_array_idx = NULL_IDX;
sh_idx = SH_NEXT_IDX(old_curr_stmt_sh_idx);
if (old_curr_stmt_sh_idx != NULL_IDX) {
SH_NEXT_IDX(old_curr_stmt_sh_idx) = SH_NEXT_IDX(type_init_sh_idx);
}
if (SH_NEXT_IDX(type_init_sh_idx) != NULL_IDX) {
SH_PREV_IDX(SH_NEXT_IDX(type_init_sh_idx)) = old_curr_stmt_sh_idx;
}
curr_stmt_sh_idx = old_curr_stmt_sh_idx;
while (sh_idx != type_init_sh_idx) {
next_sh_idx = SH_NEXT_IDX(sh_idx);
FREE_SH_NODE(sh_idx);
sh_idx = next_sh_idx;
}
FREE_SH_NODE(type_init_sh_idx);
if (AT_DCL_ERR(attr_idx) || null_init) {
ATD_CPNT_INIT_IDX(attr_idx) = NULL_IDX;
ATD_FLD(attr_idx) = NO_Tbl_Idx;
}
else {
ATD_CPNT_INIT_IDX(attr_idx) = OPND_IDX(init_opnd);
ATD_FLD(attr_idx) = OPND_FLD(init_opnd);
}
TRACE (Func_Exit, "default_init_semantics", NULL);
return;
} /* default_init_semantics */