int main (int argc,
char *argv[])
# endif
{
int column_num;
long field_len;
int line_num;
char *msg_name;
int save_statement_number = 0;
# if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
double end_time;
double start_time;
/* char time[20]; */
double total_cpu_time;
struct rusage ru;
# else
# if !defined(_HOST_OS_UNICOS)
long end_clock;
# endif
float end_time;
float start_time;
float total_cpu_time;
# endif
# if defined(_HOST_OS_UNICOS) && defined(_DEBUG)
lowmem_check();
# endif
# if defined(_TARGET32) && defined(_DEBUG)
setbuf(stdout, NULL);
setbuf(stderr, NULL);
# endif
# if defined(_HOST_OS_UNICOS)
/* Lots of start up - ignore first call. See the comment block that */
/* precedes procedure cif_summary_rec in fecif.c for a discussion of the */
/* timing methods used by the different platforms. */
SECOND(&start_time);
/* M_LOWFIT will eventually be in malloc.h. */
/* When it is remove this definition. */
# define M_LOWFIT 0107 /* Use lowest-fit algorithm for allocation. */
mallopt(M_LOWFIT, 1);
# elif defined(_HOST_OS_MAX)
/* Use clock() on MPP's (in particular T3E's) because at the time this */
/* change was made, neither SECOND() nor SECONDR() worked on T3E's. */
/* LRR 4 Mar 1997 */
clock();
start_time = 0;
/* M_LOWFIT will eventually be in malloc.h. */
/* When it is remove this definition. */
# define M_LOWFIT 0107 /* Use lowest-fit algorithm for allocation. */
mallopt(M_LOWFIT, 1);
# elif defined(_HOST_OS_SOLARIS)
/* clock() is only semi-useful on a Sun because it rolls over in just over */
/* 2147 seconds (about 36 minutes). So on a Sun, we use clock() and */
/* time() both. If elapsed time <= 2147 seconds, the accounting info will */
/* show milliseconds (from clock()), else it will show seconds (because */
/* that is the accuracy of time()). This resolution should be good enough */
/* for a compilation exceeding 36 minutes. */
start_time = (float) time(NULL);
clock();
# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
getrusage (RUSAGE_SELF, &ru);
start_time = (double) ru.ru_utime.tv_sec +
(double) ru.ru_utime.tv_usec * 1e-6 +
(double) ru.ru_stime.tv_sec +
(double) ru.ru_stime.tv_usec * 1e-6;
# else
start_time = 0;
# endif
comp_phase = Pass1_Parsing;
stmt_start_line = 1; /* Set in case mem problems */
init_compiler(argc, argv); /* init and process cmd line */
if (on_off_flags.preprocess_only) {
goto PREPROCESS_ONLY_SKIP;
}
stmt_start_line = 0;
while (LA_CH_CLASS != Ch_Class_EOF) {
comp_phase = Pass1_Parsing;
num_prog_unit_errors = 0; /* Accum errs for pgm unit */
OUTPUT_PASS_HEADER(Syntax_Pass);
if (save_statement_number != 0) {
statement_number = save_statement_number;
}
parse_prog_unit();
save_statement_number = statement_number;
if (LA_CH_CLASS == Ch_Class_EOF) {
issue_deferred_msgs();
}
/* get current field length and save largest value */
field_len = (long) sbrk(0);
# if defined(_HOST_OS_MAX)
field_len &= (1 << 32) - 1;
# endif
if (field_len > max_field_len) { /* Max set in init_compiler */
max_field_len = field_len; /* Track max usage */
}
PRINT_IR_TBL; /* If -u ir and DEBUG compiler, print ir. */
OUTPUT_PASS_HEADER(Semantics_Pass);
semantics_pass_driver(); /* PASS 2 */
if (SCP_IN_ERR(curr_scp_idx)) {
some_scp_in_err = TRUE;
}
PRINT_ALL_SYM_TBLS; /* If debug print -u options */
PRINT_FORTRAN_OUT; /* Print ir in a fortran format */
line_num = SH_GLB_LINE(SCP_LAST_SH_IDX(curr_scp_idx));
column_num = SH_COL_NUM(SCP_LAST_SH_IDX(curr_scp_idx));
if (num_prog_unit_errors == 0) {
if (opt_flags.inline_lvl > Inline_Lvl_0) {
comp_phase = Inlining;
inline_processing(SCP_FIRST_SH_IDX(curr_scp_idx));
PRINT_IR_TBL3;
}
}
insert_global_directives = TRUE;
comp_phase = Pdg_Conversion;
if (dump_flags.preinline) { /* Do not do a full compile */
if (ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Module ||
ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Function ||
ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Subroutine) {
curr_scp_idx = MAIN_SCP_IDX;
#ifdef KEY /* Bug 3477 */
if (create_mod_info_file()) { /* Creates a name for the file. */
create_mod_info_tbl(); /* Creates the table. */
output_mod_info_file(); /* Writes the table. */
}
#else
create_mod_info_file(); /* Creates a name for the file. */
create_mod_info_tbl(); /* Creates the table. */
output_mod_info_file(); /* Writes the table. */
#endif /* KEY Bug 3477 */
free_tables(); /* Frees the tables. */
}
}
else {
#ifdef KEY /* Bug 3477 */
int do_output_file = FALSE;
#endif /* KEY Bug 3477 */
if (ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Module) {
#ifdef KEY /* Bug 3477 */
do_output_file = create_mod_info_file(); /* Creates a name for the file. */
#else
create_mod_info_file(); /* Creates a name for the file. */
#endif /* KEY Bug 3477 */
}
if (num_prog_unit_errors == 0 && (binary_output || assembly_output)) {
cvrt_to_pdg(compiler_gen_date);
}
else if (ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Module) {
if (!SCP_IN_ERR(MAIN_SCP_IDX)) {
curr_scp_idx = MAIN_SCP_IDX;
#ifdef KEY /* Bug 3477 */
if (do_output_file) {
create_mod_info_tbl(); /* Creates the table. */
output_mod_info_file(); /* Writes the table. */
}
#else
create_mod_info_tbl(); /* Creates the table. */
output_mod_info_file(); /* Writes the table. */
#endif /* KEY Bug 3477 */
}
free_tables(); /* Frees the tables. */
}
else {
free_tables(); /* Frees the tables. */
}
}
/* ALERT - At this point, the symbol tables are invalid. */
/* Spit out the End Unit for the current program unit. The End Unit */
/* is needed if the Compiler Information File (CIF) is being produced */
/* and for the buffered message file. */
stmt_start_line = line_num;
stmt_start_col = column_num;
if (scp_tbl == NULL_IDX) { /* Table has been freed. */
cif_end_unit_rec(program_unit_name);
}
else {
cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
}
} /* while */
clean_up_module_files();
# ifdef _NAME_SUBSTITUTION_INLINING
if (!dump_flags.preinline)
# endif
terminate_PDGCS();
PRINT_GL_TBL; /* Prints to debug_file ifdef _DEBUG and -u gl */
PRINT_GN_TBL; /* Prints to debug_file ifdef _DEBUG and -u gn */
PREPROCESS_ONLY_SKIP:
# if defined(_HOST_OS_UNICOS)
SECOND(&end_time);
# elif defined(_HOST_OS_MAX)
end_clock = clock();
end_time = 0;
# elif defined(_HOST_OS_SOLARIS)
end_time = (float) time(NULL);
end_clock = clock();
# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
getrusage(RUSAGE_SELF, &ru);
end_time = (double) ru.ru_utime.tv_sec +
(double) ru.ru_utime.tv_usec * 1e-6 +
(double) ru.ru_stime.tv_sec +
(double) ru.ru_stime.tv_usec * 1e-6;
# else
end_time = 0;
# endif
total_cpu_time = end_time - start_time;
if (cif_need_unit_rec && cif_first_pgm_unit) {
/* Catastrophic errors, like a free source form program was compiled */
/* in fixed source form mode, so no Unit record was output. Output */
/* enough records to keep libcif tools happy. This routine needs to be */
/* called whether or not a CIF is being written because the buffered */
/* message file also must have the correct format. */
cif_fake_a_unit();
}
/* CAUTION: The following code assumes that non-Cray platforms measure */
/* memory usage in terms of bytes and that there are 4 bytes per word. */
cif_summary_rec(release_level,
compiler_gen_date,
compiler_gen_time,
total_cpu_time,
# if defined(_HOST_OS_UNICOS)
(long) 0,
(some_scp_in_err) ? -3 : max_field_len);
# elif defined(_HOST_OS_MAX)
end_clock,
(some_scp_in_err) ? -3 : max_field_len);
# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
(long) 0,
(some_scp_in_err) ? -3 : max_field_len/4);
# else /* defined(_HOST_OS_SOLARIS) */
end_clock,
(some_scp_in_err) ? -3 : max_field_len/4);
# endif
/* Output compilation summary info if the -V option was specified on the */
/* command line. Also, issue the summary information if any messages were */
/* actually issued. */
if (cmd_line_flags.verify_option ||
num_errors > 0 ||
num_warnings > 0 ||
num_cautions > 0 ||
num_notes > 0 ||
num_comments > 0 ||
num_ansi > 0 ||
(num_optz_msgs > 0 && opt_flags.msgs)) {
print_buffered_messages();
print_id_line();
/* Output the summary lines. The compilation time is in seconds. */
/* CAUTION: The following non-Cray code assumes a 32-bit word. */
# if defined(_HOST_OS_UNICOS)
PRINTMSG (0, 104, Log_Summary, 0, (double) total_cpu_time);
msg_name = "cf90";
# elif defined(_HOST_OS_MAX)
PRINTMSG (0, 104, Log_Summary, 0, (double) end_clock/1000000.0);
msg_name = "cf90";
# elif defined(_HOST_OS_LINUX)
msg_name = PSC_NAME_PREFIX "f95";
# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
/* IRIX cannot handle the int to float change necessary to get the */
/* time printed correctly, so we'll convert it to a character string */
/* and use a different message. */
/* */
/* LRR 4/28/97 In an email message from Rich Shapiro to me, he stated */
/* he did not want this line in the summary lines. */
/* sprintf(time, "%-1.2f", (double) total_cpu_time);
PRINTMSG (0, 1310, Log_Summary, 0, time); */
msg_name = "cf90";
# elif defined(_HOST_OS_SOLARIS)
PRINTMSG (0, 104, Log_Summary, 0,
(total_cpu_time <= 2147.0) ? (float) end_clock/1000000.0 :
(float) total_cpu_time);
msg_name = "cf90";
# endif
/* Maximum field length (maximum amount of memory used) in words */
/* (decimal). */
/* CAUTION: Non-Cray platforms are assumed to measure memory usage in */
/* bytes and we assume 4 bytes per word. */
# if defined(_HOST_OS_UNICOS)
PRINTMSG (0, 105, Log_Summary, 0, max_field_len);
# elif ! (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
/* LRR 4/28/97 In an email message from Rich Shapiro to me, he stated */
/* he did not want this line in the summary lines. */
PRINTMSG (0, 105, Log_Summary, 0, max_field_len/4);
# endif
/* Number of source lines compiled. */
# if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) && !defined(_TARGET_SV2)
PRINTMSG (0, 1401, Log_Summary, 0, --curr_glb_line);
# else
PRINTMSG (0, 106, Log_Summary, 0, --curr_glb_line);
# endif
/* Number of messages issued. */
# if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) && !defined(_TARGET_SV2)
PRINTMSG (0, 1403, Log_Summary, 0,
num_errors,
num_warnings,
(opt_flags.msgs == 0) ?
(num_cautions + num_notes + num_comments) :
(num_cautions + num_notes + num_comments + num_optz_msgs),
num_ansi);
# else
PRINTMSG (0, 107, Log_Summary, 0,
num_errors,
num_warnings,
(opt_flags.msgs == 0) ?
(num_cautions + num_notes + num_comments) :
(num_cautions + num_notes + num_comments + num_optz_msgs),
num_ansi);
/* Code: in words; data: in words. */
/* LRR 4/28/97 In an email message from Rich Shapiro to me, he stated */
/* he did not want this line in the summary lines. */
# if !defined(_TARGET_SV2) /* Prints blank for sv2 right now. */
PRINTMSG (0, 108, Log_Summary, 0, code_size, data_size);
# endif
# endif
if (num_errors > 0 ||
num_warnings > 0 ||
num_cautions > 0 ||
num_notes > 0 ||
num_comments > 0 ||
num_ansi > 0 ||
(num_optz_msgs > 0 && opt_flags.msgs)) {
PRINTMSG (0, 1636, Log_Summary, 0, msg_name, msg_name);
}
} /* End of summary printing. */
# ifdef _DEBUG
/* Get memory usage reports for these global tables. */
final_src_input();
MEM_REPORT(file_path_tbl);
MEM_REPORT(global_attr_tbl);
MEM_REPORT(global_bounds_tbl);
MEM_REPORT(global_line_tbl);
MEM_REPORT(global_name_tbl);
MEM_REPORT(global_type_tbl);
MEM_REPORT(str_pool);
# endif
exit_compiler ((num_errors == 0) ? RC_OKAY : RC_USER_ERROR);
} /* main */
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 */
static boolean attr_init_semantics(opnd_type *init_opnd,
int attr_idx,
int ir_idx,
expr_arg_type *expr_desc)
{
int c_type_idx;
int column;
int i;
int line;
boolean ok = TRUE;
int opnd_column;
int opnd_line;
char type_str[40];
TRACE (Func_Entry, "attr_init_semantics", NULL);
line = IR_LINE_NUM_L(ir_idx);
column = IR_COL_NUM_L(ir_idx);
c_type_idx = expr_desc->type_idx;
find_opnd_line_and_column(init_opnd, &opnd_line, &opnd_column);
if (TYP_LINEAR(c_type_idx) == Long_Typeless) {
PRINTMSG(opnd_line, 1133, Error, opnd_column);
ok = FALSE;
}
else if (!check_asg_semantics(ATD_TYPE_IDX(attr_idx),
c_type_idx,
opnd_line,
opnd_column)) {
type_str[0] = '\0';
strcat(type_str, get_basic_type_str(ATD_TYPE_IDX(attr_idx)));
PRINTMSG(line, 843, Error, column, AT_OBJ_NAME_PTR(attr_idx),
type_str,
get_basic_type_str(c_type_idx));
ok = FALSE;
}
else if (expr_desc->rank > 0) { /* check array conformance */
if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) {
PRINTMSG(line, 844, Error, column, AT_OBJ_NAME_PTR(attr_idx));
ok = FALSE;
}
else if (expr_desc->rank == BD_RANK(ATD_ARRAY_IDX(attr_idx))) {
for (i = 1; i <= expr_desc->rank; i++) {
if (fold_relationals(expr_desc->shape[i-1].idx,
BD_XT_IDX(ATD_ARRAY_IDX(attr_idx),i),
Ne_Opr)) {
PRINTMSG(line, 845, Error, column, AT_OBJ_NAME_PTR(attr_idx));
ok = FALSE;
break;
}
}
}
else {
PRINTMSG(line, 845, Error, column, AT_OBJ_NAME_PTR(attr_idx));
ok = FALSE;
}
}
TRACE (Func_Exit, "attr_init_semantics", NULL);
return(ok);
} /* attr_init_semantics */
static boolean const_init_semantics(opnd_type *init_opnd,
int attr_idx,
int ir_idx)
{
int a_type_idx;
long_type another_constant[MAX_WORDS_FOR_NUMERIC];
int c_type_idx;
char *char_ptr;
char *c_char_ptr;
int column;
int const_idx;
long64 i;
int line;
boolean ok = TRUE;
int opnd_column;
int opnd_line;
opnd_type tar_opnd;
char type_str[40];
TRACE (Func_Entry, "const_init_semantics", NULL);
line = IR_LINE_NUM_L(ir_idx);
column = IR_COL_NUM_L(ir_idx);
a_type_idx = ATD_TYPE_IDX(attr_idx);
c_type_idx = CN_TYPE_IDX(OPND_IDX((*init_opnd)));
find_opnd_line_and_column(init_opnd, &opnd_line, &opnd_column);
if (TYP_LINEAR(c_type_idx) == Long_Typeless) {
PRINTMSG(opnd_line, 1133, Error, opnd_column);
ok = FALSE;
goto EXIT;
}
else if (!check_asg_semantics(a_type_idx,
c_type_idx,
opnd_line,
opnd_column)) {
type_str[0] = '\0';
strcat(type_str, get_basic_type_str(a_type_idx));
PRINTMSG(line, 843, Error, column, AT_OBJ_NAME_PTR(attr_idx),
type_str,
get_basic_type_str(c_type_idx));
ok = FALSE;
goto EXIT;
}
if (TYP_TYPE(a_type_idx) == Character) {
if (fold_relationals(TYP_IDX(a_type_idx),
TYP_IDX(c_type_idx),
Ne_Opr)) {
/* assumes that these are both CN_Tbl_Idx */
/* create new constant for the right length and put the */
/* original string in it. Truncate or blank pad to fit. */
const_idx = ntr_const_tbl(a_type_idx, TRUE, NULL);
char_ptr = (char *)&CN_CONST(const_idx);
c_char_ptr = (char *)&CN_CONST(OPND_IDX((*init_opnd)));
for (i = 0; i < CN_INT_TO_C(TYP_IDX(a_type_idx)); i++) {
char_ptr[i] = (i >= CN_INT_TO_C(TYP_IDX(c_type_idx))) ?
' ' : c_char_ptr[i];
}
while (i % TARGET_CHARS_PER_WORD != 0) {
char_ptr[i] = ' ';
i++;
}
OPND_IDX((*init_opnd)) = const_idx;
}
/* If this is default initialization, the substring reference will */
/* need to be generated when something is actually initialized. */
if (ATD_CLASS(attr_idx) != Struct_Component) {
COPY_OPND(tar_opnd, IR_OPND_L(ir_idx));
if (gen_whole_substring(&tar_opnd, 0)) {
COPY_OPND(IR_OPND_L(ir_idx), tar_opnd);
}
}
}
else if (TYP_TYPE(c_type_idx) == Character ||
TYP_TYPE(c_type_idx) == Typeless) {
/* cast the character or typeless constant to the target type */
OPND_IDX((*init_opnd)) = cast_typeless_constant(OPND_IDX((*init_opnd)),
a_type_idx,
opnd_line,
opnd_column);
}
else if (TYP_TYPE(c_type_idx) != Character &&
TYP_TYPE(c_type_idx) != Typeless &&
TYP_LINEAR(c_type_idx) != TYP_LINEAR(a_type_idx)) {
/* PDGCS does not like it if the value is not the same size as the */
/* target; for example, the value is a double precision constant and */
/* the target is a single precision variable. So explicitly convert */
/* the value to the type and kind type parameter of the target for */
/* all combinations to be consistent. */
if (folder_driver( (char *) &CN_CONST(OPND_IDX((*init_opnd))),
c_type_idx,
NULL,
NULL_IDX,
another_constant,
&a_type_idx,
opnd_line,
opnd_column,
1,
Cvrt_Opr)) {
OPND_IDX((*init_opnd)) = ntr_const_tbl(ATD_TYPE_IDX(attr_idx),
FALSE,
another_constant);
}
}
EXIT:
TRACE (Func_Exit, "const_init_semantics", NULL);
return(ok);
} /* const_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 */
