|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 00037 static char USMID[] = "\n@(#)5.0_pl/sources/s_io.c 5.8 10/04/99 17:44:33\n"; 00038 00039 # include "defines.h" /* Machine dependent ifdefs */ 00040 00041 # include "host.m" /* Host machine dependent macros.*/ 00042 # include "host.h" /* Host machine dependent header.*/ 00043 # include "target.m" /* Target machine dependent macros.*/ 00044 # include "target.h" /* Target machine dependent header.*/ 00045 00046 # include "globals.m" 00047 # include "tokens.m" 00048 # include "sytb.m" 00049 # include "s_globals.m" 00050 # include "debug.m" 00051 # include "p_io.m" 00052 00053 # include "globals.h" 00054 # include "tokens.h" 00055 # include "sytb.h" 00056 # include "s_globals.h" 00057 # include "s_io.h" 00058 00059 00060 /*****************************************************************\ 00061 |* Function prototypes of static functions declared in this file *| 00062 \*****************************************************************/ 00063 00064 static boolean io_ctl_list_semantics(opnd_type *, io_stmt_type, boolean); 00065 static boolean io_list_semantics(opnd_type *, io_stmt_type); 00066 static void namelist_static_dv_whole_def(opnd_type *, opnd_type *); 00067 static void put_string_in_tmp(char *, int, opnd_type *); 00068 00069 # ifdef _INIT_RELOC_BASE_OFFSET 00070 static int change_to_base_and_offset(opnd_type *, opnd_type *); 00071 # endif 00072 static int create_scalar_type_tbl(opnd_type *, boolean); 00073 static int create_strct_tbl(opnd_type *, boolean); 00074 static boolean do_read_namelist_semantics(opnd_type *); 00075 static void do_write_namelist_semantics(opnd_type *); 00076 static int discombobulate_structure_ref(opnd_type *, int, int *); 00077 static int change_section_to_do(int *); 00078 static void process_deferred_io_list(void); 00079 static void expand_io_list(void); 00080 static void expand_imp_do(int, int); 00081 static int copy_text_for_expansion(int); 00082 static void create_io_call_descriptor(int, io_descriptor_type); 00083 # ifdef _NO_IO_ALTERNATE_RETURN 00084 static void add_alt_return_lbl(int, int); 00085 # endif 00086 static boolean item_has_bounds_chk(opnd_type *); 00087 static void gen_array_element_init(int, long_type *, opnd_type *, int, int); 00088 00089 static int err_attr_idx; 00090 00091 00092 /******************************************************************************\ 00093 |* *| 00094 |* Description: *| 00095 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 00096 |* *| 00097 |* Input parameters: *| 00098 |* NONE *| 00099 |* *| 00100 |* Output parameters: *| 00101 |* NONE *| 00102 |* *| 00103 |* Returns: *| 00104 |* NONE *| 00105 |* *| 00106 \******************************************************************************/ 00107 00108 void backspace_stmt_semantics (void) 00109 00110 { 00111 # ifndef _NO_IO_ALTERNATE_RETURN 00112 int alt_return_tmp; 00113 int asg_idx; 00114 int br_true_idx; 00115 int col; 00116 int eq_idx; 00117 int line; 00118 int save_next_sh_idx; 00119 # endif 00120 00121 int ir_idx; 00122 opnd_type opnd; 00123 int save_arg_info_list_base; 00124 int save_curr_stmt_sh_idx; 00125 boolean semantically_correct; 00126 00127 00128 TRACE (Func_Entry, "backspace_stmt_semantics", NULL); 00129 00130 SCP_DOES_IO(curr_scp_idx) = TRUE; 00131 00132 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 00133 00134 /* do memory management stuff to make sure the call tables are big enough */ 00135 00136 if (max_call_list_size >= arg_list_size) { 00137 enlarge_call_list_tables(); 00138 } 00139 00140 save_arg_info_list_base = arg_info_list_base; 00141 00142 arg_info_list_base = arg_info_list_top; 00143 00144 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx); 00145 00146 if (arg_info_list_top >= arg_info_list_size) { 00147 enlarge_info_list_table(); 00148 } 00149 00150 # ifndef _NO_IO_ALTERNATE_RETURN 00151 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 00152 # endif 00153 00154 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 00155 semantically_correct = io_ctl_list_semantics(&opnd, Backspace, TRUE); 00156 COPY_OPND(IR_OPND_R(ir_idx), opnd); 00157 00158 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 00159 00160 # ifndef _NO_IO_ALTERNATE_RETURN 00161 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) { 00162 00163 line = IR_LINE_NUM(ir_idx); 00164 col = IR_COL_NUM(ir_idx); 00165 00166 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE); 00167 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE; 00168 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx); 00169 AT_REFERENCED(alt_return_tmp) = Referenced; 00170 AT_DEFINED(alt_return_tmp) = TRUE; 00171 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE; 00172 00173 NTR_IR_TBL(asg_idx); 00174 IR_OPR(asg_idx) = Alt_Return_Opr; 00175 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 00176 IR_LINE_NUM(asg_idx) = line; 00177 IR_COL_NUM(asg_idx) = col; 00178 IR_LINE_NUM_L(asg_idx) = line; 00179 IR_COL_NUM_L(asg_idx) = col; 00180 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 00181 IR_IDX_L(asg_idx) = alt_return_tmp; 00182 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 00183 IR_IDX_R(asg_idx) = ir_idx; 00184 00185 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 00186 00187 if (err_list_idx) { 00188 NTR_IR_TBL(br_true_idx); 00189 IR_OPR(br_true_idx) = Br_True_Opr; 00190 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE; 00191 IR_LINE_NUM(br_true_idx) = line; 00192 IR_COL_NUM(br_true_idx) = col; 00193 00194 NTR_IR_TBL(eq_idx); 00195 IR_OPR(eq_idx) = Eq_Opr; 00196 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE; 00197 IR_LINE_NUM(eq_idx) = line; 00198 IR_COL_NUM(eq_idx) = col; 00199 IR_FLD_L(eq_idx) = AT_Tbl_Idx; 00200 IR_IDX_L(eq_idx) = alt_return_tmp; 00201 IR_LINE_NUM_L(eq_idx) = line; 00202 IR_COL_NUM_L(eq_idx) = col; 00203 00204 IR_FLD_R(eq_idx) = CN_Tbl_Idx; 00205 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX; 00206 IR_LINE_NUM_R(eq_idx) = line; 00207 IR_COL_NUM_R(eq_idx) = col; 00208 00209 IR_FLD_L(br_true_idx) = IR_Tbl_Idx; 00210 IR_IDX_L(br_true_idx) = eq_idx; 00211 00212 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx)); 00213 00214 curr_stmt_sh_idx = save_next_sh_idx; 00215 00216 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 00217 00218 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx; 00219 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00220 00221 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 00222 } 00223 } 00224 # endif 00225 00226 if (semantically_correct) { 00227 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 00228 semantically_correct = final_arg_work(&opnd, 00229 IR_IDX_L(ir_idx), 00230 IR_LIST_CNT_R(ir_idx), 00231 NULL); 00232 COPY_OPND(IR_OPND_R(ir_idx), opnd); 00233 00234 # if defined(_FILE_IO_OPRS) 00235 IR_OPR(ir_idx) = Backspace_Opr; 00236 # endif 00237 } 00238 00239 # ifdef _NO_IO_ALTERNATE_RETURN 00240 add_alt_return_lbl(ir_idx, err_attr_idx); 00241 # endif 00242 00243 /* restore arg_info_list to previous "stack frame" */ 00244 00245 arg_info_list_top = arg_info_list_base; 00246 arg_info_list_base = save_arg_info_list_base; 00247 00248 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 00249 00250 TRACE (Func_Exit, "backspace_stmt_semantics", NULL); 00251 00252 return; 00253 00254 } /* backspace_stmt_semantics */ 00255 00256 00257 /******************************************************************************\ 00258 |* *| 00259 |* Description: *| 00260 |* do semantic stuff for buffer in and buffer out stmts. *| 00261 |* *| 00262 |* Input parameters: *| 00263 |* NONE *| 00264 |* *| 00265 |* Output parameters: *| 00266 |* NONE *| 00267 |* *| 00268 |* Returns: *| 00269 |* NONE *| 00270 |* *| 00271 \******************************************************************************/ 00272 00273 void buffer_stmt_semantics (void) 00274 00275 { 00276 int base_attr; 00277 boolean buffer_in; 00278 int col; 00279 expr_arg_type exp_desc; 00280 expr_arg_type exp_desc2; 00281 int info_idx; 00282 int ir_idx; 00283 int line; 00284 int list_idx; 00285 opnd_type opnd; 00286 int save_arg_info_list_base; 00287 boolean semantically_correct; 00288 long_type the_constant[2]; 00289 int type_idx; 00290 00291 00292 TRACE (Func_Entry, "buffer_stmt_semantics", NULL); 00293 00294 SCP_DOES_IO(curr_scp_idx) = TRUE; 00295 00296 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 00297 00298 /* do memory management stuff to make sure the call tables are big enough */ 00299 00300 if (max_call_list_size >= arg_list_size) { 00301 enlarge_call_list_tables(); 00302 } 00303 00304 save_arg_info_list_base = arg_info_list_base; 00305 00306 arg_info_list_base = arg_info_list_top; 00307 00308 arg_info_list_top = arg_info_list_base + 5; 00309 00310 if (arg_info_list_top >= arg_info_list_size) { 00311 enlarge_info_list_table(); 00312 } 00313 00314 info_idx = arg_info_list_base; 00315 00316 if (IR_IDX_L(ir_idx) == glb_tbl_idx[Buffer_In_Attr_Idx]) { 00317 buffer_in = TRUE; 00318 } 00319 else { 00320 buffer_in = FALSE; 00321 } 00322 00323 /* process unit number or file name */ 00324 00325 list_idx = IR_IDX_R(ir_idx); 00326 COPY_OPND(opnd, IL_OPND(list_idx)); 00327 exp_desc.rank = 0; 00328 xref_state = CIF_Symbol_Reference; 00329 semantically_correct = expr_semantics(&opnd, &exp_desc); 00330 COPY_OPND(IL_OPND(list_idx), opnd); 00331 find_opnd_line_and_column(&opnd, &line, &col); 00332 00333 if (exp_desc.linear_type == Long_Typeless) { 00334 PRINTMSG(line, 1133, Error, col); 00335 semantically_correct = FALSE; 00336 } 00337 else if (exp_desc.type != Integer && 00338 exp_desc.type != Typeless && 00339 exp_desc.type != Character) { 00340 00341 /* error .. bad type for unit */ 00342 00343 PRINTMSG(line, 229, Error, col); 00344 semantically_correct = FALSE; 00345 } 00346 else if (exp_desc.type != Character && 00347 exp_desc.rank != 0) { 00348 00349 /* error .. not scalar */ 00350 00351 PRINTMSG(line, 229, Error, col); 00352 semantically_correct = FALSE; 00353 } 00354 else if (exp_desc.type == Character && 00355 exp_desc.constant) { 00356 00357 /* change to Typeless if length right */ 00358 00359 if (compare_cn_and_value(TYP_IDX(CN_TYPE_IDX(OPND_IDX(opnd))), 00360 TARGET_BYTES_PER_WORD, 00361 Lt_Opr)) { 00362 CN_TYPE_IDX(OPND_IDX(opnd)) = TYPELESS_DEFAULT_TYPE; 00363 } 00364 else { 00365 PRINTMSG(line, 231, Error, col, 00366 TARGET_BYTES_PER_WORD - 1); 00367 semantically_correct = FALSE; 00368 } 00369 } 00370 else if (exp_desc.linear_type == Short_Typeless_Const) { 00371 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx), 00372 CG_INTEGER_DEFAULT_TYPE, 00373 line, 00374 col); 00375 exp_desc.linear_type = INTEGER_DEFAULT_TYPE; 00376 exp_desc.type_idx = INTEGER_DEFAULT_TYPE; 00377 exp_desc.type = Integer; 00378 } 00379 00380 COPY_OPND(opnd, IL_OPND(list_idx)); 00381 cast_to_cg_default(&opnd, &exp_desc); 00382 COPY_OPND(IL_OPND(list_idx), opnd); 00383 00384 info_idx++; 00385 arg_info_list[info_idx] = init_arg_info; 00386 arg_info_list[info_idx].ed = exp_desc; 00387 arg_info_list[info_idx].maybe_modified = TRUE; 00388 IL_ARG_DESC_IDX(list_idx) = info_idx; 00389 00390 /* process mode */ 00391 00392 list_idx = IL_NEXT_LIST_IDX(list_idx); 00393 COPY_OPND(opnd, IL_OPND(list_idx)); 00394 exp_desc.rank = 0; 00395 xref_state = CIF_Symbol_Reference; 00396 semantically_correct = expr_semantics(&opnd, &exp_desc) && 00397 semantically_correct; 00398 COPY_OPND(IL_OPND(list_idx), opnd); 00399 00400 if (exp_desc.type != Integer) { 00401 00402 /* error .. mode must be integer expression */ 00403 00404 find_opnd_line_and_column(&opnd, &line, &col); 00405 PRINTMSG(line, 228, Error, col); 00406 semantically_correct = FALSE; 00407 } 00408 00409 if (exp_desc.rank != 0) { /* error .. must be scalar */ 00410 find_opnd_line_and_column(&opnd, &line, &col); 00411 PRINTMSG(line, 230, Error, col); 00412 semantically_correct = FALSE; 00413 } 00414 00415 COPY_OPND(opnd, IL_OPND(list_idx)); 00416 cast_to_cg_default(&opnd, &exp_desc); 00417 COPY_OPND(IL_OPND(list_idx), opnd); 00418 00419 info_idx++; 00420 arg_info_list[info_idx] = init_arg_info; 00421 arg_info_list[info_idx].ed = exp_desc; 00422 arg_info_list[info_idx].maybe_modified = TRUE; 00423 IL_ARG_DESC_IDX(list_idx) = info_idx; 00424 00425 /* process bloc */ 00426 00427 list_idx = IL_NEXT_LIST_IDX(list_idx); 00428 00429 COPY_OPND(opnd, IL_OPND(list_idx)); 00430 exp_desc.rank = 0; 00431 00432 if (buffer_in) { 00433 xref_state = CIF_Symbol_Modification; 00434 } 00435 else { 00436 xref_state = CIF_Symbol_Reference; 00437 } 00438 semantically_correct = expr_semantics(&opnd, &exp_desc) && 00439 semantically_correct; 00440 COPY_OPND(IL_OPND(list_idx), opnd); 00441 00442 base_attr = find_base_attr(&opnd, &line, &col); 00443 00444 info_idx++; 00445 arg_info_list[info_idx] = init_arg_info; 00446 arg_info_list[info_idx].ed = exp_desc; 00447 arg_info_list[info_idx].maybe_modified = TRUE; 00448 IL_ARG_DESC_IDX(list_idx) = info_idx; 00449 00450 list_idx = IL_NEXT_LIST_IDX(list_idx); 00451 00452 /* process eloc */ 00453 00454 COPY_OPND(opnd, IL_OPND(list_idx)); 00455 exp_desc.rank = 0; 00456 00457 if (buffer_in) { 00458 xref_state = CIF_Symbol_Modification; 00459 } 00460 else { 00461 xref_state = CIF_Symbol_Reference; 00462 } 00463 semantically_correct = expr_semantics(&opnd, &exp_desc2) && 00464 semantically_correct; 00465 COPY_OPND(IL_OPND(list_idx), opnd); 00466 00467 if (exp_desc.type == Structure) { 00468 find_opnd_line_and_column(&opnd, &line, &col); 00469 PRINTMSG(line, 879, Error, col); 00470 semantically_correct = FALSE; 00471 } 00472 else if ((exp_desc.type == Character && 00473 exp_desc2.type != Character) || 00474 (exp_desc2.type == Character && 00475 exp_desc.type != Character)) { 00476 00477 find_opnd_line_and_column(&opnd, &line, &col); 00478 PRINTMSG(line, 896, Error, col); 00479 semantically_correct = FALSE; 00480 } 00481 else if (exp_desc.type != Character && 00482 exp_desc2.type != Character && 00483 storage_bit_size_tbl[exp_desc.linear_type] != 00484 storage_bit_size_tbl[exp_desc2.linear_type]) { 00485 00486 find_opnd_line_and_column(&opnd, &line, &col); 00487 PRINTMSG(line, 896, Error, col); 00488 semantically_correct = FALSE; 00489 } 00490 00491 info_idx++; 00492 arg_info_list[info_idx] = init_arg_info; 00493 arg_info_list[info_idx].ed = exp_desc2; 00494 arg_info_list[info_idx].maybe_modified = TRUE; 00495 IL_ARG_DESC_IDX(list_idx) = info_idx; 00496 00497 /* set up type code arg */ 00498 00499 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 00500 list_idx = IL_NEXT_LIST_IDX(list_idx); 00501 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 00502 IR_LIST_CNT_R(ir_idx) = 5; 00503 00504 make_io_type_code(ATD_TYPE_IDX(base_attr), the_constant); /* BRIANJ */ 00505 IL_FLD(list_idx) = CN_Tbl_Idx; 00506 00507 # if defined(GENERATE_WHIRL) && ! defined(_TYPE_CODE_64_BIT) 00508 /* the type information goes in a 64 bit thing for mongoose */ 00509 the_constant[1] = the_constant[0]; 00510 the_constant[0] = 0; 00511 type_idx = Integer_8; 00512 # else 00513 type_idx = IO_TYPE_CODE_TYPE; 00514 # endif 00515 00516 /* BRIANJ - KAYKAY */ 00517 00518 IL_IDX(list_idx) = ntr_const_tbl(type_idx, 00519 FALSE, 00520 the_constant); 00521 IL_LINE_NUM(list_idx) = line; 00522 IL_COL_NUM(list_idx) = col; 00523 00524 exp_desc = init_exp_desc; 00525 exp_desc.type = TYP_TYPE(type_idx); 00526 exp_desc.linear_type = TYP_LINEAR(type_idx); 00527 exp_desc.type_idx = type_idx; 00528 exp_desc.constant = TRUE; 00529 exp_desc.foldable = TRUE; 00530 00531 info_idx++; 00532 arg_info_list[info_idx] = init_arg_info; 00533 arg_info_list[info_idx].ed = exp_desc; 00534 arg_info_list[info_idx].maybe_modified = TRUE; 00535 IL_ARG_DESC_IDX(list_idx) = info_idx; 00536 00537 if (semantically_correct) { 00538 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 00539 semantically_correct = final_arg_work(&opnd, 00540 IR_IDX_L(ir_idx), 00541 IR_LIST_CNT_R(ir_idx), 00542 NULL); 00543 COPY_OPND(IR_OPND_R(ir_idx), opnd); 00544 create_io_call_descriptor(ir_idx, Buffer_Desc); 00545 # if 0 00546 # if defined(_FILE_IO_OPRS) 00547 if (buffer_in) { 00548 IR_OPR(ir_idx) = Buffer_In_Opr; 00549 } 00550 else { 00551 IR_OPR(ir_idx) = Buffer_Out_Opr; 00552 } 00553 # endif 00554 # endif 00555 } 00556 00557 /* restore arg_info_list to previous "stack frame" */ 00558 00559 arg_info_list_top = arg_info_list_base; 00560 arg_info_list_base = save_arg_info_list_base; 00561 00562 TRACE (Func_Exit, "buffer_stmt_semantics", NULL); 00563 00564 return; 00565 00566 } /* buffer_stmt_semantics */ 00567 00568 00569 /******************************************************************************\ 00570 |* *| 00571 |* Description: *| 00572 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 00573 |* *| 00574 |* Input parameters: *| 00575 |* NONE *| 00576 |* *| 00577 |* Output parameters: *| 00578 |* NONE *| 00579 |* *| 00580 |* Returns: *| 00581 |* NONE *| 00582 |* *| 00583 \******************************************************************************/ 00584 00585 void close_stmt_semantics (void) 00586 00587 { 00588 00589 int ir_idx; 00590 opnd_type opnd; 00591 int save_arg_info_list_base; 00592 int save_curr_stmt_sh_idx; 00593 boolean semantically_correct; 00594 00595 # ifndef _NO_IO_ALTERNATE_RETURN 00596 int alt_return_tmp; 00597 int asg_idx; 00598 int br_true_idx; 00599 int col; 00600 int eq_idx; 00601 int line; 00602 int save_next_sh_idx; 00603 # endif 00604 00605 00606 TRACE (Func_Entry, "close_stmt_semantics", NULL); 00607 00608 SCP_DOES_IO(curr_scp_idx) = TRUE; 00609 00610 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 00611 00612 /* do memory management stuff to make sure the call tables are big enough */ 00613 00614 if (max_call_list_size >= arg_list_size) { 00615 enlarge_call_list_tables(); 00616 } 00617 00618 save_arg_info_list_base = arg_info_list_base; 00619 00620 arg_info_list_base = arg_info_list_top; 00621 00622 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx); 00623 00624 if (arg_info_list_top >= arg_info_list_size) { 00625 enlarge_info_list_table(); 00626 } 00627 00628 # ifndef _NO_IO_ALTERNATE_RETURN 00629 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 00630 # endif 00631 00632 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 00633 semantically_correct = io_ctl_list_semantics(&opnd, Close, TRUE); 00634 COPY_OPND(IR_OPND_R(ir_idx), opnd); 00635 00636 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 00637 00638 # ifndef _NO_IO_ALTERNATE_RETURN 00639 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) { 00640 00641 line = IR_LINE_NUM(ir_idx); 00642 col = IR_COL_NUM(ir_idx); 00643 00644 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE); 00645 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE; 00646 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx); 00647 AT_REFERENCED(alt_return_tmp) = Referenced; 00648 AT_DEFINED(alt_return_tmp) = TRUE; 00649 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE; 00650 00651 NTR_IR_TBL(asg_idx); 00652 IR_OPR(asg_idx) = Alt_Return_Opr; 00653 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 00654 IR_LINE_NUM(asg_idx) = line; 00655 IR_COL_NUM(asg_idx) = col; 00656 IR_LINE_NUM_L(asg_idx) = line; 00657 IR_COL_NUM_L(asg_idx) = col; 00658 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 00659 IR_IDX_L(asg_idx) = alt_return_tmp; 00660 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 00661 IR_IDX_R(asg_idx) = ir_idx; 00662 00663 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 00664 00665 if (err_list_idx) { 00666 NTR_IR_TBL(br_true_idx); 00667 IR_OPR(br_true_idx) = Br_True_Opr; 00668 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE; 00669 IR_LINE_NUM(br_true_idx) = line; 00670 IR_COL_NUM(br_true_idx) = col; 00671 00672 NTR_IR_TBL(eq_idx); 00673 IR_OPR(eq_idx) = Eq_Opr; 00674 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE; 00675 IR_LINE_NUM(eq_idx) = line; 00676 IR_COL_NUM(eq_idx) = col; 00677 IR_FLD_L(eq_idx) = AT_Tbl_Idx; 00678 IR_IDX_L(eq_idx) = alt_return_tmp; 00679 IR_LINE_NUM_L(eq_idx) = line; 00680 IR_COL_NUM_L(eq_idx) = col; 00681 00682 IR_FLD_R(eq_idx) = CN_Tbl_Idx; 00683 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX; 00684 IR_LINE_NUM_R(eq_idx) = line; 00685 IR_COL_NUM_R(eq_idx) = col; 00686 00687 IR_FLD_L(br_true_idx) = IR_Tbl_Idx; 00688 IR_IDX_L(br_true_idx) = eq_idx; 00689 00690 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx)); 00691 00692 curr_stmt_sh_idx = save_next_sh_idx; 00693 00694 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 00695 00696 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx; 00697 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00698 00699 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 00700 } 00701 } 00702 # endif 00703 00704 if (semantically_correct) { 00705 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 00706 semantically_correct = final_arg_work(&opnd, 00707 IR_IDX_L(ir_idx), 00708 IR_LIST_CNT_R(ir_idx), 00709 NULL); 00710 COPY_OPND(IR_OPND_R(ir_idx), opnd); 00711 create_io_call_descriptor(ir_idx, Close_Desc); 00712 # if defined(_FILE_IO_OPRS) 00713 IR_OPR(ir_idx) = Close_Opr; 00714 # endif 00715 } 00716 00717 # ifdef _NO_IO_ALTERNATE_RETURN 00718 add_alt_return_lbl(ir_idx, err_attr_idx); 00719 # endif 00720 00721 /* restore arg_info_list to previous "stack frame" */ 00722 00723 arg_info_list_top = arg_info_list_base; 00724 arg_info_list_base = save_arg_info_list_base; 00725 00726 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 00727 00728 TRACE (Func_Exit, "close_stmt_semantics", NULL); 00729 00730 return; 00731 00732 } /* close_stmt_semantics */ 00733 00734 00735 /******************************************************************************\ 00736 |* *| 00737 |* Description: *| 00738 |* Process the decode stmt. It is transformed into an internal Read. *| 00739 |* Process the encode stmt. It is transformed into an internal Write. *| 00740 |* *| 00741 |* Input parameters: *| 00742 |* NONE *| 00743 |* *| 00744 |* Output parameters: *| 00745 |* NONE *| 00746 |* *| 00747 |* Returns: *| 00748 |* NONE *| 00749 |* *| 00750 \******************************************************************************/ 00751 00752 void encode_decode_stmt_semantics (void) 00753 00754 { 00755 int attr_idx; 00756 int cnt_list_idx; 00757 int col; 00758 expr_arg_type exp_desc; 00759 int free_list_idx; 00760 int fmt_list_idx; 00761 int intern_list_idx; 00762 int ir_idx; 00763 opnd_type left_opnd; 00764 int line; 00765 int list_idx; 00766 boolean ok; 00767 opnd_type opnd; 00768 int pp_tmp = NULL_IDX; 00769 int tmp_idx; 00770 00771 00772 TRACE (Func_Entry, "encode_decode_stmt_semantics", NULL); 00773 00774 SCP_DOES_IO(curr_scp_idx) = TRUE; 00775 00776 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 00777 00778 cnt_list_idx = IR_IDX_L(ir_idx); 00779 00780 COPY_OPND(opnd, IL_OPND(cnt_list_idx)); 00781 exp_desc.rank = 0; 00782 xref_state = CIF_Symbol_Reference; 00783 ok = expr_semantics(&opnd, &exp_desc); 00784 COPY_OPND(IL_OPND(cnt_list_idx), opnd); 00785 find_opnd_line_and_column(&opnd, &line, &col); 00786 00787 if (exp_desc.type != Integer) { 00788 PRINTMSG(line, 681, Error, col, stmt_type_str[stmt_type]); 00789 } 00790 else if (exp_desc.constant && 00791 (CN_INT_TO_C(OPND_IDX(opnd)) <= 0 || 00792 CN_INT_TO_C(OPND_IDX(opnd)) > 152)) { 00793 00794 PRINTMSG(line, 682, Error, col, stmt_type_str[stmt_type]); 00795 } 00796 else if (exp_desc.rank > 0) { 00797 PRINTMSG(line, 683, Error, col, stmt_type_str[stmt_type]); 00798 } 00799 00800 /* do I need the count ? */ 00801 00802 fmt_list_idx = IL_NEXT_LIST_IDX(cnt_list_idx); 00803 00804 if (IL_FLD(fmt_list_idx) == IL_Tbl_Idx) { 00805 00806 /* this was format character constant inline */ 00807 /* do not send through expr_semantics. */ 00808 /* first item is format tmp, second is */ 00809 /* preparsed format tmp. */ 00810 00811 pp_tmp = IL_IDX(IL_NEXT_LIST_IDX(IL_IDX(fmt_list_idx))); 00812 FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(IL_IDX(fmt_list_idx))); 00813 free_list_idx = IL_IDX(fmt_list_idx); 00814 COPY_OPND(IL_OPND(fmt_list_idx), IL_OPND(IL_IDX(fmt_list_idx))); 00815 FREE_IR_LIST_NODE(free_list_idx); 00816 00817 ADD_TMP_TO_SHARED_LIST(IL_IDX(fmt_list_idx)); 00818 ADD_TMP_TO_SHARED_LIST(pp_tmp); 00819 } 00820 else if (IL_FLD(fmt_list_idx) == AT_Tbl_Idx && 00821 AT_OBJ_CLASS(IL_IDX(fmt_list_idx)) == Label) { 00822 00823 if (ATL_CLASS(IL_IDX(fmt_list_idx)) == Lbl_Format) { 00824 00825 pp_tmp = ATL_PP_FORMAT_TMP(IL_IDX(fmt_list_idx)); 00826 /* replace label reference with format constant idx */ 00827 IL_IDX(fmt_list_idx) = ATL_FORMAT_TMP(IL_IDX(fmt_list_idx)); 00828 IL_FLD(fmt_list_idx) = AT_Tbl_Idx; 00829 IL_LINE_NUM(fmt_list_idx) = line; 00830 IL_COL_NUM(fmt_list_idx) = col; 00831 00832 ADD_TMP_TO_SHARED_LIST(ATL_FORMAT_TMP(IL_IDX(fmt_list_idx))); 00833 00834 ADD_TMP_TO_SHARED_LIST(ATL_PP_FORMAT_TMP(IL_IDX(fmt_list_idx))); 00835 00836 } 00837 00838 /* if not a format label LRR will have already caught it */ 00839 } 00840 else { 00841 00842 COPY_OPND(opnd, IL_OPND(fmt_list_idx)); 00843 exp_desc.rank = 0; 00844 xref_state = CIF_Symbol_Reference; 00845 io_item_must_flatten = FALSE; 00846 ok = expr_semantics(&opnd, &exp_desc); 00847 COPY_OPND(IL_OPND(fmt_list_idx), opnd); 00848 00849 /* do format checks */ 00850 00851 find_opnd_line_and_column(&opnd, &line, &col); 00852 00853 if (exp_desc.type == Character) { 00854 00855 if (io_item_must_flatten || 00856 exp_desc.dist_reshape_ref || 00857 exp_desc.vector_subscript) { 00858 00859 tmp_idx = create_tmp_asg(&opnd, &exp_desc, &left_opnd, 00860 Intent_In, TRUE, FALSE); 00861 COPY_OPND(IL_OPND(fmt_list_idx), left_opnd); 00862 } 00863 } 00864 else if (exp_desc.rank > 0 && 00865 (OPND_FLD(opnd) != IR_Tbl_Idx || 00866 exp_desc.dope_vector || 00867 IR_OPR(OPND_IDX(opnd)) != Whole_Subscript_Opr)) { 00868 00869 /* these are noncontiguous arrays, sections, dope vectors */ 00870 /* error .. format error */ 00871 00872 PRINTMSG(line, 447, Error, col); 00873 } 00874 else if (exp_desc.type == Integer && 00875 exp_desc.reference) { 00876 00877 if (exp_desc.rank == 0) { /* check for ASSIGN */ 00878 00879 if (!exp_desc.reference) { /* error .. must be variable */ 00880 PRINTMSG(line, 447, Error, col); 00881 } 00882 else if (exp_desc.linear_type != INTEGER_DEFAULT_TYPE) { 00883 00884 /* must be default kind */ 00885 00886 PRINTMSG(line, 462, Error, col); 00887 } 00888 else { 00889 00890 attr_idx = find_base_attr(&opnd, &line, &col); 00891 00892 if (! ATD_IN_ASSIGN(attr_idx)) { 00893 PRINTMSG(line, 1099, Error, col); 00894 } 00895 00896 # if defined(GENERATE_WHIRL) 00897 if (ATD_ASSIGN_TMP_IDX(attr_idx) != NULL_IDX) { 00898 OPND_FLD(opnd) = AT_Tbl_Idx; 00899 OPND_IDX(opnd) = ATD_ASSIGN_TMP_IDX(attr_idx); 00900 COPY_OPND(IL_OPND(fmt_list_idx), opnd); 00901 ADD_TMP_TO_SHARED_LIST(ATD_ASSIGN_TMP_IDX(attr_idx)); 00902 } 00903 # endif 00904 } 00905 } 00906 else { /* integer array is nonstandard */ 00907 PRINTMSG(line, 778, Ansi, col); 00908 } 00909 } 00910 else if ((exp_desc.linear_type == REAL_DEFAULT_TYPE || 00911 exp_desc.type == Logical) && 00912 exp_desc.reference && 00913 exp_desc.rank > 0) { 00914 PRINTMSG(line, 778, Ansi, col); 00915 } 00916 else if (exp_desc.type == Typeless && 00917 exp_desc.rank == 0) { 00918 00919 /* intentionally blank */ 00920 /* ansi msg already issued by lex */ 00921 } 00922 else { /* error .. format error */ 00923 PRINTMSG(line, 447, Error, col); 00924 } 00925 } 00926 00927 intern_list_idx = IL_NEXT_LIST_IDX(fmt_list_idx); 00928 00929 COPY_OPND(opnd, IL_OPND(intern_list_idx)); 00930 exp_desc.rank = 0; 00931 00932 if (stmt_type == Encode_Stmt) { 00933 xref_state = CIF_Symbol_Modification; 00934 } 00935 else { 00936 xref_state = CIF_Symbol_Reference; 00937 } 00938 ok = expr_semantics(&opnd, &exp_desc); 00939 COPY_OPND(IL_OPND(intern_list_idx), opnd); 00940 00941 /* do internal unit semantics */ 00942 00943 if (stmt_type == Encode_Stmt) { 00944 00945 /* check for live do loop variable definition for encode */ 00946 00947 if (! check_for_legal_define(&opnd)) { 00948 ok = FALSE; 00949 } 00950 } 00951 00952 /* internal unit must be variable, array element or contiguous array */ 00953 00954 COPY_OPND(opnd, IL_OPND(intern_list_idx)); 00955 find_opnd_line_and_column(&opnd, &line, &col); 00956 00957 if (OPND_FLD(opnd) == IR_Tbl_Idx && 00958 IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr) { 00959 00960 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 00961 } 00962 00963 if (OPND_FLD(opnd) == IR_Tbl_Idx && 00964 (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr || 00965 IR_OPR(OPND_IDX(opnd)) == Subscript_Opr)) { 00966 00967 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 00968 } 00969 00970 if (OPND_FLD(opnd) != AT_Tbl_Idx) { 00971 /* bad internal unit reference */ 00972 00973 PRINTMSG(line, 1112, Error, col, 00974 (stmt_type == Encode_Stmt ? "destination" : "source"), 00975 (stmt_type == Encode_Stmt ? "ENCODE" : "DECODE")); 00976 00977 ok = FALSE; 00978 } 00979 else if (AT_OBJ_CLASS(OPND_IDX(opnd)) != Data_Obj || 00980 (ATD_CLASS(OPND_IDX(opnd)) != Variable && 00981 ATD_CLASS(OPND_IDX(opnd)) != Dummy_Argument && 00982 ATD_CLASS(OPND_IDX(opnd)) != Function_Result) || 00983 ATD_POINTER(OPND_IDX(opnd)) || 00984 ATD_ALLOCATABLE(OPND_IDX(opnd))) { 00985 00986 /* bad internal unit */ 00987 PRINTMSG(line, 1112, Error, col, 00988 (stmt_type == Encode_Stmt ? "destination" : "source"), 00989 (stmt_type == Encode_Stmt ? "ENCODE" : "DECODE")); 00990 ok = FALSE; 00991 } 00992 00993 00994 /* put in correct order for pgdcs */ 00995 00996 /******************\ 00997 |* start new list *| 00998 \******************/ 00999 01000 IR_IDX_L(ir_idx) = cnt_list_idx; 01001 # ifdef _NO_IO_ALTERNATE_RETURN 01002 IR_LIST_CNT_L(ir_idx) = NUM_PDG_CONTROL_LIST_ITEMS + 3; 01003 # else 01004 IR_LIST_CNT_L(ir_idx) = NUM_PDG_CONTROL_LIST_ITEMS; 01005 # endif 01006 01007 /**************************\ 01008 |* 1 - encode/decode flag *| 01009 \**************************/ 01010 01011 /* this is the cnt opnd */ 01012 IL_PREV_LIST_IDX(cnt_list_idx) = NULL_IDX; 01013 01014 /*********************\ 01015 |* 2 - eeeflag value *| 01016 \*********************/ 01017 01018 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(cnt_list_idx)); 01019 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(cnt_list_idx)) = cnt_list_idx; 01020 list_idx = IL_NEXT_LIST_IDX(cnt_list_idx); 01021 01022 IL_FLD(list_idx) = CN_Tbl_Idx; 01023 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 01024 IL_LINE_NUM(list_idx) = line; 01025 IL_COL_NUM(list_idx) = col; 01026 01027 /**********************\ 01028 |* 3 - flflag value *| 01029 \**********************/ 01030 01031 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01032 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01033 list_idx = IL_NEXT_LIST_IDX(list_idx); 01034 01035 /* This is the flag for split io */ 01036 /* set to FL_IO_SINGLE for now */ 01037 01038 IL_FLD(list_idx) = CN_Tbl_Idx; 01039 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, FL_IO_SINGLE); 01040 IL_LINE_NUM(list_idx) = line; 01041 IL_COL_NUM(list_idx) = col; 01042 01043 01044 /**********************\ 01045 |* 4 - UNIT specifier *| 01046 \**********************/ 01047 01048 IL_NEXT_LIST_IDX(list_idx) = intern_list_idx; 01049 IL_PREV_LIST_IDX(intern_list_idx) = list_idx; 01050 list_idx = IL_NEXT_LIST_IDX(list_idx); 01051 01052 /***********************\ 01053 |* 5 - IOSTAT variable *| 01054 \***********************/ 01055 01056 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01057 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01058 list_idx = IL_NEXT_LIST_IDX(list_idx); 01059 01060 /**********************\ 01061 |* 6 - REC expression *| 01062 \**********************/ 01063 01064 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01065 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01066 list_idx = IL_NEXT_LIST_IDX(list_idx); 01067 01068 /*************************\ 01069 |* 7 - pre-parsed format *| 01070 \*************************/ 01071 01072 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01073 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01074 list_idx = IL_NEXT_LIST_IDX(list_idx); 01075 01076 /* get pre-parsed from somewhere */ 01077 01078 if (pp_tmp) { 01079 IL_FLD(list_idx) = AT_Tbl_Idx; 01080 IL_IDX(list_idx) = pp_tmp; 01081 IL_LINE_NUM(list_idx) = line; 01082 IL_COL_NUM(list_idx) = col; 01083 } 01084 01085 /*********************\ 01086 |* 8 - format source *| 01087 \*********************/ 01088 01089 IL_NEXT_LIST_IDX(list_idx) = fmt_list_idx; 01090 IL_PREV_LIST_IDX(fmt_list_idx) = list_idx; 01091 list_idx = IL_NEXT_LIST_IDX(list_idx); 01092 01093 /**************************\ 01094 |* 9 - ADVANCE expression *| 01095 \**************************/ 01096 01097 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01098 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01099 list_idx = IL_NEXT_LIST_IDX(list_idx); 01100 01101 /************************\ 01102 |* 10 - SIZE expression *| 01103 \************************/ 01104 01105 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01106 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01107 list_idx = IL_NEXT_LIST_IDX(list_idx); 01108 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 01109 01110 # ifdef _NO_IO_ALTERNATE_RETURN 01111 /************************\ 01112 |* 11 - ERR label *| 01113 \************************/ 01114 01115 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01116 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01117 list_idx = IL_NEXT_LIST_IDX(list_idx); 01118 01119 /************************\ 01120 |* 12 - END label *| 01121 \************************/ 01122 01123 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01124 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01125 list_idx = IL_NEXT_LIST_IDX(list_idx); 01126 01127 /************************\ 01128 |* 13 - EOR label *| 01129 \************************/ 01130 01131 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01132 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01133 list_idx = IL_NEXT_LIST_IDX(list_idx); 01134 # endif 01135 01136 01137 /* now do io list */ 01138 01139 01140 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01141 01142 defer_stmt_expansion = TRUE; 01143 number_of_functions = 0; 01144 io_stmt_must_be_split = FALSE; 01145 01146 if (stmt_type == Decode_Stmt) { 01147 ok = io_list_semantics(&opnd, Decode); 01148 } 01149 else { 01150 ok = io_list_semantics(&opnd, Encode); 01151 } 01152 01153 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01154 01155 defer_stmt_expansion = FALSE; 01156 01157 if (ok && 01158 (number_of_functions > 0 || 01159 tree_has_constructor || 01160 io_stmt_must_be_split || 01161 io_item_must_flatten)) { 01162 process_deferred_io_list(); 01163 } 01164 else if (ok) { 01165 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01166 gen_runtime_checks(&opnd); 01167 } 01168 01169 TRACE (Func_Exit, "encode_decode_stmt_semantics", NULL); 01170 01171 return; 01172 01173 } /* encode_decode_stmt_semantics */ 01174 01175 01176 /******************************************************************************\ 01177 |* *| 01178 |* Description: *| 01179 |* ADD A DESCRIPTION HERE, Brian. *| 01180 |* *| 01181 |* Input parameters: *| 01182 |* NONE *| 01183 |* *| 01184 |* Output parameters: *| 01185 |* NONE *| 01186 |* *| 01187 |* Returns: *| 01188 |* NONE *| 01189 |* *| 01190 \******************************************************************************/ 01191 01192 void endfile_stmt_semantics (void) 01193 01194 { 01195 int ir_idx; 01196 opnd_type opnd; 01197 int save_arg_info_list_base; 01198 int save_curr_stmt_sh_idx; 01199 boolean semantically_correct; 01200 01201 # ifndef _NO_IO_ALTERNATE_RETURN 01202 int alt_return_tmp; 01203 int asg_idx; 01204 int br_true_idx; 01205 int col; 01206 int eq_idx; 01207 int line; 01208 int save_next_sh_idx; 01209 # endif 01210 01211 01212 TRACE (Func_Entry, "endfile_stmt_semantics", NULL); 01213 01214 SCP_DOES_IO(curr_scp_idx) = TRUE; 01215 01216 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 01217 01218 /* do memory management stuff to make sure the call tables are big enough */ 01219 01220 if (max_call_list_size >= arg_list_size) { 01221 enlarge_call_list_tables(); 01222 } 01223 01224 save_arg_info_list_base = arg_info_list_base; 01225 01226 arg_info_list_base = arg_info_list_top; 01227 01228 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx); 01229 01230 if (arg_info_list_top >= arg_info_list_size) { 01231 enlarge_info_list_table(); 01232 } 01233 01234 # ifndef _NO_IO_ALTERNATE_RETURN 01235 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 01236 # endif 01237 01238 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01239 semantically_correct = io_ctl_list_semantics(&opnd, Endfile, TRUE); 01240 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01241 01242 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 01243 01244 # ifndef _NO_IO_ALTERNATE_RETURN 01245 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) { 01246 01247 line = IR_LINE_NUM(ir_idx); 01248 col = IR_COL_NUM(ir_idx); 01249 01250 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE); 01251 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE; 01252 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx); 01253 AT_REFERENCED(alt_return_tmp) = Referenced; 01254 AT_DEFINED(alt_return_tmp) = TRUE; 01255 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE; 01256 01257 NTR_IR_TBL(asg_idx); 01258 IR_OPR(asg_idx) = Alt_Return_Opr; 01259 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 01260 IR_LINE_NUM(asg_idx) = line; 01261 IR_COL_NUM(asg_idx) = col; 01262 IR_LINE_NUM_L(asg_idx) = line; 01263 IR_COL_NUM_L(asg_idx) = col; 01264 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 01265 IR_IDX_L(asg_idx) = alt_return_tmp; 01266 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 01267 IR_IDX_R(asg_idx) = ir_idx; 01268 01269 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 01270 01271 if (err_list_idx) { 01272 NTR_IR_TBL(br_true_idx); 01273 IR_OPR(br_true_idx) = Br_True_Opr; 01274 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE; 01275 IR_LINE_NUM(br_true_idx) = line; 01276 IR_COL_NUM(br_true_idx) = col; 01277 01278 NTR_IR_TBL(eq_idx); 01279 IR_OPR(eq_idx) = Eq_Opr; 01280 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE; 01281 IR_LINE_NUM(eq_idx) = line; 01282 IR_COL_NUM(eq_idx) = col; 01283 IR_FLD_L(eq_idx) = AT_Tbl_Idx; 01284 IR_IDX_L(eq_idx) = alt_return_tmp; 01285 IR_LINE_NUM_L(eq_idx) = line; 01286 IR_COL_NUM_L(eq_idx) = col; 01287 01288 IR_FLD_R(eq_idx) = CN_Tbl_Idx; 01289 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX; 01290 IR_LINE_NUM_R(eq_idx) = line; 01291 IR_COL_NUM_R(eq_idx) = col; 01292 01293 IR_FLD_L(br_true_idx) = IR_Tbl_Idx; 01294 IR_IDX_L(br_true_idx) = eq_idx; 01295 01296 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx)); 01297 01298 curr_stmt_sh_idx = save_next_sh_idx; 01299 01300 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 01301 01302 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx; 01303 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01304 01305 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 01306 } 01307 } 01308 # endif 01309 01310 if (semantically_correct) { 01311 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01312 semantically_correct = final_arg_work(&opnd, 01313 IR_IDX_L(ir_idx), 01314 IR_LIST_CNT_R(ir_idx), 01315 NULL); 01316 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01317 # if defined(_FILE_IO_OPRS) 01318 IR_OPR(ir_idx) = Endfile_Opr; 01319 # endif 01320 } 01321 01322 # ifdef _NO_IO_ALTERNATE_RETURN 01323 add_alt_return_lbl(ir_idx, err_attr_idx); 01324 # endif 01325 01326 /* restore arg_info_list to previous "stack frame" */ 01327 01328 arg_info_list_top = arg_info_list_base; 01329 arg_info_list_base = save_arg_info_list_base; 01330 01331 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 01332 01333 TRACE (Func_Exit, "endfile_stmt_semantics", NULL); 01334 01335 return; 01336 01337 } /* endfile_stmt_semantics */ 01338 01339 01340 /******************************************************************************\ 01341 |* *| 01342 |* Description: *| 01343 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 01344 |* *| 01345 |* Input parameters: *| 01346 |* NONE *| 01347 |* *| 01348 |* Output parameters: *| 01349 |* NONE *| 01350 |* *| 01351 |* Returns: *| 01352 |* NONE *| 01353 |* *| 01354 \******************************************************************************/ 01355 01356 void inquire_stmt_semantics (void) 01357 01358 { 01359 int asg_idx; 01360 int attr_idx; 01361 int col; 01362 expr_arg_type exp_desc; 01363 int ir_idx; 01364 int line; 01365 int list_idx; 01366 opnd_type opnd; 01367 int save_arg_info_list_base; 01368 int save_curr_stmt_sh_idx; 01369 boolean semantically_correct; 01370 int tmp_idx; 01371 01372 # ifndef _NO_IO_ALTERNATE_RETURN 01373 int alt_return_tmp; 01374 int br_true_idx; 01375 int eq_idx; 01376 int save_next_sh_idx; 01377 # endif 01378 01379 01380 TRACE (Func_Entry, "inquire_stmt_semantics", NULL); 01381 01382 SCP_DOES_IO(curr_scp_idx) = TRUE; 01383 01384 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 01385 line = IR_LINE_NUM(ir_idx); 01386 col = IR_COL_NUM(ir_idx); 01387 01388 /* do memory management stuff to make sure the call tables are big enough */ 01389 01390 if (max_call_list_size >= arg_list_size) { 01391 enlarge_call_list_tables(); 01392 } 01393 01394 save_arg_info_list_base = arg_info_list_base; 01395 01396 arg_info_list_base = arg_info_list_top; 01397 01398 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx); 01399 01400 if (arg_info_list_top >= arg_info_list_size) { 01401 enlarge_info_list_table(); 01402 } 01403 01404 if (IR_OPR(ir_idx) == Call_Opr) { 01405 01406 # ifndef _NO_IO_ALTERNATE_RETURN 01407 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 01408 # endif 01409 01410 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01411 semantically_correct = io_ctl_list_semantics(&opnd, Inquire, TRUE); 01412 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01413 01414 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 01415 01416 # ifndef _NO_IO_ALTERNATE_RETURN 01417 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) { 01418 01419 01420 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE); 01421 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE; 01422 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx); 01423 AT_REFERENCED(alt_return_tmp) = Referenced; 01424 AT_DEFINED(alt_return_tmp) = TRUE; 01425 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE; 01426 01427 NTR_IR_TBL(asg_idx); 01428 IR_OPR(asg_idx) = Alt_Return_Opr; 01429 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 01430 IR_LINE_NUM(asg_idx) = line; 01431 IR_COL_NUM(asg_idx) = col; 01432 IR_LINE_NUM_L(asg_idx) = line; 01433 IR_COL_NUM_L(asg_idx) = col; 01434 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 01435 IR_IDX_L(asg_idx) = alt_return_tmp; 01436 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 01437 IR_IDX_R(asg_idx) = ir_idx; 01438 01439 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 01440 01441 if (err_list_idx) { 01442 NTR_IR_TBL(br_true_idx); 01443 IR_OPR(br_true_idx) = Br_True_Opr; 01444 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE; 01445 IR_LINE_NUM(br_true_idx) = line; 01446 IR_COL_NUM(br_true_idx) = col; 01447 01448 NTR_IR_TBL(eq_idx); 01449 IR_OPR(eq_idx) = Eq_Opr; 01450 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE; 01451 IR_LINE_NUM(eq_idx) = line; 01452 IR_COL_NUM(eq_idx) = col; 01453 IR_FLD_L(eq_idx) = AT_Tbl_Idx; 01454 IR_IDX_L(eq_idx) = alt_return_tmp; 01455 IR_LINE_NUM_L(eq_idx) = line; 01456 IR_COL_NUM_L(eq_idx) = col; 01457 01458 IR_FLD_R(eq_idx) = CN_Tbl_Idx; 01459 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX; 01460 IR_LINE_NUM_R(eq_idx) = line; 01461 IR_COL_NUM_R(eq_idx) = col; 01462 01463 IR_FLD_L(br_true_idx) = IR_Tbl_Idx; 01464 IR_IDX_L(br_true_idx) = eq_idx; 01465 01466 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx)); 01467 01468 curr_stmt_sh_idx = save_next_sh_idx; 01469 01470 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 01471 01472 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx; 01473 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01474 01475 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 01476 } 01477 } 01478 # endif 01479 01480 if (semantically_correct) { 01481 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01482 semantically_correct = final_arg_work(&opnd, 01483 IR_IDX_L(ir_idx), 01484 IR_LIST_CNT_R(ir_idx), 01485 NULL); 01486 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01487 create_io_call_descriptor(ir_idx, Inquire_Desc); 01488 # if defined(_FILE_IO_OPRS) 01489 IR_OPR(ir_idx) = Inquire_Opr; 01490 # endif 01491 } 01492 01493 # ifdef _NO_IO_ALTERNATE_RETURN 01494 add_alt_return_lbl(ir_idx, err_attr_idx); 01495 # endif 01496 01497 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 01498 } 01499 else { 01500 01501 /* have IOLENGTH */ 01502 01503 NTR_IR_TBL(asg_idx); 01504 IR_OPR(asg_idx) = Asg_Opr; 01505 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 01506 IR_LINE_NUM(asg_idx) = IR_LINE_NUM(ir_idx); 01507 IR_COL_NUM(asg_idx) = IR_COL_NUM(ir_idx); 01508 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 01509 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 01510 IR_IDX_R(asg_idx) = ir_idx; 01511 01512 /* put in correct order for pgdcs */ 01513 01514 list_idx = IR_IDX_L(ir_idx); 01515 01516 /**********************\ 01517 |* iolength variable *| 01518 \**********************/ 01519 01520 01521 COPY_OPND(opnd, IL_OPND(list_idx)); 01522 exp_desc.rank = 0; 01523 xref_state = CIF_Symbol_Modification; 01524 semantically_correct = expr_semantics(&opnd, &exp_desc); 01525 COPY_OPND(IR_OPND_L(asg_idx), opnd); 01526 01527 01528 if (exp_desc.rank != 0 || 01529 !exp_desc.reference || 01530 exp_desc.type != Integer || 01531 exp_desc.linear_type != INTEGER_DEFAULT_TYPE) { 01532 01533 find_opnd_line_and_column(&opnd, &line, &col); 01534 PRINTMSG(line, 483, Error, col); 01535 semantically_correct = FALSE; 01536 } 01537 else if (! check_for_legal_define(&opnd)) { 01538 semantically_correct = FALSE; 01539 } 01540 else { 01541 01542 attr_idx = find_left_attr(&opnd); 01543 01544 /* create tmp for iolength */ 01545 01546 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 01547 ATD_TYPE_IDX(tmp_idx) = ATD_TYPE_IDX(attr_idx); 01548 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 01549 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 01550 01551 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 01552 IR_IDX_L(asg_idx) = tmp_idx; 01553 IR_LINE_NUM_L(asg_idx) = IR_LINE_NUM(ir_idx); 01554 IR_COL_NUM_L(asg_idx) = IR_COL_NUM(ir_idx); 01555 01556 01557 /* gen the assignment to the iolength variable */ 01558 01559 NTR_IR_TBL(asg_idx); 01560 IR_OPR(asg_idx) = Asg_Opr; 01561 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 01562 IR_LINE_NUM(asg_idx) = line; 01563 IR_COL_NUM(asg_idx) = col; 01564 01565 COPY_OPND(IR_OPND_L(asg_idx), opnd); 01566 IR_FLD_R(asg_idx) = AT_Tbl_Idx; 01567 IR_IDX_R(asg_idx) = tmp_idx; 01568 IR_LINE_NUM_R(asg_idx) = line; 01569 IR_COL_NUM_R(asg_idx) = col; 01570 01571 gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 01572 01573 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 01574 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 01575 01576 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 01577 01578 } 01579 01580 01581 /******************\ 01582 |* flflag value *| 01583 \******************/ 01584 01585 /* This is the flag for split io */ 01586 /* set to FL_IO_SINGLE for now */ 01587 01588 01589 IL_FLD(list_idx) = CN_Tbl_Idx; 01590 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, FL_IO_SINGLE); 01591 IL_LINE_NUM(list_idx) = line; 01592 IL_COL_NUM(list_idx) = col; 01593 01594 /*******************\ 01595 |* io list is next *| 01596 \*******************/ 01597 01598 defer_stmt_expansion = TRUE; 01599 number_of_functions = 0; 01600 io_stmt_must_be_split = FALSE; 01601 01602 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01603 semantically_correct = io_list_semantics(&opnd, Inquire) && 01604 semantically_correct; 01605 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01606 01607 defer_stmt_expansion = FALSE; 01608 01609 if (semantically_correct && 01610 (number_of_functions > 0 || 01611 tree_has_constructor || 01612 io_stmt_must_be_split || 01613 io_item_must_flatten)) { 01614 process_deferred_io_list(); 01615 } 01616 else if (semantically_correct) { 01617 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01618 gen_runtime_checks(&opnd); 01619 } 01620 } 01621 01622 /* restore arg_info_list to previous "stack frame" */ 01623 01624 arg_info_list_top = arg_info_list_base; 01625 arg_info_list_base = save_arg_info_list_base; 01626 01627 TRACE (Func_Exit, "inquire_stmt_semantics", NULL); 01628 01629 return; 01630 01631 } /* inquire_stmt_semantics */ 01632 01633 01634 /******************************************************************************\ 01635 |* *| 01636 |* Description: *| 01637 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 01638 |* *| 01639 |* Input parameters: *| 01640 |* NONE *| 01641 |* *| 01642 |* Output parameters: *| 01643 |* NONE *| 01644 |* *| 01645 |* Returns: *| 01646 |* NONE *| 01647 |* *| 01648 \******************************************************************************/ 01649 01650 void open_stmt_semantics (void) 01651 01652 { 01653 int ir_idx; 01654 opnd_type opnd; 01655 int save_arg_info_list_base; 01656 int save_curr_stmt_sh_idx; 01657 boolean semantically_correct; 01658 01659 # ifndef _NO_IO_ALTERNATE_RETURN 01660 int alt_return_tmp; 01661 int asg_idx; 01662 int br_true_idx; 01663 int col; 01664 int eq_idx; 01665 int line; 01666 int save_next_sh_idx; 01667 # endif 01668 01669 01670 TRACE (Func_Entry, "open_stmt_semantics", NULL); 01671 01672 SCP_DOES_IO(curr_scp_idx) = TRUE; 01673 01674 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 01675 01676 /* do memory management stuff to make sure the call tables are big enough */ 01677 01678 if (max_call_list_size >= arg_list_size) { 01679 enlarge_call_list_tables(); 01680 } 01681 01682 save_arg_info_list_base = arg_info_list_base; 01683 01684 arg_info_list_base = arg_info_list_top; 01685 01686 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx); 01687 01688 if (arg_info_list_top >= arg_info_list_size) { 01689 enlarge_info_list_table(); 01690 } 01691 01692 # ifndef _NO_IO_ALTERNATE_RETURN 01693 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 01694 # endif 01695 01696 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01697 semantically_correct = io_ctl_list_semantics(&opnd, Open, TRUE); 01698 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01699 01700 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 01701 01702 # ifndef _NO_IO_ALTERNATE_RETURN 01703 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) { 01704 01705 line = IR_LINE_NUM(ir_idx); 01706 col = IR_COL_NUM(ir_idx); 01707 01708 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE); 01709 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE; 01710 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx); 01711 AT_REFERENCED(alt_return_tmp) = Referenced; 01712 AT_DEFINED(alt_return_tmp) = TRUE; 01713 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE; 01714 01715 NTR_IR_TBL(asg_idx); 01716 IR_OPR(asg_idx) = Alt_Return_Opr; 01717 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 01718 IR_LINE_NUM(asg_idx) = line; 01719 IR_COL_NUM(asg_idx) = col; 01720 IR_LINE_NUM_L(asg_idx) = line; 01721 IR_COL_NUM_L(asg_idx) = col; 01722 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 01723 IR_IDX_L(asg_idx) = alt_return_tmp; 01724 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 01725 IR_IDX_R(asg_idx) = ir_idx; 01726 01727 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 01728 01729 if (err_list_idx) { 01730 NTR_IR_TBL(br_true_idx); 01731 IR_OPR(br_true_idx) = Br_True_Opr; 01732 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE; 01733 IR_LINE_NUM(br_true_idx) = line; 01734 IR_COL_NUM(br_true_idx) = col; 01735 01736 NTR_IR_TBL(eq_idx); 01737 IR_OPR(eq_idx) = Eq_Opr; 01738 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE; 01739 IR_LINE_NUM(eq_idx) = line; 01740 IR_COL_NUM(eq_idx) = col; 01741 IR_FLD_L(eq_idx) = AT_Tbl_Idx; 01742 IR_IDX_L(eq_idx) = alt_return_tmp; 01743 IR_LINE_NUM_L(eq_idx) = line; 01744 IR_COL_NUM_L(eq_idx) = col; 01745 01746 IR_FLD_R(eq_idx) = CN_Tbl_Idx; 01747 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX; 01748 IR_LINE_NUM_R(eq_idx) = line; 01749 IR_COL_NUM_R(eq_idx) = col; 01750 01751 IR_FLD_L(br_true_idx) = IR_Tbl_Idx; 01752 IR_IDX_L(br_true_idx) = eq_idx; 01753 01754 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx)); 01755 01756 curr_stmt_sh_idx = save_next_sh_idx; 01757 01758 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 01759 01760 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx; 01761 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01762 01763 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 01764 } 01765 } 01766 # endif 01767 01768 if (semantically_correct) { 01769 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01770 semantically_correct = final_arg_work(&opnd, 01771 IR_IDX_L(ir_idx), 01772 IR_LIST_CNT_R(ir_idx), 01773 NULL); 01774 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01775 create_io_call_descriptor(ir_idx, Open_Desc); 01776 # if defined(_FILE_IO_OPRS) 01777 IR_OPR(ir_idx) = Open_Opr; 01778 # endif 01779 } 01780 01781 # ifdef _NO_IO_ALTERNATE_RETURN 01782 add_alt_return_lbl(ir_idx, err_attr_idx); 01783 # endif 01784 01785 /* restore arg_info_list to previous "stack frame" */ 01786 01787 arg_info_list_top = arg_info_list_base; 01788 arg_info_list_base = save_arg_info_list_base; 01789 01790 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 01791 01792 TRACE (Func_Exit, "open_stmt_semantics", NULL); 01793 01794 return; 01795 01796 } /* open_stmt_semantics */ 01797 01798 01799 /******************************************************************************\ 01800 |* *| 01801 |* Description: *| 01802 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 01803 |* *| 01804 |* Input parameters: *| 01805 |* NONE *| 01806 |* *| 01807 |* Output parameters: *| 01808 |* NONE *| 01809 |* *| 01810 |* Returns: *| 01811 |* NONE *| 01812 |* *| 01813 \******************************************************************************/ 01814 01815 void print_stmt_semantics (void) 01816 01817 { 01818 int col; 01819 int ir_idx; 01820 int line; 01821 int list_idx; 01822 int loc_idx; 01823 opnd_type opnd; 01824 boolean semantically_correct; 01825 01826 01827 TRACE (Func_Entry, "print_stmt_semantics", NULL); 01828 01829 SCP_DOES_IO(curr_scp_idx) = TRUE; 01830 01831 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 01832 01833 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 01834 semantically_correct = io_ctl_list_semantics(&opnd, Print, FALSE); 01835 COPY_OPND(IR_OPND_L(ir_idx), opnd); 01836 01837 if (is_namelist) { 01838 01839 if (IR_FLD_R(ir_idx) == IL_Tbl_Idx) { 01840 find_opnd_line_and_column((opnd_type *) &IL_OPND(IR_IDX_R(ir_idx)), 01841 &line, 01842 &col); 01843 PRINTMSG(line, 444, Error, col); 01844 } 01845 01846 if (namelist_descriptor_attr) { 01847 01848 # if 0 01849 /* call the namelist table dump routine */ 01850 01851 {int _call_idx, _list_idx, _loc_idx; 01852 int _dump_nml_idx; 01853 _dump_nml_idx = create_lib_entry_attr("DUMP_NML", 01854 8, 01855 stmt_start_line, 01856 stmt_start_col); 01857 01858 ADD_ATTR_TO_LOCAL_LIST(_dump_nml_idx); 01859 01860 NTR_IR_TBL(_call_idx); 01861 IR_OPR(_call_idx) = Call_Opr; 01862 IR_TYPE_IDX(_call_idx) = CG_INTEGER_DEFAULT_TYPE; 01863 IR_LINE_NUM(_call_idx) = stmt_start_line; 01864 IR_COL_NUM(_call_idx) = stmt_start_col; 01865 IR_FLD_L(_call_idx) = AT_Tbl_Idx; 01866 IR_IDX_L(_call_idx) = _dump_nml_idx; 01867 IR_LINE_NUM_L(_call_idx) = stmt_start_line; 01868 IR_COL_NUM_L(_call_idx) = stmt_start_col; 01869 01870 NTR_IR_LIST_TBL(_list_idx); 01871 IR_FLD_R(_call_idx) = IL_Tbl_Idx; 01872 IR_IDX_R(_call_idx) = _list_idx; 01873 IR_LIST_CNT_R(_call_idx) = 1; 01874 01875 NTR_IR_TBL(_loc_idx); 01876 IR_OPR(_loc_idx) = Aloc_Opr; 01877 IR_TYPE_IDX(_loc_idx) = CRI_Ptr_8; 01878 IR_LINE_NUM(_loc_idx) = stmt_start_line; 01879 IR_COL_NUM(_loc_idx) = stmt_start_col; 01880 IL_FLD(_list_idx) = IR_Tbl_Idx; 01881 IL_IDX(_list_idx) = _loc_idx; 01882 01883 IR_FLD_L(_loc_idx) = AT_Tbl_Idx; 01884 IR_IDX_L(_loc_idx) = namelist_descriptor_attr; 01885 IR_LINE_NUM_L(_loc_idx) = stmt_start_line; 01886 IR_COL_NUM_L(_loc_idx) = stmt_start_col; 01887 01888 gen_sh(Before, Call_Stmt, stmt_start_line, 01889 stmt_start_col, FALSE, FALSE, TRUE); 01890 01891 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = _call_idx; 01892 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 01893 } 01894 01895 # endif 01896 NTR_IR_LIST_TBL(list_idx); 01897 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 01898 IR_LIST_CNT_R(ir_idx) = 1; 01899 IR_IDX_R(ir_idx) = list_idx; 01900 NTR_IR_TBL(loc_idx); 01901 IR_OPR(loc_idx) = Loc_Opr; 01902 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 01903 IR_LINE_NUM(loc_idx) = stmt_start_line; 01904 IR_COL_NUM(loc_idx) = stmt_start_col; 01905 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 01906 IR_IDX_L(loc_idx) = namelist_descriptor_attr; 01907 IR_LINE_NUM_L(loc_idx) = stmt_start_line; 01908 IR_COL_NUM_L(loc_idx) = stmt_start_col; 01909 IL_FLD(list_idx) = IR_Tbl_Idx; 01910 IL_IDX(list_idx) = loc_idx; 01911 } 01912 } 01913 else { 01914 defer_stmt_expansion = TRUE; 01915 number_of_functions = 0; 01916 io_stmt_must_be_split = FALSE; 01917 01918 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01919 semantically_correct = io_list_semantics(&opnd, Print) && 01920 semantically_correct; 01921 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01922 01923 defer_stmt_expansion = FALSE; 01924 01925 if (semantically_correct && 01926 (number_of_functions > 0 || 01927 tree_has_constructor || 01928 io_stmt_must_be_split || 01929 io_item_must_flatten)) { 01930 process_deferred_io_list(); 01931 } 01932 else if (semantically_correct) { 01933 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 01934 gen_runtime_checks(&opnd); 01935 } 01936 } 01937 01938 TRACE (Func_Exit, "print_stmt_semantics", NULL); 01939 01940 return; 01941 01942 } /* print_stmt_semantics */ 01943 01944 01945 /******************************************************************************\ 01946 |* *| 01947 |* Description: *| 01948 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 01949 |* *| 01950 |* Input parameters: *| 01951 |* NONE *| 01952 |* *| 01953 |* Output parameters: *| 01954 |* NONE *| 01955 |* *| 01956 |* Returns: *| 01957 |* NONE *| 01958 |* *| 01959 \******************************************************************************/ 01960 01961 void read_stmt_semantics (void) 01962 01963 { 01964 int col; 01965 int ir_idx; 01966 int line; 01967 int list_idx; 01968 int loc_idx; 01969 opnd_type opnd; 01970 boolean semantically_correct; 01971 01972 # ifndef _NO_IO_ALTERNATE_RETURN 01973 int alt_return_tmp; 01974 int asg_idx; 01975 int br_idx_idx = NULL_IDX; 01976 int br_true_idx; 01977 int drop_thru_label_idx; 01978 int jump_out_label; 01979 int lab_idx; 01980 int ne_idx; 01981 int save_next_sh_idx; 01982 int save_curr_stmt_sh_idx; 01983 # endif 01984 01985 01986 TRACE (Func_Entry, "read_stmt_semantics", NULL); 01987 01988 SCP_DOES_IO(curr_scp_idx) = TRUE; 01989 01990 # ifndef _NO_IO_ALTERNATE_RETURN 01991 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 01992 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 01993 # endif 01994 01995 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 01996 01997 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 01998 semantically_correct = io_ctl_list_semantics(&opnd, Read, FALSE); 01999 COPY_OPND(IR_OPND_L(ir_idx), opnd); 02000 02001 line = IR_LINE_NUM(ir_idx); 02002 col = IR_COL_NUM(ir_idx); 02003 02004 # ifndef _NO_IO_ALTERNATE_RETURN 02005 if (have_iostat || 02006 end_list_idx != NULL_IDX || 02007 err_list_idx != NULL_IDX || 02008 eor_list_idx != NULL_IDX) { 02009 02010 if (end_list_idx == NULL_IDX || 02011 err_list_idx == NULL_IDX || 02012 eor_list_idx == NULL_IDX) { 02013 02014 /* generate a label for drop through branch */ 02015 02016 drop_thru_label_idx = gen_internal_lbl(stmt_start_line); 02017 02018 curr_stmt_sh_idx = save_next_sh_idx; 02019 02020 gen_sh(Before, Continue_Stmt, line, col, FALSE, TRUE, TRUE); 02021 02022 NTR_IR_TBL(lab_idx); 02023 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = lab_idx; 02024 IR_OPR(lab_idx) = Label_Opr; 02025 IR_TYPE_IDX(lab_idx) = TYPELESS_DEFAULT_TYPE; 02026 IR_LINE_NUM(lab_idx) = line; 02027 IR_COL_NUM(lab_idx) = col; 02028 IR_FLD_L(lab_idx) = AT_Tbl_Idx; 02029 IR_IDX_L(lab_idx) = drop_thru_label_idx; 02030 IR_COL_NUM_L(lab_idx) = col; 02031 IR_LINE_NUM_L(lab_idx) = line; 02032 02033 AT_DEFINED(drop_thru_label_idx) = TRUE; 02034 ATL_DEF_STMT_IDX(drop_thru_label_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 02035 02036 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02037 save_next_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02038 02039 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 02040 } 02041 02042 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE); 02043 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE; 02044 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx); 02045 AT_REFERENCED(alt_return_tmp) = Referenced; 02046 AT_DEFINED(alt_return_tmp) = TRUE; 02047 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE; 02048 02049 NTR_IR_TBL(asg_idx); 02050 IR_OPR(asg_idx) = Alt_Return_Opr; 02051 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 02052 IR_LINE_NUM(asg_idx) = line; 02053 IR_COL_NUM(asg_idx) = col; 02054 IR_LINE_NUM_L(asg_idx) = line; 02055 IR_COL_NUM_L(asg_idx) = col; 02056 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 02057 IR_IDX_L(asg_idx) = alt_return_tmp; 02058 02059 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 02060 IR_IDX_R(asg_idx) = ir_idx; 02061 02062 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 02063 02064 NTR_IR_TBL(br_idx_idx); 02065 IR_OPR(br_idx_idx) = Br_Index_Opr; 02066 IR_TYPE_IDX(br_idx_idx) = CG_INTEGER_DEFAULT_TYPE; 02067 02068 IR_FLD_L(br_idx_idx) = AT_Tbl_Idx; 02069 IR_IDX_L(br_idx_idx) = alt_return_tmp; 02070 IR_LINE_NUM(br_idx_idx) = line; 02071 IR_COL_NUM(br_idx_idx) = col; 02072 IR_LINE_NUM_L(br_idx_idx) = line; 02073 IR_COL_NUM_L(br_idx_idx) = col; 02074 IR_FLD_R(br_idx_idx) = IL_Tbl_Idx; 02075 IR_LIST_CNT_R(br_idx_idx) = 3; 02076 02077 NTR_IR_LIST_TBL(list_idx); 02078 IR_IDX_R(br_idx_idx) = list_idx; 02079 02080 if (err_list_idx) { 02081 COPY_OPND(IL_OPND(list_idx), IL_OPND(err_list_idx)); 02082 } 02083 else { 02084 IL_FLD(list_idx) = AT_Tbl_Idx; 02085 IL_IDX(list_idx) = drop_thru_label_idx; 02086 IL_LINE_NUM(list_idx) = line; 02087 IL_COL_NUM(list_idx) = col; 02088 } 02089 02090 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02091 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 02092 list_idx = IL_NEXT_LIST_IDX(list_idx); 02093 02094 if (end_list_idx) { 02095 COPY_OPND(IL_OPND(list_idx), IL_OPND(end_list_idx)); 02096 } 02097 else { 02098 IL_FLD(list_idx) = AT_Tbl_Idx; 02099 IL_IDX(list_idx) = drop_thru_label_idx; 02100 IL_LINE_NUM(list_idx) = line; 02101 IL_COL_NUM(list_idx) = col; 02102 } 02103 02104 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02105 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 02106 list_idx = IL_NEXT_LIST_IDX(list_idx); 02107 02108 if (eor_list_idx) { 02109 COPY_OPND(IL_OPND(list_idx), IL_OPND(eor_list_idx)); 02110 } 02111 else { 02112 IL_FLD(list_idx) = AT_Tbl_Idx; 02113 IL_IDX(list_idx) = drop_thru_label_idx; 02114 IL_LINE_NUM(list_idx) = line; 02115 IL_COL_NUM(list_idx) = col; 02116 } 02117 02118 curr_stmt_sh_idx = save_next_sh_idx; 02119 02120 gen_sh(Before, If_Stmt, line, col, FALSE, TRUE, TRUE); 02121 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02122 SH_IR_IDX(curr_stmt_sh_idx) = br_idx_idx; 02123 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02124 02125 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 02126 02127 } 02128 # endif 02129 02130 if (is_namelist) { 02131 02132 if (IR_FLD_R(ir_idx) == IL_Tbl_Idx) { 02133 find_opnd_line_and_column((opnd_type *) &IL_OPND(IR_IDX_R(ir_idx)), 02134 &line, 02135 &col); 02136 PRINTMSG(line, 444, Error, col); 02137 } 02138 02139 if (namelist_descriptor_attr) { 02140 # if 0 02141 /* call the namelist table dump routine */ 02142 02143 {int _call_idx, _list_idx, _loc_idx; 02144 int _dump_nml_idx; 02145 _dump_nml_idx = create_lib_entry_attr("DUMP_NML", 02146 8, 02147 stmt_start_line, 02148 stmt_start_col); 02149 02150 ADD_ATTR_TO_LOCAL_LIST(_dump_nml_idx); 02151 02152 NTR_IR_TBL(_call_idx); 02153 IR_OPR(_call_idx) = Call_Opr; 02154 IR_TYPE_IDX(_call_idx) = CG_INTEGER_DEFAULT_TYPE; 02155 IR_LINE_NUM(_call_idx) = stmt_start_line; 02156 IR_COL_NUM(_call_idx) = stmt_start_col; 02157 IR_FLD_L(_call_idx) = AT_Tbl_Idx; 02158 IR_IDX_L(_call_idx) = _dump_nml_idx; 02159 IR_LINE_NUM_L(_call_idx) = stmt_start_line; 02160 IR_COL_NUM_L(_call_idx) = stmt_start_col; 02161 02162 NTR_IR_LIST_TBL(_list_idx); 02163 IR_FLD_R(_call_idx) = IL_Tbl_Idx; 02164 IR_IDX_R(_call_idx) = _list_idx; 02165 IR_LIST_CNT_R(_call_idx) = 1; 02166 02167 NTR_IR_TBL(_loc_idx); 02168 IR_OPR(_loc_idx) = Aloc_Opr; 02169 IR_TYPE_IDX(_loc_idx) = CRI_Ptr_8; 02170 IR_LINE_NUM(_loc_idx) = stmt_start_line; 02171 IR_COL_NUM(_loc_idx) = stmt_start_col; 02172 IL_FLD(_list_idx) = IR_Tbl_Idx; 02173 IL_IDX(_list_idx) = _loc_idx; 02174 02175 IR_FLD_L(_loc_idx) = AT_Tbl_Idx; 02176 IR_IDX_L(_loc_idx) = namelist_descriptor_attr; 02177 IR_LINE_NUM_L(_loc_idx) = stmt_start_line; 02178 IR_COL_NUM_L(_loc_idx) = stmt_start_col; 02179 02180 gen_sh(Before, Call_Stmt, stmt_start_line, 02181 stmt_start_col, FALSE, FALSE, TRUE); 02182 02183 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = _call_idx; 02184 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02185 } 02186 02187 # endif 02188 02189 NTR_IR_LIST_TBL(list_idx); 02190 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 02191 IR_LIST_CNT_R(ir_idx) = 1; 02192 IR_IDX_R(ir_idx) = list_idx; 02193 NTR_IR_TBL(loc_idx); 02194 IR_OPR(loc_idx) = Loc_Opr; 02195 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 02196 IR_LINE_NUM(loc_idx) = stmt_start_line; 02197 IR_COL_NUM(loc_idx) = stmt_start_col; 02198 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 02199 IR_IDX_L(loc_idx) = namelist_descriptor_attr; 02200 IR_LINE_NUM_L(loc_idx) = stmt_start_line; 02201 IR_COL_NUM_L(loc_idx) = stmt_start_col; 02202 IL_FLD(list_idx) = IR_Tbl_Idx; 02203 IL_IDX(list_idx) = loc_idx; 02204 } 02205 } 02206 else { 02207 defer_stmt_expansion = TRUE; 02208 number_of_functions = 0; 02209 io_stmt_must_be_split = FALSE; 02210 02211 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 02212 semantically_correct = io_list_semantics(&opnd, Read) && 02213 semantically_correct; 02214 COPY_OPND(IR_OPND_R(ir_idx), opnd); 02215 02216 defer_stmt_expansion = FALSE; 02217 02218 # ifndef _NO_IO_ALTERNATE_RETURN 02219 if (semantically_correct && 02220 io_stmt_must_be_split && 02221 br_idx_idx != NULL_IDX) { 02222 02223 /* we have to split the io and we had an alternate return */ 02224 /* so generate the jump out label and the branch true */ 02225 02226 jump_out_label = gen_internal_lbl(stmt_start_line); 02227 02228 gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 02229 02230 NTR_IR_TBL(lab_idx); 02231 SH_IR_IDX(curr_stmt_sh_idx) = lab_idx; 02232 IR_OPR(lab_idx) = Label_Opr; 02233 IR_TYPE_IDX(lab_idx) = TYPELESS_DEFAULT_TYPE; 02234 IR_LINE_NUM(lab_idx) = line; 02235 IR_COL_NUM(lab_idx) = col; 02236 IR_FLD_L(lab_idx) = AT_Tbl_Idx; 02237 IR_IDX_L(lab_idx) = jump_out_label; 02238 IR_COL_NUM_L(lab_idx) = col; 02239 IR_LINE_NUM_L(lab_idx) = line; 02240 AT_DEFINED(jump_out_label) = TRUE; 02241 SH_IR_IDX(curr_stmt_sh_idx) = lab_idx; 02242 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02243 ATL_DEF_STMT_IDX(jump_out_label) = curr_stmt_sh_idx; 02244 02245 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02246 02247 NTR_IR_TBL(br_true_idx); 02248 IR_OPR(br_true_idx) = Br_True_Opr; 02249 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE; 02250 IR_LINE_NUM(br_true_idx) = line; 02251 IR_COL_NUM(br_true_idx) = col; 02252 02253 NTR_IR_TBL(ne_idx); 02254 IR_OPR(ne_idx) = Ne_Opr; 02255 IR_TYPE_IDX(ne_idx) = LOGICAL_DEFAULT_TYPE; 02256 IR_LINE_NUM(ne_idx) = line; 02257 IR_COL_NUM(ne_idx) = col; 02258 IR_FLD_L(ne_idx) = AT_Tbl_Idx; 02259 IR_IDX_L(ne_idx) = alt_return_tmp; 02260 IR_LINE_NUM_L(ne_idx) = line; 02261 IR_COL_NUM_L(ne_idx) = col; 02262 02263 IR_FLD_R(ne_idx) = CN_Tbl_Idx; 02264 IR_IDX_R(ne_idx) = CN_INTEGER_ZERO_IDX; 02265 IR_LINE_NUM_R(ne_idx) = line; 02266 IR_COL_NUM_R(ne_idx) = col; 02267 02268 IR_FLD_L(br_true_idx) = IR_Tbl_Idx; 02269 IR_IDX_L(br_true_idx) = ne_idx; 02270 02271 IR_FLD_R(br_true_idx) = AT_Tbl_Idx; 02272 IR_IDX_R(br_true_idx) = jump_out_label; 02273 IR_LINE_NUM_R(br_true_idx) = line; 02274 IR_COL_NUM_R(br_true_idx) = col; 02275 02276 gen_sh(After, If_Stmt, line, col, FALSE, FALSE, TRUE); 02277 02278 SH_IR_IDX(curr_stmt_sh_idx) = br_true_idx; 02279 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02280 02281 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02282 02283 } 02284 # endif 02285 02286 if (semantically_correct && 02287 (number_of_functions > 0 || 02288 tree_has_constructor || 02289 io_stmt_must_be_split || 02290 io_item_must_flatten)) { 02291 process_deferred_io_list(); 02292 } 02293 else if (semantically_correct) { 02294 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 02295 gen_runtime_checks(&opnd); 02296 } 02297 } 02298 02299 TRACE (Func_Exit, "read_stmt_semantics", NULL); 02300 02301 return; 02302 02303 } /* read_stmt_semantics */ 02304 02305 02306 /******************************************************************************\ 02307 |* *| 02308 |* Description: *| 02309 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 02310 |* *| 02311 |* Input parameters: *| 02312 |* NONE *| 02313 |* *| 02314 |* Output parameters: *| 02315 |* NONE *| 02316 |* *| 02317 |* Returns: *| 02318 |* NONE *| 02319 |* *| 02320 \******************************************************************************/ 02321 02322 void rewind_stmt_semantics (void) 02323 02324 { 02325 int ir_idx; 02326 opnd_type opnd; 02327 int save_arg_info_list_base; 02328 int save_curr_stmt_sh_idx; 02329 boolean semantically_correct; 02330 02331 # ifndef _NO_IO_ALTERNATE_RETURN 02332 int alt_return_tmp; 02333 int asg_idx; 02334 int br_true_idx; 02335 int col; 02336 int eq_idx; 02337 int line; 02338 int save_next_sh_idx; 02339 # endif 02340 02341 02342 TRACE (Func_Entry, "rewind_stmt_semantics", NULL); 02343 02344 SCP_DOES_IO(curr_scp_idx) = TRUE; 02345 02346 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 02347 02348 /* do memory management stuff to make sure the call tables are big enough */ 02349 02350 if (max_call_list_size >= arg_list_size) { 02351 enlarge_call_list_tables(); 02352 } 02353 02354 save_arg_info_list_base = arg_info_list_base; 02355 02356 arg_info_list_base = arg_info_list_top; 02357 02358 arg_info_list_top = arg_info_list_base + IR_LIST_CNT_R(ir_idx); 02359 02360 if (arg_info_list_top >= arg_info_list_size) { 02361 enlarge_info_list_table(); 02362 } 02363 02364 # ifndef _NO_IO_ALTERNATE_RETURN 02365 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 02366 # endif 02367 02368 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 02369 semantically_correct = io_ctl_list_semantics(&opnd, Rewind, TRUE); 02370 COPY_OPND(IR_OPND_R(ir_idx), opnd); 02371 02372 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 02373 02374 # ifndef _NO_IO_ALTERNATE_RETURN 02375 02376 if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) { 02377 02378 line = IR_LINE_NUM(ir_idx); 02379 col = IR_COL_NUM(ir_idx); 02380 02381 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE); 02382 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE; 02383 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx); 02384 AT_REFERENCED(alt_return_tmp) = Referenced; 02385 AT_DEFINED(alt_return_tmp) = TRUE; 02386 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE; 02387 02388 NTR_IR_TBL(asg_idx); 02389 IR_OPR(asg_idx) = Alt_Return_Opr; 02390 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 02391 IR_LINE_NUM(asg_idx) = line; 02392 IR_COL_NUM(asg_idx) = col; 02393 IR_LINE_NUM_L(asg_idx) = line; 02394 IR_COL_NUM_L(asg_idx) = col; 02395 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 02396 IR_IDX_L(asg_idx) = alt_return_tmp; 02397 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 02398 IR_IDX_R(asg_idx) = ir_idx; 02399 02400 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 02401 02402 if (err_list_idx) { 02403 NTR_IR_TBL(br_true_idx); 02404 IR_OPR(br_true_idx) = Br_True_Opr; 02405 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE; 02406 IR_LINE_NUM(br_true_idx) = line; 02407 IR_COL_NUM(br_true_idx) = col; 02408 02409 NTR_IR_TBL(eq_idx); 02410 IR_OPR(eq_idx) = Eq_Opr; 02411 IR_TYPE_IDX(eq_idx) = LOGICAL_DEFAULT_TYPE; 02412 IR_LINE_NUM(eq_idx) = line; 02413 IR_COL_NUM(eq_idx) = col; 02414 IR_FLD_L(eq_idx) = AT_Tbl_Idx; 02415 IR_IDX_L(eq_idx) = alt_return_tmp; 02416 IR_LINE_NUM_L(eq_idx) = line; 02417 IR_COL_NUM_L(eq_idx) = col; 02418 02419 IR_FLD_R(eq_idx) = CN_Tbl_Idx; 02420 IR_IDX_R(eq_idx) = CN_INTEGER_ONE_IDX; 02421 IR_LINE_NUM_R(eq_idx) = line; 02422 IR_COL_NUM_R(eq_idx) = col; 02423 02424 IR_FLD_L(br_true_idx) = IR_Tbl_Idx; 02425 IR_IDX_L(br_true_idx) = eq_idx; 02426 02427 COPY_OPND(IR_OPND_R(br_true_idx), IL_OPND(err_list_idx)); 02428 02429 curr_stmt_sh_idx = save_next_sh_idx; 02430 02431 gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE); 02432 02433 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = br_true_idx; 02434 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02435 02436 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 02437 } 02438 } 02439 # endif 02440 02441 if (semantically_correct) { 02442 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 02443 semantically_correct = final_arg_work(&opnd, 02444 IR_IDX_L(ir_idx), 02445 IR_LIST_CNT_R(ir_idx), 02446 NULL); 02447 COPY_OPND(IR_OPND_R(ir_idx), opnd); 02448 # if defined(_FILE_IO_OPRS) 02449 IR_OPR(ir_idx) = Rewind_Opr; 02450 # endif 02451 } 02452 02453 # ifdef _NO_IO_ALTERNATE_RETURN 02454 add_alt_return_lbl(ir_idx, err_attr_idx); 02455 # endif 02456 02457 /* restore arg_info_list to previous "stack frame" */ 02458 02459 arg_info_list_top = arg_info_list_base; 02460 arg_info_list_base = save_arg_info_list_base; 02461 02462 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 02463 02464 TRACE (Func_Exit, "rewind_stmt_semantics", NULL); 02465 02466 return; 02467 02468 } /* rewind_stmt_semantics */ 02469 02470 02471 /******************************************************************************\ 02472 |* *| 02473 |* Description: *| 02474 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 02475 |* *| 02476 |* Input parameters: *| 02477 |* NONE *| 02478 |* *| 02479 |* Output parameters: *| 02480 |* NONE *| 02481 |* *| 02482 |* Returns: *| 02483 |* NONE *| 02484 |* *| 02485 \******************************************************************************/ 02486 02487 void write_stmt_semantics (void) 02488 02489 { 02490 int col; 02491 int ir_idx; 02492 int line; 02493 int list_idx; 02494 int loc_idx; 02495 opnd_type opnd; 02496 boolean semantically_correct; 02497 02498 # ifndef _NO_IO_ALTERNATE_RETURN 02499 int alt_return_tmp; 02500 int asg_idx; 02501 int br_idx_idx = NULL_IDX; 02502 int br_true_idx; 02503 int drop_thru_label_idx; 02504 int jump_out_label; 02505 int lab_idx; 02506 int ne_idx; 02507 int save_curr_stmt_sh_idx; 02508 int save_next_sh_idx; 02509 # endif 02510 02511 02512 TRACE (Func_Entry, "write_stmt_semantics", NULL); 02513 02514 SCP_DOES_IO(curr_scp_idx) = TRUE; 02515 02516 # ifndef _NO_IO_ALTERNATE_RETURN 02517 save_next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 02518 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 02519 # endif 02520 02521 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 02522 line = IR_LINE_NUM(ir_idx); 02523 02524 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 02525 semantically_correct = io_ctl_list_semantics(&opnd, Write, FALSE); 02526 COPY_OPND(IR_OPND_L(ir_idx), opnd); 02527 02528 line = IR_LINE_NUM(ir_idx); 02529 col = IR_COL_NUM(ir_idx); 02530 02531 # ifndef _NO_IO_ALTERNATE_RETURN 02532 if (have_iostat || 02533 end_list_idx != NULL_IDX || 02534 err_list_idx != NULL_IDX || 02535 eor_list_idx != NULL_IDX) { 02536 02537 if (end_list_idx == NULL_IDX || 02538 err_list_idx == NULL_IDX || 02539 eor_list_idx == NULL_IDX) { 02540 02541 /* generate a label for drop through branch */ 02542 02543 drop_thru_label_idx = gen_internal_lbl(stmt_start_line); 02544 02545 curr_stmt_sh_idx = save_next_sh_idx; 02546 02547 gen_sh(Before, Continue_Stmt, line, col, FALSE, TRUE, TRUE); 02548 02549 NTR_IR_TBL(lab_idx); 02550 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = lab_idx; 02551 IR_OPR(lab_idx) = Label_Opr; 02552 IR_TYPE_IDX(lab_idx) = TYPELESS_DEFAULT_TYPE; 02553 IR_LINE_NUM(lab_idx) = line; 02554 IR_COL_NUM(lab_idx) = col; 02555 IR_FLD_L(lab_idx) = AT_Tbl_Idx; 02556 IR_IDX_L(lab_idx) = drop_thru_label_idx; 02557 IR_COL_NUM_L(lab_idx) = col; 02558 IR_LINE_NUM_L(lab_idx) = line; 02559 02560 AT_DEFINED(drop_thru_label_idx) = TRUE; 02561 ATL_DEF_STMT_IDX(drop_thru_label_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 02562 02563 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02564 save_next_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02565 02566 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 02567 } 02568 02569 alt_return_tmp = gen_compiler_tmp(1, 0, Priv, TRUE); 02570 ATD_TYPE_IDX(alt_return_tmp) = CG_INTEGER_DEFAULT_TYPE; 02571 ATD_STOR_BLK_IDX(alt_return_tmp) = SCP_SB_STACK_IDX(curr_scp_idx); 02572 AT_REFERENCED(alt_return_tmp) = Referenced; 02573 AT_DEFINED(alt_return_tmp) = TRUE; 02574 AT_SEMANTICS_DONE(alt_return_tmp) = TRUE; 02575 02576 NTR_IR_TBL(asg_idx); 02577 IR_OPR(asg_idx) = Alt_Return_Opr; 02578 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 02579 IR_LINE_NUM(asg_idx) = line; 02580 IR_COL_NUM(asg_idx) = col; 02581 IR_LINE_NUM_L(asg_idx) = line; 02582 IR_COL_NUM_L(asg_idx) = col; 02583 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 02584 IR_IDX_L(asg_idx) = alt_return_tmp; 02585 02586 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 02587 IR_IDX_R(asg_idx) = ir_idx; 02588 02589 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 02590 02591 NTR_IR_TBL(br_idx_idx); 02592 IR_OPR(br_idx_idx) = Br_Index_Opr; 02593 IR_TYPE_IDX(br_idx_idx) = CG_INTEGER_DEFAULT_TYPE; 02594 02595 IR_FLD_L(br_idx_idx) = AT_Tbl_Idx; 02596 IR_IDX_L(br_idx_idx) = alt_return_tmp; 02597 IR_LINE_NUM(br_idx_idx) = line; 02598 IR_COL_NUM(br_idx_idx) = col; 02599 IR_LINE_NUM_L(br_idx_idx) = line; 02600 IR_COL_NUM_L(br_idx_idx) = col; 02601 IR_FLD_R(br_idx_idx) = IL_Tbl_Idx; 02602 IR_LIST_CNT_R(br_idx_idx) = 3; 02603 02604 NTR_IR_LIST_TBL(list_idx); 02605 IR_IDX_R(br_idx_idx) = list_idx; 02606 02607 if (err_list_idx) { 02608 COPY_OPND(IL_OPND(list_idx), IL_OPND(err_list_idx)); 02609 } 02610 else { 02611 IL_FLD(list_idx) = AT_Tbl_Idx; 02612 IL_IDX(list_idx) = drop_thru_label_idx; 02613 IL_LINE_NUM(list_idx) = line; 02614 IL_COL_NUM(list_idx) = col; 02615 } 02616 02617 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02618 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 02619 list_idx = IL_NEXT_LIST_IDX(list_idx); 02620 02621 if (end_list_idx) { 02622 COPY_OPND(IL_OPND(list_idx), IL_OPND(end_list_idx)); 02623 } 02624 else { 02625 IL_FLD(list_idx) = AT_Tbl_Idx; 02626 IL_IDX(list_idx) = drop_thru_label_idx; 02627 IL_LINE_NUM(list_idx) = line; 02628 IL_COL_NUM(list_idx) = col; 02629 } 02630 02631 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02632 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 02633 list_idx = IL_NEXT_LIST_IDX(list_idx); 02634 02635 if (eor_list_idx) { 02636 COPY_OPND(IL_OPND(list_idx), IL_OPND(eor_list_idx)); 02637 } 02638 else { 02639 IL_FLD(list_idx) = AT_Tbl_Idx; 02640 IL_IDX(list_idx) = drop_thru_label_idx; 02641 IL_LINE_NUM(list_idx) = line; 02642 IL_COL_NUM(list_idx) = col; 02643 } 02644 02645 curr_stmt_sh_idx = save_next_sh_idx; 02646 02647 gen_sh(Before, If_Stmt, line, col, FALSE, TRUE, TRUE); 02648 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02649 SH_IR_IDX(curr_stmt_sh_idx) = br_idx_idx; 02650 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02651 02652 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 02653 02654 } 02655 # endif 02656 02657 if (is_namelist) { 02658 02659 if (IR_FLD_R(ir_idx) == IL_Tbl_Idx) { 02660 find_opnd_line_and_column((opnd_type *) &IL_OPND(IR_IDX_R(ir_idx)), 02661 &line, 02662 &col); 02663 PRINTMSG(line, 444, Error, col); 02664 } 02665 02666 if (namelist_descriptor_attr) { 02667 # if 0 02668 /* call the namelist table dump routine */ 02669 02670 {int _call_idx, _list_idx, _loc_idx; 02671 int _dump_nml_idx; 02672 _dump_nml_idx = create_lib_entry_attr("DUMP_NML", 02673 8, 02674 stmt_start_line, 02675 stmt_start_col); 02676 02677 ADD_ATTR_TO_LOCAL_LIST(_dump_nml_idx); 02678 02679 NTR_IR_TBL(_call_idx); 02680 IR_OPR(_call_idx) = Call_Opr; 02681 IR_TYPE_IDX(_call_idx) = CG_INTEGER_DEFAULT_TYPE; 02682 IR_LINE_NUM(_call_idx) = stmt_start_line; 02683 IR_COL_NUM(_call_idx) = stmt_start_col; 02684 IR_FLD_L(_call_idx) = AT_Tbl_Idx; 02685 IR_IDX_L(_call_idx) = _dump_nml_idx; 02686 IR_LINE_NUM_L(_call_idx) = stmt_start_line; 02687 IR_COL_NUM_L(_call_idx) = stmt_start_col; 02688 02689 NTR_IR_LIST_TBL(_list_idx); 02690 IR_FLD_R(_call_idx) = IL_Tbl_Idx; 02691 IR_IDX_R(_call_idx) = _list_idx; 02692 IR_LIST_CNT_R(_call_idx) = 1; 02693 02694 NTR_IR_TBL(_loc_idx); 02695 IR_OPR(_loc_idx) = Aloc_Opr; 02696 IR_TYPE_IDX(_loc_idx) = CRI_Ptr_8; 02697 IR_LINE_NUM(_loc_idx) = stmt_start_line; 02698 IR_COL_NUM(_loc_idx) = stmt_start_col; 02699 IL_FLD(_list_idx) = IR_Tbl_Idx; 02700 IL_IDX(_list_idx) = _loc_idx; 02701 02702 IR_FLD_L(_loc_idx) = AT_Tbl_Idx; 02703 IR_IDX_L(_loc_idx) = namelist_descriptor_attr; 02704 IR_LINE_NUM_L(_loc_idx) = stmt_start_line; 02705 IR_COL_NUM_L(_loc_idx) = stmt_start_col; 02706 02707 gen_sh(Before, Call_Stmt, stmt_start_line, 02708 stmt_start_col, FALSE, FALSE, TRUE); 02709 02710 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = _call_idx; 02711 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02712 } 02713 02714 # endif 02715 02716 NTR_IR_LIST_TBL(list_idx); 02717 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 02718 IR_LIST_CNT_R(ir_idx) = 1; 02719 IR_IDX_R(ir_idx) = list_idx; 02720 NTR_IR_TBL(loc_idx); 02721 IR_OPR(loc_idx) = Loc_Opr; 02722 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 02723 IR_LINE_NUM(loc_idx) = stmt_start_line; 02724 IR_COL_NUM(loc_idx) = stmt_start_col; 02725 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 02726 IR_IDX_L(loc_idx) = namelist_descriptor_attr; 02727 IR_LINE_NUM_L(loc_idx) = stmt_start_line; 02728 IR_COL_NUM_L(loc_idx) = stmt_start_col; 02729 IL_FLD(list_idx) = IR_Tbl_Idx; 02730 IL_IDX(list_idx) = loc_idx; 02731 } 02732 } 02733 else { 02734 defer_stmt_expansion = TRUE; 02735 number_of_functions = 0; 02736 io_stmt_must_be_split = FALSE; 02737 02738 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 02739 semantically_correct = io_list_semantics(&opnd, Write) && 02740 semantically_correct; 02741 COPY_OPND(IR_OPND_R(ir_idx), opnd); 02742 02743 defer_stmt_expansion = FALSE; 02744 02745 # ifndef _NO_IO_ALTERNATE_RETURN 02746 if (semantically_correct && 02747 io_stmt_must_be_split && 02748 br_idx_idx != NULL_IDX) { 02749 02750 /* we have to split the io and we had an alternate return */ 02751 /* so generate the jump out label and the branch true */ 02752 02753 jump_out_label = gen_internal_lbl(stmt_start_line); 02754 02755 gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE); 02756 02757 NTR_IR_TBL(lab_idx); 02758 SH_IR_IDX(curr_stmt_sh_idx) = lab_idx; 02759 IR_OPR(lab_idx) = Label_Opr; 02760 IR_TYPE_IDX(lab_idx) = TYPELESS_DEFAULT_TYPE; 02761 IR_LINE_NUM(lab_idx) = line; 02762 IR_COL_NUM(lab_idx) = col; 02763 IR_FLD_L(lab_idx) = AT_Tbl_Idx; 02764 IR_IDX_L(lab_idx) = jump_out_label; 02765 IR_COL_NUM_L(lab_idx) = col; 02766 IR_LINE_NUM_L(lab_idx) = line; 02767 AT_DEFINED(jump_out_label) = TRUE; 02768 SH_IR_IDX(curr_stmt_sh_idx) = lab_idx; 02769 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02770 ATL_DEF_STMT_IDX(jump_out_label) = curr_stmt_sh_idx; 02771 02772 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02773 02774 NTR_IR_TBL(br_true_idx); 02775 IR_OPR(br_true_idx) = Br_True_Opr; 02776 IR_TYPE_IDX(br_true_idx) = LOGICAL_DEFAULT_TYPE; 02777 IR_LINE_NUM(br_true_idx) = line; 02778 IR_COL_NUM(br_true_idx) = col; 02779 02780 NTR_IR_TBL(ne_idx); 02781 IR_OPR(ne_idx) = Ne_Opr; 02782 IR_TYPE_IDX(ne_idx) = LOGICAL_DEFAULT_TYPE; 02783 IR_LINE_NUM(ne_idx) = line; 02784 IR_COL_NUM(ne_idx) = col; 02785 IR_FLD_L(ne_idx) = AT_Tbl_Idx; 02786 IR_IDX_L(ne_idx) = alt_return_tmp; 02787 IR_LINE_NUM_L(ne_idx) = line; 02788 IR_COL_NUM_L(ne_idx) = col; 02789 02790 IR_FLD_R(ne_idx) = CN_Tbl_Idx; 02791 IR_IDX_R(ne_idx) = CN_INTEGER_ZERO_IDX; 02792 IR_LINE_NUM_R(ne_idx) = line; 02793 IR_COL_NUM_R(ne_idx) = col; 02794 02795 IR_FLD_L(br_true_idx) = IR_Tbl_Idx; 02796 IR_IDX_L(br_true_idx) = ne_idx; 02797 02798 IR_FLD_R(br_true_idx) = AT_Tbl_Idx; 02799 IR_IDX_R(br_true_idx) = jump_out_label; 02800 IR_LINE_NUM_R(br_true_idx) = line; 02801 IR_COL_NUM_R(br_true_idx) = col; 02802 02803 gen_sh(After, If_Stmt, line, col, FALSE, FALSE, TRUE); 02804 02805 SH_IR_IDX(curr_stmt_sh_idx) = br_true_idx; 02806 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02807 02808 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02809 02810 } 02811 # endif 02812 02813 if (semantically_correct && 02814 (number_of_functions > 0 || 02815 tree_has_constructor || 02816 io_stmt_must_be_split || 02817 io_item_must_flatten)) { 02818 process_deferred_io_list(); 02819 } 02820 else if (semantically_correct) { 02821 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 02822 gen_runtime_checks(&opnd); 02823 } 02824 } 02825 02826 TRACE (Func_Exit, "write_stmt_semantics", NULL); 02827 02828 return; 02829 02830 } /* write_stmt_semantics */ 02831 02832 02833 /******************************************************************************\ 02834 |* *| 02835 |* Description: *| 02836 |* <description> *| 02837 |* *| 02838 |* Input parameters: *| 02839 |* NONE *| 02840 |* *| 02841 |* Output parameters: *| 02842 |* NONE *| 02843 |* *| 02844 |* Returns: *| 02845 |* NOTHING *| 02846 |* *| 02847 \******************************************************************************/ 02848 02849 static boolean io_ctl_list_semantics(opnd_type *list_opnd, 02850 io_stmt_type io_type, 02851 boolean is_call) 02852 02853 { 02854 int attr_idx; 02855 int ciitem_idx; 02856 int col; 02857 long_type constant_value; 02858 int err_idx; 02859 expr_arg_type exp_desc; 02860 boolean default_kind; 02861 boolean format_expected; 02862 int free_list_idx; 02863 int i; 02864 int info_idx; 02865 boolean internal_file = FALSE; 02866 char io_type_string[16]; 02867 int k; 02868 opnd_type left_opnd; 02869 int line; 02870 int list_array[MAX_NUM_CIITEM + 1]; 02871 int list_idx; 02872 boolean match; 02873 boolean namelist_expected; 02874 opnd_type opnd; 02875 int pp_tmp = NULL_IDX; 02876 boolean semantically_correct = TRUE; 02877 int tmp_idx; 02878 int fm; 02879 02880 # if ! (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 02881 int ir_idx; 02882 # endif 02883 02884 02885 TRACE (Func_Entry, "io_ctl_list_semantics", NULL); 02886 02887 list_directed = FALSE; 02888 02889 io_type_string[0] = '\0'; 02890 strcat(io_type_string, io_stmt_str[io_type]); 02891 02892 end_list_idx = NULL_IDX; 02893 err_list_idx = NULL_IDX; 02894 err_attr_idx = NULL_IDX; 02895 eor_list_idx = NULL_IDX; 02896 have_iostat = FALSE; 02897 02898 if (io_type == Print) { 02899 io_type = Write; 02900 } 02901 02902 if (io_type == Inquire) { 02903 err_idx = INQ_ERR_IDX; 02904 } 02905 else { 02906 err_idx = ERR_IDX; 02907 } 02908 02909 is_namelist = FALSE; 02910 02911 list_idx = OPND_IDX((*list_opnd)); 02912 02913 info_idx = arg_info_list_base; 02914 02915 for (i = 1; i <= OPND_LIST_CNT((*list_opnd)); i++) { 02916 02917 info_idx++; 02918 02919 list_array[i] = list_idx; 02920 02921 format_expected = IL_FORMAT_EXPECTED(list_idx); 02922 namelist_expected = IL_NAMELIST_EXPECTED(list_idx); 02923 02924 02925 if (IL_FLD(list_idx) == NO_Tbl_Idx) { 02926 list_idx = IL_NEXT_LIST_IDX(list_idx); 02927 continue; 02928 } 02929 else if (IL_FLD(list_idx) == CN_Tbl_Idx && 02930 IL_IDX(list_idx) == NULL_IDX) { 02931 /* had a * for format or unit */ 02932 02933 if (i == 1) { 02934 /* default unit */ 02935 02936 /* change to NO_Tbl_Idx */ 02937 IL_FLD(list_idx) = NO_Tbl_Idx; 02938 } 02939 else if (i == 2) { 02940 /* list directed io */ 02941 list_directed = TRUE; 02942 02943 } 02944 # ifdef _DEBUG 02945 else { 02946 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx), 02947 &line, 02948 &col); 02949 PRINTMSG(line, 762, Internal, col); 02950 } 02951 # endif 02952 list_idx = IL_NEXT_LIST_IDX(list_idx); 02953 continue; 02954 } 02955 else 02956 if (IL_FLD(list_idx) == AT_Tbl_Idx && 02957 i == FMT_IDX && 02958 !(namelist_expected) && 02959 ( io_type == Write || io_type == Read)){ 02960 if (AT_OBJ_CLASS(IL_IDX(list_idx)) == Data_Obj){ 02961 if (ATD_CLASS(IL_IDX(list_idx)) == Constant) 02962 IL_IDX(list_idx) = ATD_CONST_IDX(IL_IDX(list_idx)); 02963 else 02964 if (ATD_CLASS(IL_IDX(list_idx)) ==Atd_Unknown && 02965 AT_ATTR_LINK(IL_IDX(list_idx)) != NULL && 02966 ATD_CLASS(AT_ATTR_LINK(IL_IDX(list_idx)))== Constant ) 02967 IL_IDX(list_idx) = ATD_CONST_IDX(AT_ATTR_LINK(IL_IDX(list_idx))); 02968 else 02969 IL_IDX(list_idx)=ATD_TMP_IDX(ATL_FORMAT_TMP(IL_IDX(list_idx))); 02970 } 02971 else 02972 IL_IDX(list_idx)=ATD_TMP_IDX(ATL_FORMAT_TMP(IL_IDX(list_idx))); 02973 02974 IL_FLD(list_idx) = CN_Tbl_Idx; 02975 02976 } 02977 else if (i == FMT_IDX && 02978 IL_FLD(list_idx) == IL_Tbl_Idx) { 02979 /* this was format character constant inline */ 02980 /* do not send through expr_semantics. */ 02981 /* first item is format tmp, second is */ 02982 /* preparsed format tmp. */ 02983 02984 pp_tmp = IL_IDX(IL_NEXT_LIST_IDX(IL_IDX(list_idx))); 02985 FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(IL_IDX(list_idx))); 02986 free_list_idx = IL_IDX(list_idx); 02987 COPY_OPND(IL_OPND(list_idx), IL_OPND(IL_IDX(list_idx))); 02988 FREE_IR_LIST_NODE(free_list_idx); 02989 02990 ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx)); 02991 ADD_TMP_TO_SHARED_LIST(pp_tmp); 02992 02993 list_idx = IL_NEXT_LIST_IDX(list_idx); 02994 continue; 02995 } 02996 02997 ciitem_idx = arg_idx_tbl[io_type][i]; 02998 02999 exp_desc.rank = 0; 03000 COPY_OPND(opnd, IL_OPND(list_idx)); 03001 03002 if (i == NML_IDX) { 03003 namelist_illegal = FALSE; 03004 } 03005 03006 io_item_must_flatten = FALSE; 03007 03008 if (ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form 03009 == Var_Only_Form) { 03010 xref_state = CIF_Symbol_Modification; 03011 } 03012 else if (i == FMT_IDX && 03013 IL_FLD(list_idx) == AT_Tbl_Idx && 03014 AT_OBJ_CLASS(IL_IDX(list_idx)) == Label) { 03015 03016 xref_state = CIF_No_Usage_Rec; 03017 } 03018 else { 03019 xref_state = CIF_Symbol_Reference; 03020 } 03021 03022 if (i == UNIT_IDX) { 03023 in_call_list = TRUE; 03024 } 03025 03026 if (ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form 03027 == Label_Form || 03028 ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form 03029 == Format_Form) { 03030 03031 label_allowed = TRUE; 03032 } 03033 03034 if (!expr_semantics(&opnd, &exp_desc)) { 03035 namelist_illegal = TRUE; 03036 label_allowed = FALSE; 03037 semantically_correct = FALSE; 03038 list_idx = IL_NEXT_LIST_IDX(list_idx); 03039 in_call_list = FALSE; 03040 continue; 03041 } 03042 03043 in_call_list = FALSE; 03044 label_allowed = FALSE; 03045 03046 COPY_OPND(IL_OPND(list_idx), opnd); 03047 03048 namelist_illegal = TRUE; 03049 03050 if (! is_call) { 03051 03052 if (io_item_must_flatten || 03053 exp_desc.dist_reshape_ref || 03054 exp_desc.vector_subscript) { 03055 03056 tmp_idx = create_tmp_asg(&opnd, &exp_desc, &left_opnd, 03057 Intent_In, TRUE, FALSE); 03058 COPY_OPND(IL_OPND(list_idx), left_opnd); 03059 } 03060 } 03061 else { 03062 arg_info_list[info_idx] = init_arg_info; 03063 arg_info_list[info_idx].ed = exp_desc; 03064 arg_info_list[info_idx].maybe_modified = TRUE; 03065 IL_ARG_DESC_IDX(list_idx) = info_idx; 03066 } 03067 03068 if (exp_desc.rank != 0 && 03069 i != FMT_IDX && 03070 exp_desc.type != Character) { 03071 03072 find_opnd_line_and_column(&opnd, &line, &col); 03073 PRINTMSG(line, 449, Error, col, 03074 exp_desc.rank, 03075 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name); 03076 semantically_correct = FALSE; 03077 } 03078 03079 if (ciitem_tbl[io_type].ciitem_list[ciitem_idx].scalar && 03080 exp_desc.rank > 0) { 03081 03082 find_opnd_line_and_column(&opnd, &line, &col); 03083 PRINTMSG(line, 1113, Error, col, 03084 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name); 03085 semantically_correct = FALSE; 03086 } 03087 03088 switch (ciitem_tbl[io_type].ciitem_list[ciitem_idx].allowed_form) { 03089 case Exp_Form : 03090 03091 match = FALSE; 03092 03093 for (k = 0; 03094 k < ciitem_tbl[io_type].ciitem_list[ciitem_idx].num_types; 03095 k++){ 03096 03097 if (exp_desc.type == 03098 ciitem_tbl[io_type].ciitem_list[ciitem_idx]. 03099 allowed_types[k]) { 03100 match = TRUE; 03101 break; 03102 } 03103 } 03104 03105 find_opnd_line_and_column(&opnd, &line, &col); 03106 03107 if (!match) { 03108 PRINTMSG(line, 441, Error, col, 03109 get_basic_type_str(exp_desc.type_idx), 03110 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name, 03111 io_type_string); 03112 03113 semantically_correct = FALSE; 03114 } 03115 else if (exp_desc.type == Typeless) { 03116 03117 if (exp_desc.linear_type == Long_Typeless) { 03118 find_opnd_line_and_column(&opnd, &line, &col); 03119 PRINTMSG(line, 1133, Error, col); 03120 semantically_correct = FALSE; 03121 } 03122 else if (exp_desc.linear_type == Short_Typeless_Const) { 03123 IL_IDX(list_idx) = cast_typeless_constant(IL_IDX(list_idx), 03124 INTEGER_DEFAULT_TYPE, 03125 line, 03126 col); 03127 exp_desc.linear_type = INTEGER_DEFAULT_TYPE; 03128 exp_desc.type_idx = INTEGER_DEFAULT_TYPE; 03129 exp_desc.type = Integer; 03130 COPY_OPND(opnd, IL_OPND(list_idx)); 03131 } 03132 } 03133 else if (exp_desc.type == Character && 03134 ! exp_desc.constant && 03135 ciitem_tbl[io_type].ciitem_list[ciitem_idx]. 03136 allowed_types[0] == Integer && 03137 (io_type == Rewind || 03138 io_type == Backspace || 03139 io_type == Endfile)) { 03140 03141 /* It is an error to have a character variable UNIT for */ 03142 /* endfile, backspace or rewind. */ 03143 03144 PRINTMSG(line, 441, Error, col, 03145 get_basic_type_str(exp_desc.type_idx), 03146 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name, 03147 io_type_string); 03148 03149 semantically_correct = FALSE; 03150 03151 } 03152 else if (exp_desc.type == Character && 03153 exp_desc.constant && 03154 ciitem_tbl[io_type].ciitem_list[ciitem_idx]. 03155 allowed_types[0] == Integer) { 03156 03157 /* This combination of factors assumes we are */ 03158 /* talking about a character constant UNIT, */ 03159 /* this is a file name, not internal write. */ 03160 /* change to Typeless here. check length first */ 03161 03162 # ifdef _DEBUG 03163 if (strcmp(ciitem_tbl[io_type].ciitem_list[ciitem_idx].name, 03164 "UNIT") != 0) { 03165 PRINTMSG(line, 606, Internal, col); 03166 } 03167 # endif 03168 03169 if (compare_cn_and_value(TYP_IDX(exp_desc.type_idx), 03170 TARGET_BYTES_PER_WORD, 03171 Lt_Opr)) { 03172 03173 /* BRIANJ - Why convert since it is going back to const */ 03174 /* table. Can we use it directly? */ 03175 03176 constant_value = (long_type) CN_INT_TO_C(OPND_IDX(opnd)); 03177 IL_IDX(list_idx) = ntr_const_tbl(TYPELESS_DEFAULT_TYPE, 03178 FALSE, 03179 &constant_value); 03180 03181 exp_desc.type = Typeless; 03182 exp_desc.linear_type = TYPELESS_DEFAULT_TYPE; 03183 exp_desc.type_idx = TYPELESS_DEFAULT_TYPE; 03184 03185 PRINTMSG(line, 485, Ansi, col); 03186 03187 if (is_call) { 03188 arg_info_list[info_idx].ed = exp_desc; 03189 } 03190 } 03191 else { 03192 PRINTMSG(line, 216, Error, col, 03193 TARGET_BYTES_PER_WORD); 03194 semantically_correct = FALSE; 03195 } 03196 } 03197 03198 if (semantically_correct) { 03199 03200 COPY_OPND(opnd, IL_OPND(list_idx)); 03201 cast_to_cg_default(&opnd, &exp_desc); 03202 COPY_OPND(IL_OPND(list_idx), opnd); 03203 03204 if (is_call) { 03205 arg_info_list[info_idx].ed = exp_desc; 03206 } 03207 } 03208 03209 if (is_call) { 03210 arg_info_list[info_idx].maybe_modified = FALSE; 03211 } 03212 break; 03213 03214 case Label_Form : 03215 03216 if (i == err_idx) { 03217 err_list_idx = list_idx; 03218 err_attr_idx = IL_IDX(list_idx); 03219 } 03220 else if (i == END_IDX) { 03221 end_list_idx = list_idx; 03222 } 03223 else if (i == EOR_IDX) { 03224 eor_list_idx = list_idx; 03225 } 03226 03227 if (OPND_FLD(opnd) == AT_Tbl_Idx && 03228 AT_OBJ_CLASS(OPND_IDX(opnd)) == Label) { 03229 } 03230 else { 03231 find_opnd_line_and_column(&opnd, &line, &col); 03232 PRINTMSG(line, 448, Error, col); 03233 semantically_correct = FALSE; 03234 } 03235 03236 break; 03237 03238 case Namelist_Form : 03239 03240 /* never be here */ 03241 break; 03242 03243 case Var_Only_Form : 03244 03245 find_opnd_line_and_column(&opnd, &line, &col); 03246 if (exp_desc.reference) { 03247 03248 default_kind = TRUE; 03249 switch (exp_desc.type) { 03250 case Integer : 03251 default_kind = (exp_desc.linear_type == INTEGER_DEFAULT_TYPE); 03252 break; 03253 03254 case Logical : 03255 default_kind = (exp_desc.linear_type == LOGICAL_DEFAULT_TYPE); 03256 break; 03257 case Real : 03258 default_kind = (exp_desc.linear_type == REAL_DEFAULT_TYPE); 03259 break; 03260 case Complex : 03261 default_kind = (exp_desc.linear_type == COMPLEX_DEFAULT_TYPE); 03262 break; 03263 case Character : 03264 default_kind = TRUE; 03265 break; 03266 } 03267 03268 if (exp_desc.type != ciitem_tbl[io_type].ciitem_list[ciitem_idx]. 03269 allowed_types[0]) { 03270 PRINTMSG(line, 459, Error, col, 03271 get_basic_type_str(exp_desc.type_idx), 03272 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name, 03273 io_type_string); 03274 03275 semantically_correct = FALSE; 03276 } 03277 else if (!default_kind) { 03278 PRINTMSG(line, 461, Error, col, 03279 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name, 03280 io_type_string); 03281 semantically_correct = FALSE; 03282 } 03283 else if (! check_for_legal_define(&opnd)) { 03284 semantically_correct = FALSE; 03285 } 03286 else { 03287 03288 attr_idx = find_left_attr(&opnd); 03289 03290 # if ! (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 03291 if ((exp_desc.type == Integer && 03292 storage_bit_size_tbl[exp_desc.linear_type] != 03293 storage_bit_size_tbl[ 03294 TYP_LINEAR(CG_INTEGER_DEFAULT_TYPE)]) || 03295 (exp_desc.type == Logical && 03296 storage_bit_size_tbl[exp_desc.linear_type] != 03297 storage_bit_size_tbl[ 03298 TYP_LINEAR(CG_LOGICAL_DEFAULT_TYPE)])) { 03299 03300 03301 /* must be word size int/logical, else copy out */ 03302 03303 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 03304 03305 if (exp_desc.type == Integer) { 03306 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE; 03307 } 03308 else { 03309 ATD_TYPE_IDX(tmp_idx) = CG_LOGICAL_DEFAULT_TYPE; 03310 } 03311 03312 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 03313 AT_SEMANTICS_DONE(tmp_idx)= TRUE; 03314 03315 03316 NTR_IR_TBL(ir_idx); 03317 IR_OPR(ir_idx) = Asg_Opr; 03318 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(tmp_idx); 03319 IR_LINE_NUM(ir_idx) = line; 03320 IR_COL_NUM(ir_idx) = col; 03321 03322 IR_FLD_R(ir_idx) = AT_Tbl_Idx; 03323 IR_IDX_R(ir_idx) = tmp_idx; 03324 IR_LINE_NUM_R(ir_idx) = line; 03325 IR_COL_NUM_R(ir_idx) = col; 03326 03327 COPY_OPND(IR_OPND_L(ir_idx), opnd); 03328 gen_sh(After, Assignment_Stmt, line, 03329 col, FALSE, FALSE, TRUE); 03330 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 03331 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 03332 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 03333 03334 IL_FLD(list_idx) = AT_Tbl_Idx; 03335 IL_IDX(list_idx) = tmp_idx; 03336 IL_LINE_NUM(list_idx) = line; 03337 IL_COL_NUM(list_idx) = col; 03338 03339 COPY_OPND(opnd, IL_OPND(list_idx)); 03340 03341 exp_desc.tmp_reference = TRUE; 03342 exp_desc.type_idx = ATD_TYPE_IDX(tmp_idx); 03343 exp_desc.linear_type = TYP_LINEAR(ATD_TYPE_IDX(tmp_idx)); 03344 03345 if (is_call) { 03346 arg_info_list[info_idx].ed = exp_desc; 03347 } 03348 03349 } 03350 # endif 03351 } 03352 } 03353 else { /* must be variable */ 03354 PRINTMSG(line, 460, Error, col, 03355 ciitem_tbl[io_type].ciitem_list[ciitem_idx].name, 03356 basic_type_str[ciitem_tbl[io_type]. 03357 ciitem_list[ciitem_idx].allowed_types[0]], 03358 io_type_string); 03359 semantically_correct = FALSE; 03360 } 03361 03362 break; 03363 03364 case Format_Form : 03365 03366 /* assume format for now */ 03367 03368 find_opnd_line_and_column(&opnd, &line, &col); 03369 03370 fm = OPND_IDX(opnd); 03371 03372 if (!format_expected && 03373 OPND_FLD(opnd) == AT_Tbl_Idx && 03374 AT_OBJ_CLASS(OPND_IDX(opnd)) == Namelist_Grp ) { 03375 is_namelist = TRUE; 03376 03377 if (io_type == Read) { 03378 semantically_correct = do_read_namelist_semantics(&opnd) 03379 && semantically_correct; 03380 } 03381 else { 03382 do_write_namelist_semantics(&opnd); 03383 } 03384 03385 if (ATN_NAMELIST_DESC(OPND_IDX(opnd)) == NULL_IDX) { 03386 /* create_namelist_descriptor(OPND_IDX(opnd)); */ 03387 } 03388 03389 namelist_descriptor_attr = ATN_NAMELIST_DESC(OPND_IDX(opnd)); 03390 03391 ADD_TMP_TO_SHARED_LIST(namelist_descriptor_attr); 03392 03393 } 03394 else if (namelist_expected) { 03395 03396 /* must be namelist group, had NML = */ 03397 03398 PRINTMSG(line, 446, Error, col); 03399 semantically_correct = FALSE; 03400 03401 is_namelist = TRUE; 03402 } 03403 else if (OPND_FLD(opnd) == AT_Tbl_Idx && 03404 AT_OBJ_CLASS(OPND_IDX(opnd)) == Label) { 03405 03406 if (ATL_CLASS(OPND_IDX(opnd)) == Lbl_Format) { 03407 /* replace label reference with format constant idx */ 03408 IL_IDX(list_idx) = ATL_FORMAT_TMP(OPND_IDX(opnd)); 03409 IL_FLD(list_idx) = AT_Tbl_Idx; 03410 IL_LINE_NUM(list_idx) = line; 03411 IL_COL_NUM(list_idx) = col; 03412 03413 pp_tmp = ATL_PP_FORMAT_TMP(OPND_IDX(opnd)); 03414 03415 ADD_TMP_TO_SHARED_LIST(ATL_FORMAT_TMP(OPND_IDX(opnd))); 03416 ADD_TMP_TO_SHARED_LIST(ATL_PP_FORMAT_TMP(OPND_IDX(opnd))); 03417 } 03418 03419 /* if not a format label larry will have already caught it */ 03420 03421 } 03422 else if (exp_desc.type == Character) { 03423 03424 } 03425 else if (exp_desc.rank > 0 && 03426 (OPND_FLD(opnd) != IR_Tbl_Idx || 03427 exp_desc.dope_vector || 03428 IR_OPR(OPND_IDX(opnd)) != Whole_Subscript_Opr)) { 03429 03430 /* these are noncontiguous arrays, sections, dope vectors */ 03431 /* error .. format error */ 03432 03433 PRINTMSG(line, 447, Error, col); 03434 semantically_correct = FALSE; 03435 } 03436 else if (exp_desc.type == Integer && 03437 exp_desc.reference) { 03438 03439 if (exp_desc.rank == 0) { /* check for ASSIGN */ 03440 03441 if (!exp_desc.reference) { /* error .. must be variable */ 03442 PRINTMSG(line, 447, Error, col); 03443 semantically_correct = FALSE; 03444 } 03445 else if (exp_desc.linear_type != INTEGER_DEFAULT_TYPE) { 03446 03447 /* must be default kind */ 03448 03449 PRINTMSG(line, 462, Error, col); 03450 semantically_correct = FALSE; 03451 } 03452 else { 03453 03454 attr_idx = find_base_attr(&opnd, &line, &col); 03455 03456 if (! ATD_IN_ASSIGN(attr_idx)) { 03457 PRINTMSG(line, 1099, Error, col); 03458 } 03459 03460 # if defined(GENERATE_WHIRL) 03461 if (ATD_ASSIGN_TMP_IDX(attr_idx) != NULL_IDX) { 03462 OPND_FLD(opnd) = AT_Tbl_Idx; 03463 OPND_IDX(opnd) = ATD_ASSIGN_TMP_IDX(attr_idx); 03464 COPY_OPND(IL_OPND(list_idx), opnd); 03465 ADD_TMP_TO_SHARED_LIST(ATD_ASSIGN_TMP_IDX(attr_idx)); 03466 } 03467 # endif 03468 } 03469 } 03470 else { /* integer array is nonstandard */ 03471 PRINTMSG(line, 778, Ansi, col); 03472 } 03473 } 03474 else if ((exp_desc.linear_type == REAL_DEFAULT_TYPE || 03475 exp_desc.type == Logical) && 03476 exp_desc.reference && 03477 exp_desc.rank > 0) { 03478 PRINTMSG(line, 778, Ansi, col); 03479 } 03480 else if (exp_desc.type == Typeless && 03481 exp_desc.rank == 0) { 03482 03483 /* intentionally blank */ 03484 /* ansi msg already issued by lex */ 03485 } 03486 else { /* error .. format error */ 03487 PRINTMSG(line, 447, Error, col); 03488 semantically_correct = FALSE; 03489 } 03490 03491 break; 03492 } /* switch */ 03493 03494 /* put checks here that require that the exp_desc be valid */ 03495 /* these checks are done for each list item. */ 03496 03497 if (io_type == Read || io_type == Write) { 03498 03499 if (i == UNIT_IDX) { 03500 03501 if (exp_desc.type == Character && 03502 !exp_desc.constant && 03503 exp_desc.reference) { 03504 03505 internal_file = TRUE; 03506 03507 if (io_type == Write) { 03508 mark_attr_defined(&opnd); 03509 03510 if (! check_for_legal_define(&opnd)) { 03511 semantically_correct = FALSE; 03512 } 03513 } 03514 03515 if (exp_desc.vector_subscript) { 03516 find_opnd_line_and_column(&opnd, &line, &col); 03517 PRINTMSG(line, 467, Error, col); 03518 semantically_correct = FALSE; 03519 } 03520 else if (OPND_FLD(opnd) == AT_Tbl_Idx && 03521 ATD_ARRAY_IDX(OPND_IDX(opnd)) != NULL_IDX && 03522 BD_ARRAY_CLASS(ATD_ARRAY_IDX(OPND_IDX(opnd))) == 03523 Assumed_Size) { 03524 03525 PRINTMSG(line, 1302, Ansi, col); 03526 } 03527 } 03528 } 03529 } 03530 03531 list_idx = IL_NEXT_LIST_IDX(list_idx); 03532 } /* end of for loop for list items */ 03533 03534 /* put checks here that can be done after all list items */ 03535 /* are processed. They are only done once. */ 03536 03537 if (internal_file && is_namelist) { 03538 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_array[FMT_IDX]), 03539 &line, &col); 03540 PRINTMSG(line, 472, Error, col); 03541 semantically_correct = FALSE; 03542 } 03543 03544 if (is_call) { 03545 /* copy list_array to arg_list */ 03546 for (k = 1; k <= OPND_LIST_CNT((*list_opnd)); k++) { 03547 arg_list[k] = list_array[k]; 03548 } 03549 } 03550 else { 03551 /* read, write, print */ 03552 03553 /* If PURE/ELEMENTAL subprogram, can only read/write to internal file. */ 03554 03555 if (!internal_file && 03556 (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) || 03557 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) && 03558 (io_type == Read || io_type == Write)) { 03559 PRINTMSG(line, 1263, Error, col, 03560 io_type == Read ? "READ" : "WRITE", 03561 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))?"elemental":"pure", 03562 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 03563 semantically_correct = FALSE; 03564 } 03565 03566 03567 if (internal_file) { 03568 } 03569 03570 /* if had advance specifier => check this stuff */ 03571 03572 if (IL_FLD(list_array[ADVANCE_IDX]) != NO_Tbl_Idx) { 03573 03574 if (IL_FLD(list_array[FMT_IDX]) == NO_Tbl_Idx || is_namelist) { 03575 find_opnd_line_and_column((opnd_type *) 03576 &IL_OPND(list_array[ADVANCE_IDX]), 03577 &line, &col); 03578 PRINTMSG(line, 468, Error, col); 03579 semantically_correct = FALSE; 03580 } 03581 else if (list_directed) { 03582 find_opnd_line_and_column((opnd_type *) 03583 &IL_OPND(list_array[FMT_IDX]), 03584 &line, &col); 03585 PRINTMSG(line, 469, Error, col); 03586 semantically_correct = FALSE; 03587 } 03588 03589 if (internal_file) { 03590 find_opnd_line_and_column((opnd_type *) 03591 &IL_OPND(list_array[UNIT_IDX]), 03592 &line, &col); 03593 PRINTMSG(line, 470, Error, col); 03594 semantically_correct = FALSE; 03595 } 03596 } 03597 03598 /* if REC specifier is present => check this stuff */ 03599 03600 if (IL_FLD(list_array[REC_IDX]) != NO_Tbl_Idx) { 03601 03602 if (internal_file) { 03603 find_opnd_line_and_column((opnd_type *) 03604 &IL_OPND(list_array[REC_IDX]), 03605 &line, &col); 03606 PRINTMSG(line, 471, Error, col); 03607 semantically_correct = FALSE; 03608 } 03609 else if (is_namelist) { 03610 find_opnd_line_and_column((opnd_type *) 03611 &IL_OPND(list_array[FMT_IDX]), 03612 &line, &col); 03613 PRINTMSG(line, 466, Error, col, 03614 io_type_string); 03615 semantically_correct = FALSE; 03616 } 03617 } 03618 03619 03620 if (is_namelist) { 03621 /* change opr */ 03622 IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) = (operator_type) 03623 (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) + 2); 03624 } 03625 else if (IL_FLD(list_array[FMT_IDX]) == NO_Tbl_Idx) { 03626 /* unformatted */ 03627 IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) = (operator_type) 03628 (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) + 1); 03629 } 03630 03631 if (IL_FLD(list_array[IOSTAT_IDX]) != NO_Tbl_Idx) { 03632 have_iostat = TRUE; 03633 } 03634 03635 /******************\ 03636 |* start new list *| 03637 \******************/ 03638 03639 NTR_IR_LIST_TBL(list_idx); 03640 OPND_IDX((*list_opnd)) = list_idx; 03641 03642 # ifdef _NO_IO_ALTERNATE_RETURN 03643 OPND_LIST_CNT((*list_opnd)) = NUM_PDG_CONTROL_LIST_ITEMS + 3; 03644 # else 03645 OPND_LIST_CNT((*list_opnd)) = NUM_PDG_CONTROL_LIST_ITEMS; 03646 # endif 03647 03648 /**************************\ 03649 |* 1 - encode/decode flag *| 03650 \**************************/ 03651 03652 IL_FLD(list_idx) = CN_Tbl_Idx; 03653 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 03654 IL_LINE_NUM(list_idx) = stmt_start_line; 03655 IL_COL_NUM(list_idx) = stmt_start_col; 03656 03657 /*********************\ 03658 |* 2 - eeeflag value *| 03659 \*********************/ 03660 03661 constant_value = 0; 03662 constant_value |= (IL_FLD(list_array[err_idx]) != NO_Tbl_Idx) ? 03663 ERR_IS_PRESENT : 0; 03664 constant_value |= (IL_FLD(list_array[END_IDX]) != NO_Tbl_Idx) ? 03665 END_IS_PRESENT : 0; 03666 constant_value |= (IL_FLD(list_array[EOR_IDX]) != NO_Tbl_Idx) ? 03667 EOR_IS_PRESENT : 0; 03668 constant_value |= (IL_FLD(list_array[IOSTAT_IDX]) != NO_Tbl_Idx) ? 03669 IOSTAT_IS_PRESENT : 0; 03670 03671 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03672 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03673 list_idx = IL_NEXT_LIST_IDX(list_idx); 03674 03675 IL_FLD(list_idx) = CN_Tbl_Idx; 03676 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, constant_value); 03677 IL_LINE_NUM(list_idx) = stmt_start_line; 03678 IL_COL_NUM(list_idx) = stmt_start_col; 03679 03680 /**********************\ 03681 |* 3 - flflag value *| 03682 \**********************/ 03683 03684 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03685 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03686 list_idx = IL_NEXT_LIST_IDX(list_idx); 03687 03688 /* This is the flag for split io */ 03689 /* set to FL_IO_SINGLE for now */ 03690 03691 constant_value = FL_IO_SINGLE; 03692 03693 IL_FLD(list_idx) = CN_Tbl_Idx; 03694 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, FL_IO_SINGLE); 03695 IL_LINE_NUM(list_idx) = stmt_start_line; 03696 IL_COL_NUM(list_idx) = stmt_start_col; 03697 03698 03699 /**********************\ 03700 |* 4 - UNIT specifier *| 03701 \**********************/ 03702 03703 IL_NEXT_LIST_IDX(list_idx) = list_array[UNIT_IDX]; 03704 IL_PREV_LIST_IDX(list_array[UNIT_IDX]) = list_idx; 03705 list_idx = IL_NEXT_LIST_IDX(list_idx); 03706 03707 /***********************\ 03708 |* 5 - IOSTAT variable *| 03709 \***********************/ 03710 03711 IL_NEXT_LIST_IDX(list_idx) = list_array[IOSTAT_IDX]; 03712 IL_PREV_LIST_IDX(list_array[IOSTAT_IDX]) = list_idx; 03713 list_idx = IL_NEXT_LIST_IDX(list_idx); 03714 03715 /**********************\ 03716 |* 6 - REC expression *| 03717 \**********************/ 03718 03719 IL_NEXT_LIST_IDX(list_idx) = list_array[REC_IDX]; 03720 IL_PREV_LIST_IDX(list_array[REC_IDX]) = list_idx; 03721 list_idx = IL_NEXT_LIST_IDX(list_idx); 03722 03723 /*************************\ 03724 |* 7 - pre-parsed format *| 03725 \*************************/ 03726 03727 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 03728 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 03729 list_idx = IL_NEXT_LIST_IDX(list_idx); 03730 03731 /* get pre-parsed from somewhere */ 03732 03733 if (! is_namelist && 03734 ! list_directed) { 03735 03736 if (pp_tmp) { 03737 IL_FLD(list_idx) = AT_Tbl_Idx; 03738 IL_IDX(list_idx) = pp_tmp; 03739 IL_LINE_NUM(list_idx) = stmt_start_line; 03740 IL_COL_NUM(list_idx) = stmt_start_col; 03741 } 03742 } 03743 03744 /*********************\ 03745 |* 8 - format source *| 03746 \*********************/ 03747 03748 IL_NEXT_LIST_IDX(list_idx) = list_array[FMT_IDX]; 03749 IL_PREV_LIST_IDX(list_array[FMT_IDX]) = list_idx; 03750 list_idx = IL_NEXT_LIST_IDX(list_idx); 03751 03752 if (list_directed) 03753 { 03754 IL_OPND(list_idx) = null_opnd; 03755 } 03756 03757 /**************************\ 03758 |* 9 - ADVANCE expression *| 03759 \**************************/ 03760 03761 IL_NEXT_LIST_IDX(list_idx) = list_array[ADVANCE_IDX]; 03762 IL_PREV_LIST_IDX(list_array[ADVANCE_IDX]) = list_idx; 03763 list_idx = IL_NEXT_LIST_IDX(list_idx); 03764 03765 /************************\ 03766 |* 10 - SIZE expression *| 03767 \************************/ 03768 03769 IL_NEXT_LIST_IDX(list_idx) = list_array[SIZE_IDX]; 03770 IL_PREV_LIST_IDX(list_array[SIZE_IDX]) = list_idx; 03771 list_idx = IL_NEXT_LIST_IDX(list_idx); 03772 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 03773 03774 # ifdef _NO_IO_ALTERNATE_RETURN 03775 /************************\ 03776 |* 11 - ERR label *| 03777 \************************/ 03778 03779 if (err_list_idx == NULL_IDX) { 03780 NTR_IR_LIST_TBL(err_list_idx); 03781 } 03782 03783 IL_NEXT_LIST_IDX(list_idx) = err_list_idx; 03784 IL_PREV_LIST_IDX(err_list_idx) = list_idx; 03785 list_idx = IL_NEXT_LIST_IDX(list_idx); 03786 03787 /************************\ 03788 |* 12 - END label *| 03789 \************************/ 03790 03791 if (end_list_idx == NULL_IDX) { 03792 NTR_IR_LIST_TBL(end_list_idx); 03793 } 03794 03795 IL_NEXT_LIST_IDX(list_idx) = end_list_idx; 03796 IL_PREV_LIST_IDX(end_list_idx) = list_idx; 03797 list_idx = IL_NEXT_LIST_IDX(list_idx); 03798 03799 /************************\ 03800 |* 13 - EOR label *| 03801 \************************/ 03802 03803 if (eor_list_idx == NULL_IDX) { 03804 NTR_IR_LIST_TBL(eor_list_idx); 03805 } 03806 03807 IL_NEXT_LIST_IDX(list_idx) = eor_list_idx; 03808 IL_PREV_LIST_IDX(eor_list_idx) = list_idx; 03809 list_idx = IL_NEXT_LIST_IDX(list_idx); 03810 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 03811 # endif 03812 03813 } 03814 03815 TRACE (Func_Exit, "io_ctl_list_semantics", NULL); 03816 03817 return(semantically_correct); 03818 03819 } /* io_ctl_list_semantics */ 03820 03821 /******************************************************************************\ 03822 |* *| 03823 |* Description: *| 03824 |* <description> *| 03825 |* *| 03826 |* Input parameters: *| 03827 |* NONE *| 03828 |* *| 03829 |* Output parameters: *| 03830 |* NONE *| 03831 |* *| 03832 |* Returns: *| 03833 |* NOTHING *| 03834 |* *| 03835 \******************************************************************************/ 03836 03837 static boolean io_list_semantics(opnd_type *top_opnd, 03838 io_stmt_type io_type) 03839 03840 { 03841 int asg_idx; 03842 int attr_idx; 03843 int cnt; 03844 int col; 03845 boolean do_var_ok; 03846 expr_arg_type exp_desc; 03847 expr_arg_type lcv_exp_desc; 03848 expr_arg_type start_exp_desc; 03849 expr_arg_type end_exp_desc; 03850 expr_arg_type inc_exp_desc; 03851 boolean have_seen_must_flatten = FALSE; 03852 boolean have_seen_constructor = FALSE; 03853 int imp_idx; 03854 int line; 03855 int list_idx; 03856 int list2_idx; 03857 boolean needs_expansion = FALSE; 03858 int new_do_var_idx; 03859 opnd_type opnd; 03860 boolean save_in_implied_do; 03861 boolean semantically_correct = TRUE; 03862 int struct_list_idx; 03863 long_type the_constant; 03864 int type_idx; 03865 03866 03867 TRACE (Func_Entry, "io_list_semantics", NULL); 03868 03869 if (OPND_FLD((*top_opnd)) == NO_Tbl_Idx) { 03870 goto EXIT; 03871 } 03872 if (OPND_FLD((*top_opnd)) == IL_Tbl_Idx) { 03873 list_idx = OPND_IDX((*top_opnd)); 03874 } 03875 else { 03876 find_opnd_line_and_column(top_opnd, &line, &col); 03877 PRINTMSG(line, 637, Internal, col); 03878 } 03879 03880 io_item_must_flatten = FALSE; 03881 tree_has_constructor = FALSE; 03882 03883 # ifdef _THREE_CALL_IO 03884 io_stmt_must_be_split = TRUE; 03885 three_call_model = TRUE; 03886 # endif 03887 03888 while (list_idx != NULL_IDX) { 03889 03890 IL_HAS_FUNCTIONS(list_idx) = FALSE; 03891 IL_MUST_BE_LOOP(list_idx) = FALSE; 03892 03893 if (IL_FLD(list_idx) == IR_Tbl_Idx && 03894 IR_OPR(IL_IDX(list_idx)) == Implied_Do_Opr) { 03895 03896 # ifdef _THREE_CALL_IO 03897 IL_MUST_BE_LOOP(list_idx) = TRUE; 03898 # endif 03899 03900 /* skip do variable processing until the control values are done. */ 03901 03902 /***********************\ 03903 |* do do initial value *| 03904 \***********************/ 03905 03906 list2_idx = IL_NEXT_LIST_IDX(IR_IDX_R(IL_IDX(list_idx))); 03907 03908 COPY_OPND(opnd, IL_OPND(list2_idx)); 03909 start_exp_desc.rank = 0; 03910 number_of_functions = 0; 03911 xref_state = CIF_Symbol_Reference; 03912 semantically_correct = expr_semantics(&opnd, &start_exp_desc) && 03913 semantically_correct; 03914 COPY_OPND(IL_OPND(list2_idx), opnd); 03915 03916 if (item_has_bounds_chk(&opnd)) { 03917 number_of_functions++; 03918 } 03919 03920 if (number_of_functions > 0) { 03921 IL_HAS_FUNCTIONS(list2_idx) = TRUE; 03922 IL_HAS_FUNCTIONS(list_idx) = TRUE; 03923 needs_expansion = TRUE; 03924 03925 if (io_type == Read && 03926 list_idx != OPND_IDX((*top_opnd))) { 03927 io_stmt_must_be_split = TRUE; 03928 } 03929 } 03930 else { 03931 IL_HAS_FUNCTIONS(list2_idx) = FALSE; 03932 } 03933 03934 find_opnd_line_and_column(&opnd, &line, &col); 03935 03936 if (start_exp_desc.rank != 0) { 03937 PRINTMSG(line, 476, Error, col); 03938 semantically_correct = FALSE; 03939 } 03940 03941 if (start_exp_desc.linear_type == Long_Typeless) { 03942 PRINTMSG(line, 1133, Error, col); 03943 semantically_correct = FALSE; 03944 } 03945 else if (start_exp_desc.type != Integer && 03946 start_exp_desc.type != Typeless && 03947 (start_exp_desc.type != Real || 03948 (start_exp_desc.linear_type != REAL_DEFAULT_TYPE && 03949 start_exp_desc.linear_type != DOUBLE_DEFAULT_TYPE))) { 03950 03951 PRINTMSG(line, 477, Error, col); 03952 semantically_correct = FALSE; 03953 } 03954 else if (start_exp_desc.type == Real) { 03955 PRINTMSG(line, 943, Comment, col); 03956 } 03957 03958 COPY_OPND(opnd, IL_OPND(list2_idx)); 03959 cast_to_cg_default(&opnd, &start_exp_desc); 03960 COPY_OPND(IL_OPND(list2_idx), opnd); 03961 03962 /************************\ 03963 |* do do terminal value *| 03964 \************************/ 03965 03966 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 03967 03968 COPY_OPND(opnd, IL_OPND(list2_idx)); 03969 end_exp_desc.rank = 0; 03970 number_of_functions = 0; 03971 xref_state = CIF_Symbol_Reference; 03972 semantically_correct = expr_semantics(&opnd, &end_exp_desc) && 03973 semantically_correct; 03974 COPY_OPND(IL_OPND(list2_idx), opnd); 03975 03976 if (item_has_bounds_chk(&opnd)) { 03977 number_of_functions++; 03978 } 03979 03980 if (number_of_functions > 0) { 03981 IL_HAS_FUNCTIONS(list2_idx) = TRUE; 03982 IL_HAS_FUNCTIONS(list_idx) = TRUE; 03983 needs_expansion = TRUE; 03984 03985 if (io_type == Read && 03986 list_idx != OPND_IDX((*top_opnd))) { 03987 io_stmt_must_be_split = TRUE; 03988 } 03989 } 03990 else { 03991 IL_HAS_FUNCTIONS(list2_idx) = FALSE; 03992 } 03993 03994 find_opnd_line_and_column(&opnd, &line, &col); 03995 03996 if (end_exp_desc.rank != 0) { 03997 PRINTMSG(line, 476, Error, col); 03998 semantically_correct = FALSE; 03999 } 04000 04001 if (end_exp_desc.linear_type == Long_Typeless) { 04002 PRINTMSG(line, 1133, Error, col); 04003 semantically_correct = FALSE; 04004 } 04005 else if (end_exp_desc.type != Integer && 04006 end_exp_desc.type != Typeless && 04007 (end_exp_desc.type != Real || 04008 (end_exp_desc.linear_type != REAL_DEFAULT_TYPE && 04009 end_exp_desc.linear_type != DOUBLE_DEFAULT_TYPE))) { 04010 04011 PRINTMSG(line, 477, Error, col); 04012 semantically_correct = FALSE; 04013 } 04014 else if (end_exp_desc.type == Real) { 04015 PRINTMSG(line, 943, Comment, col); 04016 } 04017 04018 COPY_OPND(opnd, IL_OPND(list2_idx)); 04019 cast_to_cg_default(&opnd, &end_exp_desc); 04020 COPY_OPND(IL_OPND(list2_idx), opnd); 04021 04022 04023 /********************************\ 04024 |* do do stride if there is one *| 04025 \********************************/ 04026 04027 if (IL_NEXT_LIST_IDX(list2_idx) != NULL_IDX) { 04028 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 04029 COPY_OPND(opnd, IL_OPND(list2_idx)); 04030 inc_exp_desc.rank = 0; 04031 number_of_functions = 0; 04032 xref_state = CIF_Symbol_Reference; 04033 semantically_correct = expr_semantics(&opnd, &inc_exp_desc) && 04034 semantically_correct; 04035 COPY_OPND(IL_OPND(list2_idx), opnd); 04036 04037 if (item_has_bounds_chk(&opnd)) { 04038 number_of_functions++; 04039 } 04040 04041 if (number_of_functions > 0) { 04042 IL_HAS_FUNCTIONS(list2_idx) = TRUE; 04043 IL_HAS_FUNCTIONS(list_idx) = TRUE; 04044 needs_expansion = TRUE; 04045 04046 if (io_type == Read && 04047 list_idx != OPND_IDX((*top_opnd))) { 04048 io_stmt_must_be_split = TRUE; 04049 } 04050 } 04051 else { 04052 IL_HAS_FUNCTIONS(list2_idx) = FALSE; 04053 } 04054 04055 find_opnd_line_and_column(&opnd, &line, &col); 04056 04057 if (inc_exp_desc.rank != 0) { 04058 PRINTMSG(line, 476, Error, col); 04059 semantically_correct = FALSE; 04060 } 04061 04062 if (inc_exp_desc.linear_type == Long_Typeless) { 04063 PRINTMSG(line, 1133, Error, col); 04064 semantically_correct = FALSE; 04065 } 04066 else if (inc_exp_desc.type != Integer && 04067 inc_exp_desc.type != Typeless && 04068 (inc_exp_desc.type != Real || 04069 (inc_exp_desc.linear_type != REAL_DEFAULT_TYPE && 04070 inc_exp_desc.linear_type != DOUBLE_DEFAULT_TYPE))) { 04071 04072 PRINTMSG(line, 477, Error, col); 04073 semantically_correct = FALSE; 04074 } 04075 else if (inc_exp_desc.type == Real) { 04076 PRINTMSG(line, 943, Comment, col); 04077 } 04078 04079 if (semantically_correct && 04080 OPND_FLD(opnd) == CN_Tbl_Idx) { 04081 04082 type_idx = CG_LOGICAL_DEFAULT_TYPE; 04083 04084 semantically_correct &= 04085 folder_driver((char *)&CN_CONST(OPND_IDX(opnd)), 04086 inc_exp_desc.type_idx, 04087 (char *)&CN_CONST(CN_INTEGER_ZERO_IDX), 04088 CG_INTEGER_DEFAULT_TYPE, 04089 &the_constant, 04090 &type_idx, 04091 line, 04092 col, 04093 2, 04094 Eq_Opr); 04095 04096 if (THIS_IS_TRUE(&the_constant, type_idx)) { 04097 PRINTMSG(line, 1084, Error, col); 04098 semantically_correct = FALSE; 04099 } 04100 } 04101 04102 COPY_OPND(opnd, IL_OPND(list2_idx)); 04103 cast_to_cg_default(&opnd, &inc_exp_desc); 04104 COPY_OPND(IL_OPND(list2_idx), opnd); 04105 04106 } 04107 else { 04108 /* fill in default stride here */ 04109 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx)); 04110 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx; 04111 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 04112 IR_LIST_CNT_R(IL_IDX(list_idx))++; 04113 IL_FLD(list2_idx) = CN_Tbl_Idx; 04114 IL_IDX(list2_idx) = CN_INTEGER_ONE_IDX; 04115 IL_LINE_NUM(list2_idx) = stmt_start_line; 04116 IL_COL_NUM(list2_idx) = stmt_start_col; 04117 04118 inc_exp_desc = init_exp_desc; 04119 04120 inc_exp_desc.type_idx = CN_TYPE_IDX(CN_INTEGER_ONE_IDX); 04121 inc_exp_desc.linear_type = TYP_LINEAR(inc_exp_desc.type_idx); 04122 inc_exp_desc.type = TYP_TYPE(inc_exp_desc.type_idx); 04123 } 04124 04125 /**************************\ 04126 |* do do control variable *| 04127 \**************************/ 04128 04129 04130 list2_idx = IR_IDX_R(IL_IDX(list_idx)); 04131 04132 do_var_ok = TRUE; 04133 04134 COPY_OPND(opnd, IL_OPND(list2_idx)); 04135 lcv_exp_desc.rank = 0; 04136 number_of_functions = 0; 04137 xref_state = CIF_Symbol_Modification; 04138 save_in_implied_do = in_implied_do; 04139 in_implied_do = FALSE; 04140 do_var_ok = expr_semantics(&opnd, &lcv_exp_desc); 04141 COPY_OPND(IL_OPND(list2_idx), opnd); 04142 in_implied_do = save_in_implied_do; 04143 04144 04145 /* For CIF purposes, mark the LCV Attr as being used as an I/O */ 04146 /* implied-DO so that if it appears nowhere else, CIF will still */ 04147 /* generate an Object record for it. */ 04148 04149 attr_idx = find_left_attr(&opnd); 04150 04151 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 04152 ATD_SEEN_AS_IO_LCV(attr_idx) = TRUE; 04153 } 04154 04155 04156 if (number_of_functions > 0) { 04157 IL_HAS_FUNCTIONS(list2_idx) = TRUE; 04158 IL_HAS_FUNCTIONS(list_idx) = TRUE; 04159 needs_expansion = TRUE; 04160 } 04161 else { 04162 IL_HAS_FUNCTIONS(list2_idx) = FALSE; 04163 } 04164 04165 /* BHJ JLS LRR ... need interpretation for this one. imp do var must be */ 04166 /* "named" scalar variable, not sub-object. */ 04167 04168 find_opnd_line_and_column(&opnd, &line, &col); 04169 04170 if (!lcv_exp_desc.reference) { 04171 PRINTMSG(line, 481, Error, col); 04172 do_var_ok = FALSE; 04173 } 04174 else { 04175 04176 if (lcv_exp_desc.rank != 0) { 04177 PRINTMSG(line, 482, Error, col); 04178 do_var_ok = FALSE; 04179 } 04180 04181 if (lcv_exp_desc.type != Integer && 04182 (lcv_exp_desc.type != Real || 04183 (lcv_exp_desc.linear_type != REAL_DEFAULT_TYPE && 04184 lcv_exp_desc.linear_type != DOUBLE_DEFAULT_TYPE))) { 04185 04186 PRINTMSG(line, 474, Error, col); 04187 do_var_ok = FALSE; 04188 } 04189 else if (lcv_exp_desc.type == Real) { 04190 IL_MUST_BE_LOOP(list_idx) = TRUE; 04191 io_stmt_must_be_split = TRUE; 04192 PRINTMSG(line, 1569, Ansi, col); 04193 } 04194 04195 if (do_var_ok && 04196 OPND_FLD(opnd) != AT_Tbl_Idx && 04197 (OPND_FLD(opnd) != IR_Tbl_Idx || 04198 IR_OPR(OPND_IDX(opnd)) != Dv_Deref_Opr || 04199 IR_FLD_L(OPND_IDX(opnd)) != AT_Tbl_Idx)) { 04200 04201 PRINTMSG(line, 530, Comment, col); 04202 do_var_ok = FALSE; 04203 } 04204 04205 if (do_var_ok) { 04206 04207 if (! check_for_legal_define(&opnd)) { 04208 do_var_ok = FALSE; 04209 } 04210 } 04211 } 04212 04213 NTR_IR_LIST_TBL(imp_idx); 04214 IL_NEXT_LIST_IDX(imp_idx) = imp_do_var_list; 04215 imp_do_var_list = imp_idx; 04216 04217 if (do_var_ok) { 04218 imp_idx = IL_NEXT_LIST_IDX(imp_idx); 04219 04220 while (imp_idx) { 04221 04222 if (OPND_IDX(opnd) == IL_IDX(imp_idx)) { 04223 PRINTMSG(line, 533, Error, col, 04224 AT_OBJ_NAME_PTR(OPND_IDX(opnd))); 04225 do_var_ok = FALSE; 04226 break; 04227 } 04228 04229 imp_idx = IL_NEXT_LIST_IDX(imp_idx); 04230 } 04231 04232 if (do_var_ok) { 04233 COPY_OPND(IL_OPND(imp_do_var_list), opnd); 04234 } 04235 } 04236 04237 04238 semantically_correct = semantically_correct && do_var_ok; 04239 04240 04241 /***********************\ 04242 |* do list of io items *| 04243 \***********************/ 04244 04245 in_implied_do = TRUE; 04246 COPY_OPND(opnd, IR_OPND_L(IL_IDX(list_idx))); 04247 number_of_functions = 0; 04248 semantically_correct = io_list_semantics(&opnd, io_type) && 04249 semantically_correct; 04250 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), opnd); 04251 04252 if (number_of_functions > 0) { 04253 IL_HAS_FUNCTIONS(list_idx) = TRUE; 04254 IL_MUST_BE_LOOP(list_idx) = TRUE; 04255 io_stmt_must_be_split = TRUE; 04256 needs_expansion = TRUE; 04257 } 04258 04259 if (io_item_must_flatten) { 04260 IL_MUST_BE_LOOP(list_idx) = TRUE; 04261 io_stmt_must_be_split = TRUE; 04262 have_seen_must_flatten = TRUE; 04263 } 04264 04265 if (tree_has_constructor) { 04266 IL_MUST_BE_LOOP(list_idx) = TRUE; 04267 io_stmt_must_be_split = TRUE; 04268 have_seen_constructor = TRUE; 04269 } 04270 04271 /* take imp_do var of list */ 04272 imp_idx = imp_do_var_list; 04273 imp_do_var_list = IL_NEXT_LIST_IDX(imp_idx); 04274 FREE_IR_LIST_NODE(imp_idx); 04275 04276 if (do_var_ok && 04277 storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(attr_idx))] != 04278 storage_bit_size_tbl[TYP_LINEAR(CG_INTEGER_DEFAULT_TYPE)] && 04279 ! IL_MUST_BE_LOOP(list_idx)) { 04280 04281 new_do_var_idx = gen_compiler_tmp(stmt_start_line, stmt_start_col, 04282 Priv, TRUE); 04283 04284 AT_SEMANTICS_DONE(new_do_var_idx)= TRUE; 04285 ATD_TYPE_IDX(new_do_var_idx) = CG_INTEGER_DEFAULT_TYPE; 04286 ATD_STOR_BLK_IDX(new_do_var_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 04287 AT_CIF_SYMBOL_ID(new_do_var_idx) = AT_CIF_SYMBOL_ID(attr_idx); 04288 04289 lcv_exp_desc.type_idx = ATD_TYPE_IDX(new_do_var_idx); 04290 lcv_exp_desc.type = TYP_TYPE(lcv_exp_desc.type_idx); 04291 lcv_exp_desc.linear_type = TYP_LINEAR(lcv_exp_desc.type_idx); 04292 04293 AT_ATTR_LINK(attr_idx) = new_do_var_idx; 04294 AT_IGNORE_ATTR_LINK(attr_idx) = TRUE; 04295 04296 ATD_IMP_DO_LCV(new_do_var_idx) = TRUE; 04297 04298 IL_NONDEFAULT_IMP_DO_LCV(list_idx) = TRUE; 04299 io_stmt_must_be_split = TRUE; 04300 needs_expansion = TRUE; 04301 04302 NTR_IR_TBL(asg_idx); 04303 IR_OPR(asg_idx) = Asg_Opr; 04304 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(attr_idx); 04305 IR_LINE_NUM(asg_idx) = stmt_start_line; 04306 IR_COL_NUM(asg_idx) = stmt_start_col; 04307 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 04308 IR_IDX_L(asg_idx) = attr_idx; 04309 IR_LINE_NUM_L(asg_idx) = stmt_start_line; 04310 IR_COL_NUM_L(asg_idx) = stmt_start_col; 04311 IR_FLD_R(asg_idx) = AT_Tbl_Idx; 04312 IR_IDX_R(asg_idx) = new_do_var_idx; 04313 IR_LINE_NUM_R(asg_idx) = stmt_start_line; 04314 IR_COL_NUM_R(asg_idx) = stmt_start_col; 04315 04316 IL_FLD(IR_IDX_R(IL_IDX(list_idx))) = IR_Tbl_Idx; 04317 IL_IDX(IR_IDX_R(IL_IDX(list_idx))) = asg_idx; 04318 04319 in_implied_do = TRUE; 04320 COPY_OPND(opnd, IR_OPND_L(IL_IDX(list_idx))); 04321 semantically_correct = io_list_semantics(&opnd, io_type) && 04322 semantically_correct; 04323 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), opnd); 04324 } 04325 04326 if (semantically_correct && 04327 lcv_exp_desc.type == Integer) { 04328 04329 /* Check start, end, and increment to make */ 04330 /* sure they are the same type as lcv. */ 04331 04332 list2_idx = IL_NEXT_LIST_IDX(IR_IDX_R(IL_IDX(list_idx))); 04333 04334 COPY_OPND(opnd, IL_OPND(list2_idx)); 04335 cast_to_type_idx(&opnd, &start_exp_desc, lcv_exp_desc.type_idx); 04336 COPY_OPND(IL_OPND(list2_idx), opnd); 04337 04338 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 04339 04340 COPY_OPND(opnd, IL_OPND(list2_idx)); 04341 cast_to_type_idx(&opnd, &end_exp_desc, lcv_exp_desc.type_idx); 04342 COPY_OPND(IL_OPND(list2_idx), opnd); 04343 04344 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 04345 04346 COPY_OPND(opnd, IL_OPND(list2_idx)); 04347 cast_to_type_idx(&opnd, &inc_exp_desc, lcv_exp_desc.type_idx); 04348 COPY_OPND(IL_OPND(list2_idx), opnd); 04349 } 04350 04351 if (do_var_ok) { 04352 /* clear the AT_ATTR_LINK field of the old do var attr */ 04353 AT_ATTR_LINK(attr_idx) = NULL_IDX; 04354 AT_IGNORE_ATTR_LINK(attr_idx) = FALSE; 04355 } 04356 04357 in_implied_do = save_in_implied_do; 04358 } 04359 else { 04360 04361 if (IL_FLD(list_idx) == IR_Tbl_Idx && 04362 IR_OPR(IL_IDX(list_idx)) == Io_Item_Type_Code_Opr) { 04363 04364 /* this is the second time here for this one. */ 04365 /* remove the Io_Item_Type_Code_Opr. */ 04366 04367 COPY_OPND(IL_OPND(list_idx), IR_OPND_L(IL_IDX(list_idx))); 04368 } 04369 04370 exp_desc.rank = 0; 04371 COPY_OPND(opnd, IL_OPND(list_idx)); 04372 number_of_functions = 0; 04373 io_item_must_flatten = FALSE; 04374 tree_has_constructor = FALSE; 04375 04376 if (io_type == Read || io_type == Decode) { 04377 xref_state = CIF_Symbol_Modification; 04378 } 04379 else { 04380 xref_state = CIF_Symbol_Reference; 04381 } 04382 04383 if (list_directed && 04384 OPND_FLD(opnd) == CN_Tbl_Idx && 04385 TYP_TYPE(CN_TYPE_IDX(OPND_IDX(opnd))) == Typeless) { 04386 04387 find_opnd_line_and_column(&opnd, &line, &col); 04388 PRINTMSG(line, 316, Error, col); 04389 semantically_correct = FALSE; 04390 } 04391 04392 in_io_list = TRUE; 04393 semantically_correct = expr_semantics(&opnd, &exp_desc) && 04394 semantically_correct; 04395 COPY_OPND(IL_OPND(list_idx), opnd); 04396 in_io_list = FALSE; 04397 04398 if (exp_desc.reference) { 04399 attr_idx = find_left_attr(&opnd); 04400 04401 if (ATD_AUXILIARY(attr_idx)) { 04402 semantically_correct = FALSE; 04403 find_opnd_line_and_column(&opnd, &line, &col); 04404 PRINTMSG(line, 945, Error, col); 04405 } 04406 } 04407 04408 if (item_has_bounds_chk(&opnd)) { 04409 number_of_functions++; 04410 } 04411 04412 if (number_of_functions > 0) { 04413 IL_HAS_FUNCTIONS(list_idx) = TRUE; 04414 needs_expansion = TRUE; 04415 04416 if (io_type == Read && 04417 list_idx != OPND_IDX((*top_opnd))) { 04418 io_stmt_must_be_split = TRUE; 04419 } 04420 } 04421 04422 if (io_item_must_flatten || 04423 exp_desc.dist_reshape_ref || 04424 (IL_FLD(list_idx) == IR_Tbl_Idx && 04425 IR_ARRAY_SYNTAX(IL_IDX(list_idx))) || 04426 exp_desc.vector_subscript) { 04427 04428 IL_MUST_FLATTEN(list_idx) = TRUE; 04429 have_seen_must_flatten = TRUE; 04430 04431 if ((io_type == Read || io_type == Decode) && 04432 (exp_desc.vector_subscript || exp_desc.dist_reshape_ref) && 04433 IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 04434 04435 io_stmt_must_be_split = TRUE; 04436 } 04437 04438 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 04439 04440 /* save exp_desc */ 04441 arg_info_list_base = arg_info_list_top; 04442 arg_info_list_top = arg_info_list_base + 1; 04443 04444 if (arg_info_list_top >= arg_info_list_size) { 04445 enlarge_info_list_table(); 04446 } 04447 04448 IL_ARG_DESC_IDX(list_idx) = arg_info_list_top; 04449 arg_info_list[arg_info_list_top] = init_arg_info; 04450 arg_info_list[arg_info_list_top].ed = exp_desc; 04451 } 04452 else if (tree_has_constructor) { 04453 IL_HAS_CONSTRUCTOR(list_idx) = TRUE; 04454 have_seen_constructor = TRUE; 04455 } 04456 04457 if (io_type == Read || io_type == Decode) { 04458 04459 if (!exp_desc.reference) { 04460 find_opnd_line_and_column(&opnd, &line, &col); 04461 04462 if (exp_desc.constant) { 04463 PRINTMSG(line, 479, Error, col, 04464 io_stmt_str[io_type]); 04465 } 04466 else { /* expression */ 04467 PRINTMSG(line, 478, Error, col, 04468 io_stmt_str[io_type]); 04469 } 04470 04471 semantically_correct = FALSE; 04472 } 04473 else if (OPND_FLD(opnd) == AT_Tbl_Idx && 04474 imp_do_var_list != NULL_IDX) { 04475 04476 imp_idx = imp_do_var_list; 04477 04478 while (imp_idx) { 04479 04480 if (OPND_IDX(opnd) == IL_IDX(imp_idx)) { 04481 04482 /* error .. input item must not be imp do var */ 04483 04484 find_opnd_line_and_column(&opnd, &line, &col); 04485 PRINTMSG(line, 532, Error, col); 04486 semantically_correct = FALSE; 04487 break; 04488 } 04489 imp_idx = IL_NEXT_LIST_IDX(imp_idx); 04490 } 04491 } 04492 04493 if (semantically_correct) { 04494 04495 if (! check_for_legal_define(&opnd)) { 04496 semantically_correct = FALSE; 04497 } 04498 } 04499 } /* io_type == Read */ 04500 04501 if (exp_desc.type == Structure) { 04502 04503 if (ATT_POINTER_CPNT(TYP_IDX(exp_desc.type_idx))) { 04504 find_opnd_line_and_column(&opnd, &line, &col); 04505 PRINTMSG(line, 235, Error, col); 04506 semantically_correct = FALSE; 04507 } 04508 else if (AT_USE_ASSOCIATED(TYP_IDX(exp_desc.type_idx)) && 04509 ATT_PRIVATE_CPNT(TYP_IDX(exp_desc.type_idx))) { 04510 find_opnd_line_and_column(&opnd, &line, &col); 04511 PRINTMSG(line, 1100, Error, col); 04512 semantically_correct = FALSE; 04513 } 04514 else if (IL_MUST_FLATTEN(list_idx) && FALSE) { 04515 /* This is either a concat, array */ 04516 /* syntax, or a vector valued subscript. All of which */ 04517 /* need to be flattened to a temp before the structure */ 04518 /* is split up. The expr_desc has already been saved. */ 04519 04520 IL_STRUCT_REF(list_idx) = TRUE; 04521 04522 } 04523 else /* 11/07/00[sos]: else clause changed for PV 799401 */ 04524 { 04525 #if 0 /* do not lower or flatten the structure io item--FMZ */ 04526 04527 IL_STRUCT_REF(list_idx) = TRUE; 04528 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 04529 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 04530 number_of_functions++; 04531 needs_expansion = TRUE; 04532 04533 /* save exp_desc */ 04534 arg_info_list_base = arg_info_list_top; 04535 arg_info_list_top = arg_info_list_base + 1; 04536 04537 if (arg_info_list_top >= arg_info_list_size) { 04538 enlarge_info_list_table(); 04539 } 04540 04541 IL_ARG_DESC_IDX(list_idx) = arg_info_list_top; 04542 arg_info_list[arg_info_list_top] = init_arg_info; 04543 arg_info_list[arg_info_list_top].ed = exp_desc; 04544 #else 04545 COPY_OPND(opnd, IL_OPND(list_idx)); 04546 find_opnd_line_and_column(&opnd, &line, &col); 04547 04548 NTR_IR_TBL(asg_idx); 04549 IR_OPR(asg_idx) = Io_Item_Type_Code_Opr; 04550 IR_TYPE_IDX(asg_idx) = exp_desc.type_idx; 04551 IR_LINE_NUM(asg_idx) = line; 04552 IR_COL_NUM(asg_idx) = col; 04553 04554 COPY_OPND(IR_OPND_L(asg_idx), opnd); 04555 IL_FLD(list_idx) = IR_Tbl_Idx; 04556 IL_IDX(list_idx) = asg_idx; 04557 04558 #endif 04559 04560 } 04561 } 04562 else { 04563 /* insert the Io_Item_Type_Code_Opr */ 04564 04565 COPY_OPND(opnd, IL_OPND(list_idx)); 04566 find_opnd_line_and_column(&opnd, &line, &col); 04567 04568 NTR_IR_TBL(asg_idx); 04569 IR_OPR(asg_idx) = Io_Item_Type_Code_Opr; 04570 IR_TYPE_IDX(asg_idx) = exp_desc.type_idx; 04571 IR_LINE_NUM(asg_idx) = line; 04572 IR_COL_NUM(asg_idx) = col; 04573 04574 COPY_OPND(IR_OPND_L(asg_idx), opnd); 04575 IL_FLD(list_idx) = IR_Tbl_Idx; 04576 IL_IDX(list_idx) = asg_idx; 04577 } 04578 } 04579 04580 list_idx = IL_NEXT_LIST_IDX(list_idx); 04581 } 04582 04583 EXIT: 04584 04585 if (needs_expansion) { 04586 number_of_functions = 1; 04587 } 04588 04589 if (have_seen_must_flatten) { 04590 io_item_must_flatten = TRUE; 04591 } 04592 04593 if (have_seen_constructor) { 04594 tree_has_constructor = TRUE; 04595 } 04596 04597 TRACE (Func_Exit, "io_list_semantics", NULL); 04598 04599 return(semantically_correct); 04600 04601 } /* io_list_semantics */ 04602 04603 /******************************************************************************\ 04604 |* *| 04605 |* Description: *| 04606 |* Create namelist descriptor. This is the description of the tables *| 04607 |* from the library people. *| 04608 |* *| 04609 |* The CFT90 namelist I/O READ and WRITE statements will generate *| 04610 |* namelist list table for single-call I/O interface: *| 04611 |* *| 04612 |* --------------------------------------------------- *| 04613 |* | reserved | pointer to namelist | *| 04614 |* |63 58|57 0| *| 04615 |* --------------------------------------------------- *| 04616 |* *| 04617 |* A namelist for single-call namelist I/O statements may contain the *| 04618 |* following items in the namelist: *| 04619 |* *| 04620 |* 1. scalar variables of type: *| 04621 |* a. integer *| 04622 |* b. logical *| 04623 |* c. real (single and double) *| 04624 |* d. complex (single and double) *| 04625 |* e. character *| 04626 |* f. typeless or Boolean *| 04627 |* g. derived type character (all character or mixed word and *| 04628 |* character) *| 04629 |* h. derived type word (all word-oriented) *| 04630 |* 2. array variables of type: *| 04631 |* a. integer *| 04632 |* b. logical *| 04633 |* c. real (single and double) *| 04634 |* d. complex (single and double) *| 04635 |* e. character *| 04636 |* f. typeless or Boolean *| 04637 |* g. derived type character (all character or mixed word and *| 04638 |* character) *| 04639 |* h. derived type word (all word-oriented) *| 04640 |* *| 04641 |* Pointers are not allowed in I/O lists or namelists. *| 04642 |* *| 04643 |* NAMELIST TABLE CONTENTS: *| 04644 |* *| 04645 |* The namelist group information will contain the following 2-word entry: *| 04646 |* ---------------------------------------------------------------------- *| 04647 |* 0 |version| reserved | icount | *| 04648 |* |63 61|60 16|15 0| *| 04649 |* ---------------------------------------------------------------------- *| 04650 |* 1 | fcd of namelist group name | *| 04651 |* ---------------------------------------------------------------------- *| 04652 |* *| 04653 |* The namelist group information will be followed by one or more namelist *| 04654 |* group_object_list items: *| 04655 |* ---------------------------------------------------------------------- *| 04656 |* 2 | valtype | reserved | *| 04657 |* |63 56|55 0| *| 04658 |* ---------------------------------------------------------------------- *| 04659 |* 3 | fcd of namelist group_object_list_item name | *| 04660 |* ---------------------------------------------------------------------- *| 04661 |* 4 | address of 1)scalar info or 2)array dopevector or 3)structure table | *| 04662 |* ---------------------------------------------------------------------- *| 04663 |* *| 04664 |* The dope vector is described in dopevec.h. The namelist scalar entry *| 04665 |* contains: *| 04666 |* ---------------------------------------------------------------------- *| 04667 |* 0 | reserved | type |dp| decde| intlen | decllen | *| 04668 |* |63 32|31 24|23|22 20|19 8|7 0| *| 04669 |* ---------------------------------------------------------------------- *| 04670 |* 1 | fortran character descriptor or address of noncharacter variable | *| 04671 |* ---------------------------------------------------------------------- *| 04672 |* *| 04673 |* Structures point to another namelist table which contains header word with *| 04674 |* a count of the number of entries in the structure and one or more namelist *| 04675 |* group_object_list entries for scalars, arrays, and other structures within *| 04676 |* the structure. *| 04677 |* ---------------------------------------------------------------------- *| 04678 |* 0 | reserved | structlen | *| 04679 |* |63 16|15 0| *| 04680 |* ---------------------------------------------------------------------- *| 04681 |* 1 | address of dopevector if structure is an array, else addr of strct | *| 04682 |* ---------------------------------------------------------------------- *| 04683 |* 2 | valtype | reserved | *| 04684 |* |63 56|55 0| *| 04685 |* ---------------------------------------------------------------------- *| 04686 |* 3 | fcd of namelist group_object_list_item name | *| 04687 |* ---------------------------------------------------------------------- *| 04688 |* 4 | address of 1)scalar info or 2)array dopevector or 3)structure entries| *| 04689 |* ---------------------------------------------------------------------- *| 04690 |* *| 04691 |* where: *| 04692 |* *| 04693 |* Namelist Group Information: *| 04694 |* *| 04695 |* WORD 0: *| 04696 |* version: *| 04697 |* word 0, bits 61-63 *| 04698 |* 1 = current version *| 04699 |* *| 04700 |* reserved for future development: *| 04701 |* word 0, bits 16-60 = 0 *| 04702 |* *| 04703 |* icount is the number of namelist group_object_list items in the *| 04704 |* namelist table. *| 04705 |* word 0, bits 0-15 *| 04706 |* *| 04707 |* WORD 1: *| 04708 |* fcd of namelist group name: *| 04709 |* word 1, bits 0-63 *| 04710 |* *| 04711 |* Namelist group_object_list_item information: *| 04712 |* *| 04713 |* WORD 0: *| 04714 |* valtype indicates type of iolist entry: *| 04715 |* word 0, bits 56-63 *| 04716 |* 0 = unused *| 04717 |* 1 = scalar, no pointers *| 04718 |* 2 = dope vector for array, no pointers *| 04719 |* 3 = io loop (NOT USED FOR NAMELIST) *| 04720 |* 4 = structure as scalar, no pointers *| 04721 |* 5 = structure as array, no pointers *| 04722 |* *| 04723 |* reserved for future development: *| 04724 |* word 0, bits 0-63 = 0 *| 04725 |* *| 04726 |* WORD 1: *| 04727 |* fcd of namelist group_object_list_item name: *| 04728 |* word 1, bits 0-63 *| 04729 |* *| 04730 |* WORD 2: *| 04731 |* address of namelist 1) scalar information, 2) dopevector, *| 04732 |* 3) structure *| 04733 |* table *| 04734 |* word 2, bits 0-63 *| 04735 |* *| 04736 |* Namelist scalar information contains: *| 04737 |* *| 04738 |* WORD 0: *| 04739 |* Fortran 90 type word *| 04740 |* *| 04741 |* WORD 1: *| 04742 |* fcd of scalar character item or addr of noncharacter scalar item: *| 04743 |* word 1, bits 0-63 *| 04744 |* *| 04745 |* Namelist structure information contains: *| 04746 |* *| 04747 |* WORD 0: *| 04748 |* reserved for future development: *| 04749 |* word 0, bits 17-63 = 0 *| 04750 |* *| 04751 |* structlen is number of structure components in this structure: *| 04752 |* word 0, bits 0-16 *| 04753 |* *| 04754 |* WORD 1: *| 04755 |* address of dopevector when structure is an array; *| 04756 |* else address of scalar structure. *| 04757 |* word 1, bits 0-63 *| 04758 |* *| 04759 |* WORD n*(1-3) where n is the number of structure components in structure: *| 04760 |* *| 04761 |* Namelist group_object_list_item[n] *| 04762 |* *| 04763 |* *| 04764 |* Input parameters: *| 04765 |* namelist_attr - idx to namelist group attr *| 04766 |* *| 04767 |* Output parameters: *| 04768 |* NONE *| 04769 |* *| 04770 |* Returns: *| 04771 |* NOTHING *| 04772 |* *| 04773 \******************************************************************************/ 04774 04775 void create_namelist_descriptor(int namelist_attr) 04776 04777 { 04778 int asg_idx; 04779 int col; 04780 expr_arg_type exp_desc; 04781 int head_idx; 04782 long_type idx_constant; 04783 boolean in_module = FALSE; 04784 int item_attr; 04785 opnd_type l_opnd; 04786 int line; 04787 int list_idx; 04788 int loc_idx; 04789 long num; 04790 int offset; 04791 boolean ok; 04792 opnd_type opnd; 04793 opnd_type opnd2; 04794 int save_curr_stmt_sh_idx; 04795 int sh_idx; 04796 int size; 04797 int sn_idx; 04798 int sub_idx; 04799 int stack_grp_tbl_idx; 04800 int static_grp_tbl_idx; 04801 int tail_idx; 04802 long_type the_constant[2]; 04803 int tmp_idx; 04804 int type_idx; 04805 int val_type; 04806 04807 nmlist_group_hdr *group_hdr_ptr; 04808 nmlist_goli_t *goli_ptr; 04809 04810 # ifdef _INIT_RELOC_BASE_OFFSET 04811 int attr_idx; 04812 # endif 04813 04814 04815 TRACE (Func_Entry, "create_namelist_descriptor", NULL); 04816 04817 line = AT_DEF_LINE(namelist_attr); 04818 col = AT_DEF_COLUMN(namelist_attr); 04819 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 04820 04821 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) { 04822 in_module = TRUE; 04823 } 04824 04825 # if defined(GENERATE_WHIRL) 04826 type_idx = SA_INTEGER_DEFAULT_TYPE; 04827 # else 04828 type_idx = CG_INTEGER_DEFAULT_TYPE; 04829 # endif 04830 04831 /*****************************************\ 04832 |* create static namelist group tbl attr *| 04833 \*****************************************/ 04834 04835 if (two_word_fcd) { 04836 size = NML_GRP_HDR_SIZE_FCD2 + 04837 (NML_GRP_ITEM_SIZE_FCD2 * ATN_NUM_NAMELIST(namelist_attr)); 04838 } 04839 else { 04840 size = NML_GRP_HDR_SIZE + 04841 (NML_GRP_ITEM_SIZE * ATN_NUM_NAMELIST(namelist_attr)); 04842 } 04843 04844 # if defined(GENERATE_WHIRL) 04845 /* the version item is always 64 bits */ 04846 /* add one for the header version, and one for each item entry */ 04847 if (TYP_LINEAR(type_idx) == Integer_4) { 04848 size += 1 + ATN_NUM_NAMELIST(namelist_attr); 04849 } 04850 # endif 04851 04852 static_grp_tbl_idx = gen_static_integer_array_tmp(size, line, col); 04853 04854 if (! in_module) { 04855 /****************************************\ 04856 |* create stack namelist group tbl attr *| 04857 \****************************************/ 04858 04859 stack_grp_tbl_idx = gen_compiler_tmp(line,col, 04860 Priv, TRUE); 04861 ATD_TYPE_IDX(stack_grp_tbl_idx) = ATD_TYPE_IDX(static_grp_tbl_idx); 04862 ATD_STOR_BLK_IDX(stack_grp_tbl_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 04863 04864 /* This new tmp is fully created, so does not need decl_semantics */ 04865 04866 AT_SEMANTICS_DONE(stack_grp_tbl_idx) = TRUE; 04867 04868 ATD_ARRAY_IDX(stack_grp_tbl_idx) = ATD_ARRAY_IDX(static_grp_tbl_idx); 04869 } 04870 04871 04872 sh_idx = ntr_sh_tbl(); 04873 SH_STMT_TYPE(sh_idx) = Assignment_Stmt; 04874 SH_GLB_LINE(sh_idx) = line; 04875 SH_COL_NUM(sh_idx) = col; 04876 SH_COMPILER_GEN(sh_idx) = TRUE; 04877 SH_P2_SKIP_ME(sh_idx) = TRUE; 04878 head_idx = sh_idx; 04879 tail_idx = sh_idx; 04880 curr_stmt_sh_idx = sh_idx; 04881 04882 if (! in_module) { 04883 /***********************************\ 04884 |* copy static attr to stack attr. *| 04885 \***********************************/ 04886 04887 04888 gen_opnd(&opnd, stack_grp_tbl_idx, AT_Tbl_Idx, line, col); 04889 ok = gen_whole_subscript(&opnd, &exp_desc); 04890 04891 gen_opnd(&opnd2, static_grp_tbl_idx, AT_Tbl_Idx, line, col); 04892 ok = gen_whole_subscript(&opnd2, &exp_desc); 04893 04894 asg_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 04895 Asg_Opr, type_idx, line, col, 04896 OPND_FLD(opnd2), OPND_IDX(opnd2)); 04897 04898 gen_sh(After, Assignment_Stmt, line, col, 04899 FALSE, FALSE, TRUE); 04900 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 04901 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 04902 } 04903 04904 /* set first word to version and count */ 04905 /* this can be two words on IRIX with -n32 */ 04906 04907 idx_constant = 1; 04908 04909 the_constant[0] = 0; 04910 the_constant[1] = 0; 04911 04912 group_hdr_ptr = (nmlist_group_hdr *)the_constant; 04913 04914 # if defined(_BITFIELD_RIGHT_TO_LEFT) /* Most x86 platforms */ 04915 the_constant[0] = 1 | (ATN_NUM_NAMELIST(namelist_attr) << 16) ; 04916 # else 04917 group_hdr_ptr->version = 1; 04918 group_hdr_ptr->icount = ATN_NUM_NAMELIST(namelist_attr); 04919 # endif 04920 04921 gen_opnd(&opnd, 04922 ntr_const_tbl((sizeof(nmlist_group_hdr) == 8) ? Integer_8 : 04923 Integer_4, 04924 FALSE, 04925 the_constant), 04926 CN_Tbl_Idx, 04927 line, 04928 col); 04929 04930 gen_array_element_init(static_grp_tbl_idx, 04931 &idx_constant, 04932 &opnd, 04933 Init_Opr, 04934 NULL_IDX); 04935 04936 04937 /***********************************************\ 04938 |* set next word to fcd to namelist group name *| 04939 \***********************************************/ 04940 04941 put_string_in_tmp(AT_OBJ_NAME_PTR(namelist_attr), 04942 AT_NAME_LEN(namelist_attr), 04943 &opnd); 04944 04945 # ifdef _INIT_RELOC_BASE_OFFSET 04946 if (in_module) { 04947 04948 /* Check to make sure that SB_FIRST_ATTR_IDX has a value.*/ 04949 /* Create a temp as an overlay for the first object if */ 04950 /* there is no FIRST attr. */ 04951 04952 attr_idx = find_left_attr(&opnd); 04953 04954 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) { 04955 set_sb_first_attr_idx(attr_idx); 04956 } 04957 } 04958 # endif 04959 04960 /* tmp is character */ 04961 04962 # if defined(GENERATE_WHIRL) 04963 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 04964 Loc_Opr, CRI_Ch_Ptr_8, line, col, 04965 NO_Tbl_Idx, NULL_IDX); 04966 # else 04967 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 04968 Aloc_Opr, CRI_Ch_Ptr_8, line, col, 04969 NO_Tbl_Idx, NULL_IDX); 04970 # endif 04971 04972 04973 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col); 04974 04975 gen_array_element_init(in_module ? static_grp_tbl_idx : stack_grp_tbl_idx, 04976 &idx_constant, 04977 &opnd, 04978 in_module ? Init_Reloc_Opr : Asg_Opr, 04979 NULL_IDX); 04980 04981 04982 if (two_word_fcd) { 04983 /* fill in the length explicitly */ 04984 04985 if (char_len_in_bytes) { 04986 /* length is in bytes on solaris */ 04987 num = (long) AT_NAME_LEN(namelist_attr); 04988 } 04989 else { 04990 /* length is in bits on mpp. */ 04991 num = (long) AT_NAME_LEN(namelist_attr) * CHAR_BIT; 04992 } 04993 04994 gen_opnd(&opnd, 04995 C_INT_TO_CN(type_idx, num), 04996 CN_Tbl_Idx, 04997 line, 04998 col); 04999 05000 gen_array_element_init(static_grp_tbl_idx, 05001 &idx_constant, 05002 &opnd, 05003 Init_Opr, 05004 NULL_IDX); 05005 05006 } 05007 05008 sn_idx = ATN_FIRST_NAMELIST_IDX(namelist_attr); 05009 05010 while (sn_idx != NULL_IDX) { 05011 05012 item_attr = SN_ATTR_IDX(sn_idx); 05013 05014 while (AT_ATTR_LINK(item_attr) && 05015 ! AT_IGNORE_ATTR_LINK(item_attr)) { 05016 item_attr = AT_ATTR_LINK(item_attr); 05017 } 05018 05019 05020 /***************************************************\ 05021 |* set the valtype in the first word of item entry *| 05022 \***************************************************/ 05023 05024 if (TYP_TYPE(ATD_TYPE_IDX(item_attr)) == Structure) { 05025 05026 if (ATD_ARRAY_IDX(item_attr)) { 05027 val_type = NML_VALTYPE_STRCT_ARRAY; 05028 } 05029 else { 05030 val_type = NML_VALTYPE_STRCT; 05031 } 05032 } 05033 else if (ATD_ARRAY_IDX(item_attr)) { 05034 val_type = NML_VALTYPE_ARRAY; 05035 } 05036 else { 05037 val_type = NML_VALTYPE_SCALAR; 05038 } 05039 05040 05041 # if defined(_BITFIELD_RIGHT_TO_LEFT) /* Most x86 platforms */ 05042 the_constant[0] = val_type; 05043 # else 05044 05045 the_constant[0] = 0; 05046 the_constant[1] = 0; 05047 05048 goli_ptr = (nmlist_goli_t *)the_constant; 05049 05050 goli_ptr->valtype = val_type; 05051 # endif 05052 05053 gen_opnd(&opnd, 05054 ntr_const_tbl((sizeof(nmlist_goli_t) == 8) ? Integer_8 : 05055 Integer_4, 05056 FALSE, 05057 the_constant), 05058 CN_Tbl_Idx, 05059 line, 05060 col); 05061 05062 gen_array_element_init(static_grp_tbl_idx, 05063 &idx_constant, 05064 &opnd, 05065 Init_Opr, 05066 NULL_IDX); 05067 05068 05069 /***************************************\ 05070 |* set the fcd for the group item name *| 05071 \***************************************/ 05072 05073 put_string_in_tmp(AT_OBJ_NAME_PTR(item_attr), 05074 AT_NAME_LEN(item_attr), 05075 &opnd); 05076 05077 # ifdef _INIT_RELOC_BASE_OFFSET 05078 if (in_module) { 05079 05080 /* Check to make sure that SB_FIRST_ATTR_IDX has a value.*/ 05081 /* Create a temp as an overlay for the first object if */ 05082 /* there is no FIRST attr. */ 05083 05084 attr_idx = find_left_attr(&opnd); 05085 05086 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) { 05087 set_sb_first_attr_idx(attr_idx); 05088 } 05089 } 05090 # endif 05091 05092 /* tmp is character */ 05093 05094 # if defined(GENERATE_WHIRL) 05095 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 05096 Loc_Opr, CRI_Ch_Ptr_8, line, col, 05097 NO_Tbl_Idx, NULL_IDX); 05098 # else 05099 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 05100 Aloc_Opr, CRI_Ch_Ptr_8, line, col, 05101 NO_Tbl_Idx, NULL_IDX); 05102 # endif 05103 05104 05105 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col); 05106 05107 gen_array_element_init(in_module ? static_grp_tbl_idx:stack_grp_tbl_idx, 05108 &idx_constant, 05109 &opnd, 05110 in_module ? Init_Reloc_Opr : Asg_Opr, 05111 NULL_IDX); 05112 05113 05114 if (two_word_fcd) { 05115 /* fill in the length explicitly */ 05116 05117 if (char_len_in_bytes) { 05118 /* length is in bytes on solaris */ 05119 num = (long) AT_NAME_LEN(item_attr); 05120 } 05121 else { 05122 /* length is in bits on mpp. */ 05123 num = (long) AT_NAME_LEN(item_attr) * CHAR_BIT; 05124 } 05125 05126 gen_opnd(&opnd, 05127 C_INT_TO_CN(type_idx, num), 05128 CN_Tbl_Idx, 05129 line, 05130 col); 05131 05132 gen_array_element_init(static_grp_tbl_idx, 05133 &idx_constant, 05134 &opnd, 05135 Init_Opr, 05136 NULL_IDX); 05137 05138 } 05139 05140 05141 /*******************************************\ 05142 |* Now for the varieties of the third word *| 05143 \*******************************************/ 05144 05145 gen_opnd(&opnd, item_attr, AT_Tbl_Idx, line, col); 05146 05147 switch (val_type) { 05148 case NML_VALTYPE_SCALAR : 05149 /* get scalar type tbl */ 05150 loc_idx = gen_ir(AT_Tbl_Idx, create_scalar_type_tbl(&opnd, 05151 in_module), 05152 Loc_Opr, CRI_Ptr_8, line, col, 05153 NO_Tbl_Idx, NULL_IDX); 05154 05155 break; 05156 05157 case NML_VALTYPE_ARRAY : 05158 /* get dope vector */ 05159 05160 exp_desc = init_exp_desc; 05161 ok = gen_whole_subscript(&opnd, &exp_desc); 05162 05163 if (in_module) { 05164 namelist_static_dv_whole_def(&l_opnd, &opnd); 05165 } 05166 else { 05167 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 05168 ATD_TYPE_IDX(tmp_idx) = ATD_TYPE_IDX(item_attr); 05169 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 05170 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 05171 05172 /* Positions 1-7 are deferred shape entries in the bd table. */ 05173 05174 ATD_ARRAY_IDX(tmp_idx) = exp_desc.rank; 05175 ATD_IM_A_DOPE(tmp_idx) = FALSE; 05176 OPND_FLD(l_opnd) = AT_Tbl_Idx; 05177 OPND_IDX(l_opnd) = tmp_idx; 05178 OPND_LINE_NUM(l_opnd) = line; 05179 OPND_COL_NUM(l_opnd) = col; 05180 05181 exp_desc.type_idx = ATD_TYPE_IDX(item_attr); 05182 exp_desc.type = TYP_TYPE(exp_desc.type_idx); 05183 exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx); 05184 05185 if (exp_desc.type == Character) { 05186 exp_desc.char_len.fld = TYP_FLD(exp_desc.type_idx); 05187 exp_desc.char_len.idx = TYP_IDX(exp_desc.type_idx); 05188 } 05189 gen_dv_whole_def(&l_opnd, &opnd, &exp_desc); 05190 } 05191 05192 # if defined(GENERATE_WHIRL) 05193 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd), 05194 Loc_Opr, CRI_Ptr_8, line, col, 05195 NO_Tbl_Idx, NULL_IDX); 05196 # else 05197 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd), 05198 in_module ? Aloc_Opr : Loc_Opr, CRI_Ptr_8, line, col, 05199 NO_Tbl_Idx, NULL_IDX); 05200 # endif 05201 05202 break; 05203 05204 case NML_VALTYPE_STRCT : 05205 case NML_VALTYPE_STRCT_ARRAY : 05206 /* get struct tbl */ 05207 loc_idx = gen_ir(AT_Tbl_Idx, create_strct_tbl(&opnd, in_module), 05208 Loc_Opr, CRI_Ptr_8, line, col, 05209 NO_Tbl_Idx, NULL_IDX); 05210 05211 break; 05212 } 05213 05214 # ifdef _INIT_RELOC_BASE_OFFSET 05215 if (in_module) { 05216 05217 /* Check to make sure that SB_FIRST_ATTR_IDX has a value.*/ 05218 /* Create a temp as an overlay for the first object if */ 05219 /* there is no FIRST attr. */ 05220 05221 attr_idx = find_left_attr(&(IR_OPND_L(loc_idx))); 05222 05223 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) { 05224 set_sb_first_attr_idx(attr_idx); 05225 } 05226 } 05227 # endif 05228 05229 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col); 05230 05231 gen_array_element_init(in_module ? static_grp_tbl_idx:stack_grp_tbl_idx, 05232 &idx_constant, 05233 &opnd, 05234 in_module ? Init_Reloc_Opr : Asg_Opr, 05235 NULL_IDX); 05236 05237 05238 sn_idx = SN_SIBLING_LINK(sn_idx); 05239 } 05240 05241 ATN_NAMELIST_DESC(namelist_attr) = in_module ? static_grp_tbl_idx : 05242 stack_grp_tbl_idx; 05243 05244 tail_idx = curr_stmt_sh_idx; 05245 05246 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 05247 05248 # ifdef _DEBUG 05249 if (SH_IR_IDX(head_idx) != NULL_IDX) { 05250 PRINTMSG(line, 626, Internal, col, 05251 "empty head_idx", "create_namelist_descriptor"); 05252 } 05253 # endif 05254 head_idx = SH_NEXT_IDX(head_idx); 05255 FREE_SH_NODE(SH_PREV_IDX(head_idx)); 05256 SH_PREV_IDX(head_idx) = NULL_IDX; 05257 05258 insert_sh_chain_after_entries(head_idx, tail_idx); 05259 05260 TRACE (Func_Exit, "create_namelist_descriptor", NULL); 05261 05262 return; 05263 05264 } /* create_namelist_descriptor */ 05265 05266 /******************************************************************************\ 05267 |* *| 05268 |* Description: *| 05269 |* Create a whole def of a dope vector that is in a module block. *| 05270 |* This is for namelist tables. It is a complete definition using *| 05271 |* Init_Opr and Init_Reloc_Opr. There can be no runtime assignments. *| 05272 |* *| 05273 |* Input parameters: *| 05274 |* NONE *| 05275 |* *| 05276 |* Output parameters: *| 05277 |* NONE *| 05278 |* *| 05279 |* Returns: *| 05280 |* NOTHING *| 05281 |* *| 05282 \******************************************************************************/ 05283 05284 static void namelist_static_dv_whole_def(opnd_type *l_opnd, 05285 opnd_type *r_opnd) 05286 05287 { 05288 int asg_idx; 05289 int attr_idx; 05290 int col; 05291 int const_idx; 05292 long_type constant[2]; 05293 int dope_idx = NULL_IDX; 05294 ext_dope_type *dv_ptr; 05295 int i; 05296 long_type idx_constant; 05297 int line; 05298 int list_idx; 05299 int loc_idx; 05300 int num_elements; 05301 int num_words; 05302 int offset; 05303 opnd_type opnd; 05304 long_type rank; 05305 int rank_idx = NULL_IDX; 05306 int sub_idx; 05307 long_type the_constant[2]; 05308 int tmp_idx; 05309 int type_idx; 05310 int type_idx2; 05311 int words_in_address = 1; 05312 05313 # ifdef _INIT_RELOC_BASE_OFFSET 05314 int attr_idx2; 05315 # endif 05316 05317 05318 TRACE (Func_Entry, "namelist_static_dv_whole_def", NULL); 05319 05320 # if defined(GENERATE_WHIRL) 05321 type_idx2 = SA_INTEGER_DEFAULT_TYPE; 05322 05323 if (type_idx2 == Integer_8) { 05324 words_in_address = 2; 05325 } 05326 # else 05327 type_idx2 = CG_INTEGER_DEFAULT_TYPE; 05328 # endif 05329 05330 attr_idx = find_base_attr(r_opnd, &line, &col); 05331 05332 rank = (long_type) ((ATD_ARRAY_IDX(attr_idx) ? 05333 BD_RANK(ATD_ARRAY_IDX(attr_idx)) :0)); 05334 05335 num_words = DV_HD_WORD_SIZE + (rank * DV_DIM_WORD_SIZE); 05336 num_elements = num_words; 05337 05338 # if defined(GENERATE_WHIRL) 05339 if (TYP_LINEAR(type_idx2) == Integer_8) { 05340 num_elements = num_elements / 2; 05341 } 05342 # endif 05343 05344 tmp_idx = gen_static_integer_array_tmp(num_elements, line, col); 05345 05346 gen_opnd(l_opnd, tmp_idx, AT_Tbl_Idx, line, col); 05347 05348 /* Start the initialization of the dope vector at the second element */ 05349 05350 idx_constant = 2; 05351 05352 /* We don't want to initialize the Base address in this constant */ 05353 /* It gets a Init_Reloc_Opr and ccg doesn't allow multiple inits */ 05354 /* when one is a reloc init. So ask for (num_words - 1). */ 05355 05356 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 05357 TYP_TYPE(TYP_WORK_IDX) = Typeless; 05358 TYP_BIT_LEN(TYP_WORK_IDX) = (num_words - words_in_address) * 05359 TARGET_BITS_PER_WORD; 05360 type_idx = ntr_type_tbl(); 05361 05362 const_idx = ntr_const_tbl(type_idx, FALSE, NULL); 05363 05364 gen_opnd(&opnd, const_idx, CN_Tbl_Idx, line, col); 05365 05366 gen_array_element_init(tmp_idx, 05367 &idx_constant, 05368 &opnd, 05369 Init_Opr, 05370 NULL_IDX); 05371 05372 /********************\ 05373 |* set BASE address *| 05374 \********************/ 05375 05376 # ifdef _INIT_RELOC_BASE_OFFSET 05377 offset = change_to_base_and_offset(r_opnd, &opnd); 05378 # else 05379 make_base_subtree(r_opnd, &opnd, &rank_idx, &dope_idx); 05380 offset = NULL_IDX; 05381 # endif 05382 05383 05384 # if defined(GENERATE_WHIRL) 05385 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 05386 Loc_Opr, TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character ? 05387 CRI_Ch_Ptr_8 : CRI_Ptr_8, line, col, 05388 NO_Tbl_Idx, NULL_IDX); 05389 # else 05390 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 05391 Aloc_Opr, TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character ? 05392 CRI_Ch_Ptr_8 : CRI_Ptr_8, line, col, 05393 NO_Tbl_Idx, NULL_IDX); 05394 # endif 05395 05396 05397 # ifdef _INIT_RELOC_BASE_OFFSET 05398 /* Check to make sure that SB_FIRST_ATTR_IDX has a value.*/ 05399 /* Create a temp as an overlay for the first object if */ 05400 /* there is no FIRST attr. */ 05401 05402 attr_idx2 = find_left_attr(&opnd); 05403 05404 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx2)) == NULL_IDX) { 05405 set_sb_first_attr_idx(attr_idx2); 05406 } 05407 # endif 05408 05409 05410 # ifdef _TRANSFORM_CHAR_SEQUENCE 05411 # ifdef _TARGET_OS_UNICOS 05412 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure && 05413 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) { 05414 05415 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 05416 COPY_OPND(opnd, IR_OPND_L(loc_idx)); 05417 transform_char_sequence_ref(&opnd, ATD_TYPE_IDX(attr_idx)); 05418 COPY_OPND(IR_OPND_L(loc_idx), opnd); 05419 } 05420 # endif 05421 # endif 05422 05423 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col); 05424 05425 /* reset idx_constant to 1 for the base address */ 05426 idx_constant = 1; 05427 gen_array_element_init(tmp_idx, 05428 &idx_constant, 05429 &opnd, 05430 Init_Reloc_Opr, 05431 offset); 05432 05433 05434 /* We must set the dv_ptr to the word before the actual constant */ 05435 /* since it has a "Base address" component and the constant doesn't */ 05436 05437 dv_ptr = (ext_dope_type *)&(CP_CONSTANT( 05438 CN_POOL_IDX(const_idx) - words_in_address)); 05439 type_idx = ATD_TYPE_IDX(attr_idx); 05440 05441 /* the entire constant is initialized to 0's */ 05442 /* so just fill in the non zero parts. */ 05443 05444 /******************\ 05445 |* set ASSOC flag *| 05446 \******************/ 05447 05448 DV_SET_ASSOC(*dv_ptr, 1); 05449 05450 05451 /*************\ 05452 |* EL_LEN *| 05453 \*************/ 05454 05455 if (TYP_TYPE(type_idx) == Structure) { 05456 05457 if (compare_cn_and_value(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)), 05458 MAX_DV_EL_LEN, 05459 Ge_Opr)) { 05460 PRINTMSG(line, 1174, Error, col, 05461 ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)), 05462 MAX_DV_EL_LEN); 05463 DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN); 05464 } 05465 else { 05466 05467 gen_opnd(&opnd, 05468 ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)), 05469 CN_Tbl_Idx, 05470 line, 05471 col); 05472 05473 cast_opnd_to_type_idx(&opnd, type_idx2); 05474 05475 # if defined(GENERATE_WHIRL) 05476 if (TYP_LINEAR(type_idx2) == Integer_8) { 05477 DV_SET_EL_LEN(*dv_ptr, *(long long *)&(CN_CONST(OPND_IDX(opnd)))); 05478 } 05479 else { 05480 DV_SET_EL_LEN(*dv_ptr, CN_CONST(OPND_IDX(opnd))); 05481 } 05482 # else 05483 DV_SET_EL_LEN(*dv_ptr, CN_CONST(OPND_IDX(opnd))); 05484 # endif 05485 } 05486 } 05487 else if (TYP_TYPE(type_idx) == Character) { 05488 05489 if (TYP_FLD(type_idx) == CN_Tbl_Idx) { 05490 05491 gen_opnd(&opnd, 05492 TYP_IDX(type_idx), 05493 CN_Tbl_Idx, 05494 line, 05495 col); 05496 05497 cast_opnd_to_type_idx(&opnd, type_idx2); 05498 05499 05500 if (! char_len_in_bytes) { 05501 05502 /* length must be in bits for every platform BUT solaris */ 05503 if (folder_driver((char *)&CN_CONST(OPND_IDX(opnd)), 05504 type_idx2, 05505 (char *)&CN_CONST(CN_INTEGER_CHAR_BIT_IDX), 05506 CN_TYPE_IDX(CN_INTEGER_CHAR_BIT_IDX), 05507 the_constant, 05508 &type_idx2, 05509 line, 05510 col, 05511 2, 05512 Mult_Opr)) { 05513 } 05514 05515 gen_opnd(&opnd, 05516 ntr_const_tbl(type_idx2, 05517 FALSE, 05518 the_constant), 05519 CN_Tbl_Idx, 05520 line, 05521 col); 05522 } 05523 05524 05525 if (char_len_in_bytes) { 05526 05527 if (compare_cn_and_value(TYP_IDX(type_idx), 05528 MAX_DV_EL_LEN, 05529 Ge_Opr)) { 05530 PRINTMSG(line, 1174, Error, col, 05531 TYP_IDX(type_idx), MAX_DV_EL_LEN); 05532 } 05533 } 05534 else { 05535 05536 if (compare_cn_and_value(TYP_IDX(type_idx), 05537 MAX_DV_EL_LEN/8, 05538 Ge_Opr)) { 05539 PRINTMSG(line, 1174, Error, col, 05540 TYP_IDX(type_idx), 05541 MAX_DV_EL_LEN/8); 05542 } 05543 } 05544 05545 # if defined(GENERATE_WHIRL) 05546 if (TYP_LINEAR(type_idx2) == Integer_8) { 05547 DV_SET_EL_LEN(*dv_ptr, *(long long *)&(CN_CONST(OPND_IDX(opnd)))); 05548 } 05549 else { 05550 DV_SET_EL_LEN(*dv_ptr, CN_CONST(OPND_IDX(opnd))); 05551 } 05552 # else 05553 DV_SET_EL_LEN(*dv_ptr, CN_CONST(OPND_IDX(opnd))); 05554 # endif 05555 } 05556 else { 05557 PRINTMSG(line, 630, Internal, col); 05558 } 05559 } 05560 else { 05561 DV_SET_EL_LEN(*dv_ptr, storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 05562 } 05563 05564 /*************\ 05565 |* P_OR_A *| 05566 \*************/ 05567 05568 if (ATD_ALLOCATABLE(attr_idx)) { 05569 DV_SET_P_OR_A(*dv_ptr, 2); 05570 } 05571 else if (ATD_POINTER(attr_idx)) { 05572 DV_SET_P_OR_A(*dv_ptr, 1); 05573 } 05574 05575 /*************\ 05576 |* N_DIM *| 05577 \*************/ 05578 05579 DV_SET_NUM_DIMS(*dv_ptr, rank); 05580 05581 /*************\ 05582 |* TYPE_CODE *| 05583 \*************/ 05584 05585 make_io_type_code(type_idx, constant); 05586 # ifdef _TYPE_CODE_64_BIT 05587 DV_SET_TYPE_CODE(*dv_ptr, *(f90_type_t *)constant); 05588 # else 05589 DV_SET_TYPE_CODE(*dv_ptr, *constant); 05590 # endif 05591 05592 for (i = 0; i < rank; i++) { 05593 05594 /************************************\ 05595 |* set LOW_BOUND for each dimension *| 05596 \************************************/ 05597 05598 gen_opnd(&opnd, 05599 BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), i + 1), 05600 CN_Tbl_Idx, 05601 line, 05602 col); 05603 05604 cast_opnd_to_type_idx(&opnd, type_idx2); 05605 05606 # if defined(GENERATE_WHIRL) 05607 if (TYP_LINEAR(type_idx2) == Integer_8) { 05608 DV_SET_LOW_BOUND(*dv_ptr,i, 05609 *(long long *)&(CN_CONST(OPND_IDX(opnd)))); 05610 } 05611 else { 05612 DV_SET_LOW_BOUND(*dv_ptr,i, CN_CONST(OPND_IDX(opnd))); 05613 } 05614 # else 05615 DV_SET_LOW_BOUND(*dv_ptr,i, CN_CONST(OPND_IDX(opnd))); 05616 # endif 05617 05618 /*********************************\ 05619 |* set EXTENT for each dimension *| 05620 \*********************************/ 05621 05622 gen_opnd(&opnd, 05623 BD_XT_IDX(ATD_ARRAY_IDX(attr_idx), i + 1), 05624 CN_Tbl_Idx, 05625 line, 05626 col); 05627 05628 cast_opnd_to_type_idx(&opnd, type_idx2); 05629 05630 # if defined(GENERATE_WHIRL) 05631 if (TYP_LINEAR(type_idx2) == Integer_8) { 05632 DV_SET_EXTENT(*dv_ptr,i, 05633 *(long long *)&(CN_CONST(OPND_IDX(opnd)))); 05634 } 05635 else { 05636 DV_SET_EXTENT(*dv_ptr,i, CN_CONST(OPND_IDX(opnd))); 05637 } 05638 # else 05639 DV_SET_EXTENT(*dv_ptr,i, CN_CONST(OPND_IDX(opnd))); 05640 # endif 05641 05642 /**************************************\ 05643 |* set STRIDE_MULT for each dimension *| 05644 \**************************************/ 05645 05646 gen_opnd(&opnd, 05647 BD_SM_IDX(ATD_ARRAY_IDX(attr_idx), i + 1), 05648 CN_Tbl_Idx, 05649 line, 05650 col); 05651 05652 cast_opnd_to_type_idx(&opnd, type_idx2); 05653 05654 # if defined(GENERATE_WHIRL) 05655 if (TYP_LINEAR(type_idx2) == Integer_8) { 05656 DV_SET_STRIDE_MULT(*dv_ptr,i, 05657 *(long long *)&(CN_CONST(OPND_IDX(opnd)))); 05658 } 05659 else { 05660 DV_SET_STRIDE_MULT(*dv_ptr,i, CN_CONST(OPND_IDX(opnd))); 05661 } 05662 # else 05663 DV_SET_STRIDE_MULT(*dv_ptr,i, CN_CONST(OPND_IDX(opnd))); 05664 # endif 05665 05666 } 05667 05668 TRACE (Func_Exit, "namelist_static_dv_whole_def", NULL); 05669 05670 return; 05671 05672 } /* namelist_static_dv_whole_def */ 05673 05674 /******************************************************************************\ 05675 |* *| 05676 |* Description: *| 05677 |* create the two word scalar type tbl entry. It is described in the *| 05678 |* description for create_namelist_descriptor. *| 05679 |* *| 05680 |* Input parameters: *| 05681 |* NONE *| 05682 |* *| 05683 |* Output parameters: *| 05684 |* NONE *| 05685 |* *| 05686 |* Returns: *| 05687 |* NOTHING *| 05688 |* *| 05689 \******************************************************************************/ 05690 05691 static int create_scalar_type_tbl(opnd_type *opnd, 05692 boolean in_module) 05693 05694 { 05695 int attr_idx; 05696 int asg_idx; 05697 int base_attr; 05698 int col; 05699 expr_arg_type exp_desc; 05700 long_type idx_constant; 05701 int line; 05702 int list_idx; 05703 int loc_idx; 05704 int offset; 05705 boolean ok; 05706 opnd_type opnd2; 05707 int sub_idx; 05708 long_type the_constant[2]; 05709 long64 num; 05710 int tmp_idx; 05711 int type_idx; 05712 05713 TRACE (Func_Entry, "create_scalar_type_tbl", NULL); 05714 05715 base_attr = find_base_attr(opnd, &line, &col); 05716 05717 /**********************************\ 05718 |* create scalar type tbl attr *| 05719 \**********************************/ 05720 05721 # if defined(GENERATE_WHIRL) 05722 type_idx = SA_INTEGER_DEFAULT_TYPE; 05723 # else 05724 type_idx = CG_INTEGER_DEFAULT_TYPE; 05725 # endif 05726 05727 if (in_module) { 05728 tmp_idx = gen_compiler_tmp(line,col, Shared, TRUE); 05729 ATD_TYPE_IDX(tmp_idx) = type_idx; 05730 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 05731 05732 ATD_SAVED(tmp_idx) = TRUE; 05733 ATD_DATA_INIT(tmp_idx) = TRUE; 05734 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 05735 } 05736 else { 05737 tmp_idx = gen_compiler_tmp(line,col, Priv, TRUE); 05738 ATD_TYPE_IDX(tmp_idx) = type_idx; 05739 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 05740 05741 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 05742 } 05743 05744 exp_desc.type = Integer; 05745 exp_desc.type_idx = type_idx; 05746 exp_desc.linear_type = TYP_LINEAR(type_idx); 05747 exp_desc.rank = 1; 05748 exp_desc.shape[0].fld = CN_Tbl_Idx; 05749 05750 if (two_word_fcd) { 05751 num = NML_SCALAR_ENTRY_SIZE_FCD2; 05752 } 05753 else { 05754 num = NML_SCALAR_ENTRY_SIZE; 05755 } 05756 05757 # if defined(GENERATE_WHIRL) 05758 if (TYP_LINEAR(type_idx) == Integer_4) { 05759 num++; 05760 } 05761 # endif 05762 05763 exp_desc.shape[0].idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 05764 05765 ATD_ARRAY_IDX(tmp_idx) = create_bd_ntry_for_const(&exp_desc, 05766 line, 05767 col); 05768 05769 05770 /*********************\ 05771 |* fill in type code *| 05772 \*********************/ 05773 05774 idx_constant = 1; 05775 05776 make_io_type_code(ATD_TYPE_IDX(base_attr), the_constant); 05777 05778 gen_opnd(&opnd2, 05779 ntr_const_tbl(IO_TYPE_CODE_TYPE, 05780 FALSE, 05781 the_constant), 05782 CN_Tbl_Idx, 05783 line, 05784 col); 05785 05786 gen_array_element_init(tmp_idx, 05787 &idx_constant, 05788 &opnd2, 05789 in_module ? Init_Opr : Asg_Opr, 05790 NULL_IDX); 05791 05792 /***********************\ 05793 |* fill in loc of opnd *| 05794 \***********************/ 05795 05796 if (TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Character) { 05797 ok = gen_whole_substring(opnd, 0); 05798 } 05799 05800 offset = NULL_IDX; 05801 05802 opnd2 = *opnd; 05803 05804 # ifdef _INIT_RELOC_BASE_OFFSET 05805 if (in_module) { 05806 offset = change_to_base_and_offset(opnd, &opnd2); 05807 05808 /* Check to make sure that SB_FIRST_ATTR_IDX has a value.*/ 05809 /* Create a temp as an overlay for the first object if */ 05810 /* there is no FIRST attr. */ 05811 05812 attr_idx = find_left_attr(&opnd2); 05813 05814 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) { 05815 set_sb_first_attr_idx(attr_idx); 05816 } 05817 } 05818 # endif 05819 05820 # if defined(GENERATE_WHIRL) 05821 loc_idx = gen_ir(OPND_FLD(opnd2), OPND_IDX(opnd2), 05822 Loc_Opr, TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Character ? 05823 CRI_Ch_Ptr_8 : CRI_Ptr_8, line, col, 05824 NO_Tbl_Idx, NULL_IDX); 05825 # else 05826 loc_idx = gen_ir(OPND_FLD(opnd2), OPND_IDX(opnd2), 05827 Aloc_Opr, TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Character ? 05828 CRI_Ch_Ptr_8 : CRI_Ptr_8, line, col, 05829 NO_Tbl_Idx, NULL_IDX); 05830 # endif 05831 05832 05833 # ifdef _TRANSFORM_CHAR_SEQUENCE 05834 # ifdef _TARGET_OS_UNICOS 05835 if (TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Structure && 05836 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(base_attr)))) { 05837 05838 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 05839 COPY_OPND(opnd2, IR_OPND_L(loc_idx)); 05840 transform_char_sequence_ref(&opnd2, ATD_TYPE_IDX(base_attr)); 05841 COPY_OPND(IR_OPND_L(loc_idx), opnd2); 05842 } 05843 # endif 05844 # endif 05845 05846 gen_opnd(&opnd2, loc_idx, IR_Tbl_Idx, line, col); 05847 05848 gen_array_element_init(tmp_idx, 05849 &idx_constant, 05850 &opnd2, 05851 in_module ? Init_Reloc_Opr : Asg_Opr, 05852 offset); 05853 05854 05855 if (TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Character && 05856 two_word_fcd) { 05857 05858 /* fill in the length explicitly */ 05859 05860 /* This must be a constant length character variable */ 05861 # ifdef _DEBUG 05862 if (TYP_FLD(ATD_TYPE_IDX(base_attr)) != CN_Tbl_Idx) { 05863 PRINTMSG(line, 1025, Internal, col); 05864 } 05865 # endif 05866 05867 gen_opnd(&opnd2, 05868 TYP_IDX(ATD_TYPE_IDX(base_attr)), 05869 CN_Tbl_Idx, 05870 line, 05871 col); 05872 05873 cast_opnd_to_type_idx(&opnd2, type_idx); 05874 05875 05876 if (! char_len_in_bytes) { 05877 05878 /* length must be in bits for every platform BUT solaris */ 05879 if (folder_driver((char *)&CN_CONST(OPND_IDX(opnd2)), 05880 type_idx, 05881 (char *)&CN_CONST(CN_INTEGER_CHAR_BIT_IDX), 05882 CN_TYPE_IDX(CN_INTEGER_CHAR_BIT_IDX), 05883 the_constant, 05884 &type_idx, 05885 line, 05886 col, 05887 2, 05888 Mult_Opr)) { 05889 } 05890 05891 gen_opnd(&opnd2, 05892 ntr_const_tbl(type_idx, 05893 FALSE, 05894 the_constant), 05895 CN_Tbl_Idx, 05896 line, 05897 col); 05898 05899 } 05900 05901 05902 gen_array_element_init(tmp_idx, 05903 &idx_constant, 05904 &opnd2, 05905 in_module ? Init_Opr : Asg_Opr, 05906 NULL_IDX); 05907 } 05908 05909 05910 TRACE (Func_Exit, "create_scalar_type_tbl", NULL); 05911 05912 return(tmp_idx); 05913 05914 } /* create_scalar_type_tbl */ 05915 05916 /******************************************************************************\ 05917 |* *| 05918 |* Description: *| 05919 |* create the struct tbl for namelist descriptors. *| 05920 |* *| 05921 |* Input parameters: *| 05922 |* NONE *| 05923 |* *| 05924 |* Output parameters: *| 05925 |* NONE *| 05926 |* *| 05927 |* Returns: *| 05928 |* NOTHING *| 05929 |* *| 05930 \******************************************************************************/ 05931 05932 static int create_strct_tbl(opnd_type *base_opnd, 05933 boolean in_module) 05934 05935 { 05936 int asg_idx; 05937 int base_attr; 05938 int col; 05939 int comp_attr; 05940 int dope_idx = NULL_IDX; 05941 int dv_tmp_idx; 05942 expr_arg_type exp_desc; 05943 long_type idx_constant; 05944 opnd_type l_opnd; 05945 int line; 05946 int list_idx; 05947 int loc_idx; 05948 long64 num; 05949 int offset; 05950 boolean ok; 05951 opnd_type opnd; 05952 opnd_type opnd2; 05953 int rank_idx = NULL_IDX; 05954 int size; 05955 int sn_idx; 05956 int static_tmp_idx; 05957 int sub_idx; 05958 int struct_idx; 05959 long_type the_constant[2]; 05960 int tmp_idx; 05961 int type_idx; 05962 int type_idx2; 05963 int val_type; 05964 05965 # ifdef _INIT_RELOC_BASE_OFFSET 05966 int attr_idx; 05967 # endif 05968 05969 nmlist_struclist_t *struct_hdr; 05970 nmlist_goli_t *goli_ptr; 05971 05972 TRACE (Func_Entry, "create_strct_tbl", NULL); 05973 05974 # if defined(GENERATE_WHIRL) 05975 type_idx2 = SA_INTEGER_DEFAULT_TYPE; 05976 # else 05977 type_idx2 = CG_INTEGER_DEFAULT_TYPE; 05978 # endif 05979 05980 base_attr = find_base_attr(base_opnd, &line, &col); 05981 type_idx = TYP_IDX(ATD_TYPE_IDX(base_attr)); /* Structure index */ 05982 05983 /**********************************\ 05984 |* create static struct tbl attr. *| 05985 \**********************************/ 05986 05987 if (two_word_fcd) { 05988 size = NML_STRCT_HDR_SIZE_FCD2 + 05989 (NML_STRCT_ITEM_SIZE_FCD2 * ATT_NUM_CPNTS(type_idx)); 05990 } 05991 else { 05992 size = NML_STRCT_HDR_SIZE + 05993 (NML_STRCT_ITEM_SIZE * ATT_NUM_CPNTS(type_idx)); 05994 } 05995 05996 # if defined(GENERATE_WHIRL) 05997 /* the version item is always 64 bits */ 05998 /* add one for the header version, and one for each cpnt entry */ 05999 if (TYP_LINEAR(type_idx2) == Integer_4) { 06000 size += 1 + ATT_NUM_CPNTS(type_idx); 06001 } 06002 # endif 06003 06004 static_tmp_idx = gen_static_integer_array_tmp(size,line,col); 06005 06006 if (! in_module) { 06007 06008 /***************************\ 06009 |* create struct tbl attr. *| 06010 \***************************/ 06011 06012 tmp_idx = gen_compiler_tmp(line,col, Priv, TRUE); 06013 ATD_TYPE_IDX(tmp_idx) = type_idx2; 06014 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 06015 06016 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 06017 06018 ATD_ARRAY_IDX(tmp_idx) = ATD_ARRAY_IDX(static_tmp_idx); 06019 06020 /***********************************\ 06021 |* copy static attr to stack attr. *| 06022 \***********************************/ 06023 06024 06025 gen_opnd(&opnd, tmp_idx, AT_Tbl_Idx, line, col); 06026 ok = gen_whole_subscript(&opnd, &exp_desc); 06027 06028 gen_opnd(&opnd2, static_tmp_idx, AT_Tbl_Idx, line, col); 06029 ok = gen_whole_subscript(&opnd2, &exp_desc); 06030 06031 asg_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 06032 Asg_Opr, type_idx2, line, col, 06033 OPND_FLD(opnd2), OPND_IDX(opnd2)); 06034 06035 gen_sh(After, Assignment_Stmt, line, col, 06036 FALSE, FALSE, TRUE); 06037 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 06038 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 06039 } 06040 06041 06042 /*************************************************\ 06043 |* set first word with number of components. *| 06044 \*************************************************/ 06045 06046 idx_constant = 1; 06047 06048 # if defined(_BITFIELD_RIGHT_TO_LEFT) /* Most x86 platforms */ 06049 the_constant[0] = (long_type) ATT_NUM_CPNTS(type_idx) << 16; 06050 # else 06051 the_constant[0] = 0; 06052 the_constant[1] = 0; 06053 06054 struct_hdr = (nmlist_struclist_t *)the_constant; 06055 06056 struct_hdr->structlen = ATT_NUM_CPNTS(type_idx); 06057 # endif 06058 06059 gen_opnd(&opnd, 06060 ntr_const_tbl((sizeof(nmlist_struclist_t) == 8) ? Integer_8 : 06061 Integer_4, 06062 FALSE, 06063 the_constant), 06064 CN_Tbl_Idx, 06065 line, 06066 col); 06067 06068 gen_array_element_init(static_tmp_idx, 06069 &idx_constant, 06070 &opnd, 06071 Init_Opr, 06072 NULL_IDX); 06073 06074 06075 /*************************************************************\ 06076 |* set next word with loc of dope vector or address of strct *| 06077 \*************************************************************/ 06078 06079 if (ATD_ARRAY_IDX(base_attr)) { 06080 /* get dope vector */ 06081 06082 COPY_OPND(opnd, (*base_opnd)); 06083 exp_desc = init_exp_desc; 06084 ok = gen_whole_subscript(&opnd, &exp_desc); 06085 COPY_OPND((*base_opnd), opnd); 06086 06087 if (in_module) { 06088 namelist_static_dv_whole_def(&l_opnd, &opnd); 06089 } 06090 else { 06091 dv_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 06092 06093 ATD_TYPE_IDX(dv_tmp_idx) = ATD_TYPE_IDX(base_attr); 06094 ATD_STOR_BLK_IDX(dv_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 06095 AT_SEMANTICS_DONE(dv_tmp_idx)= TRUE; 06096 06097 /* Positions 1-7 are deferred shape entries in the bd table. */ 06098 06099 ATD_ARRAY_IDX(dv_tmp_idx) = exp_desc.rank; 06100 ATD_IM_A_DOPE(dv_tmp_idx) = FALSE; 06101 06102 gen_opnd(&l_opnd, dv_tmp_idx, AT_Tbl_Idx, line, col); 06103 06104 exp_desc.type_idx = ATD_TYPE_IDX(base_attr); 06105 exp_desc.type = TYP_TYPE(exp_desc.type_idx); 06106 exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx); 06107 06108 if (exp_desc.type == Character) { 06109 exp_desc.char_len.fld = TYP_FLD(exp_desc.type_idx); 06110 exp_desc.char_len.idx = TYP_IDX(exp_desc.type_idx); 06111 } 06112 gen_dv_whole_def(&l_opnd, &opnd, &exp_desc); 06113 } 06114 06115 # if defined(GENERATE_WHIRL) 06116 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd), 06117 Loc_Opr, CRI_Ptr_8, line, col, 06118 NO_Tbl_Idx, NULL_IDX); 06119 # else 06120 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd), 06121 in_module ? Aloc_Opr : Loc_Opr, CRI_Ptr_8, line, col, 06122 NO_Tbl_Idx, NULL_IDX); 06123 # endif 06124 06125 rank_idx = 0; 06126 dope_idx = 0; 06127 make_base_subtree(base_opnd, &l_opnd, &rank_idx, &dope_idx); 06128 COPY_OPND((*base_opnd), l_opnd); 06129 06130 } 06131 else { 06132 06133 # if defined(GENERATE_WHIRL) 06134 loc_idx = gen_ir(OPND_FLD((*base_opnd)), OPND_IDX((*base_opnd)), 06135 Loc_Opr, CRI_Ptr_8, line, col, 06136 NO_Tbl_Idx, NULL_IDX); 06137 # else 06138 loc_idx = gen_ir(OPND_FLD((*base_opnd)), OPND_IDX((*base_opnd)), 06139 in_module ? Aloc_Opr : Loc_Opr, CRI_Ptr_8, line, col, 06140 NO_Tbl_Idx, NULL_IDX); 06141 # endif 06142 06143 # ifdef _TRANSFORM_CHAR_SEQUENCE 06144 # ifdef _TARGET_OS_UNICOS 06145 if (TYP_TYPE(ATD_TYPE_IDX(base_attr)) == Structure && 06146 ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(base_attr)))) { 06147 06148 IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8; 06149 COPY_OPND(opnd, IR_OPND_L(loc_idx)); 06150 transform_char_sequence_ref(&opnd, ATD_TYPE_IDX(base_attr)); 06151 COPY_OPND(IR_OPND_L(loc_idx), opnd); 06152 } 06153 # endif 06154 # endif 06155 06156 } 06157 06158 offset = NULL_IDX; 06159 06160 # ifdef _INIT_RELOC_BASE_OFFSET 06161 if (in_module) { 06162 06163 COPY_OPND(opnd, IR_OPND_L(loc_idx)); 06164 offset = change_to_base_and_offset(&opnd, &opnd2); 06165 COPY_OPND(IR_OPND_L(loc_idx), opnd2); 06166 06167 /* Check to make sure that SB_FIRST_ATTR_IDX has a value.*/ 06168 /* Create a temp as an overlay for the first object if */ 06169 /* there is no FIRST attr. */ 06170 06171 attr_idx = find_left_attr(&(IR_OPND_L(loc_idx))); 06172 06173 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) { 06174 set_sb_first_attr_idx(attr_idx); 06175 } 06176 } 06177 # endif 06178 06179 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col); 06180 06181 gen_array_element_init(in_module ? static_tmp_idx : tmp_idx, 06182 &idx_constant, 06183 &opnd, 06184 in_module ? Init_Reloc_Opr : Asg_Opr, 06185 offset); 06186 06187 sn_idx = ATT_FIRST_CPNT_IDX(type_idx); 06188 06189 while (sn_idx != NULL_IDX) { 06190 06191 comp_attr = SN_ATTR_IDX(sn_idx); 06192 06193 /***************************************************\ 06194 |* set the valtype in the first word of item entry *| 06195 \***************************************************/ 06196 06197 if (TYP_TYPE(ATD_TYPE_IDX(comp_attr)) == Structure) { 06198 06199 if (ATD_ARRAY_IDX(comp_attr)) { 06200 val_type = NML_VALTYPE_STRCT_ARRAY; 06201 } 06202 else { 06203 val_type = NML_VALTYPE_STRCT; 06204 } 06205 } 06206 else if (ATD_ARRAY_IDX(comp_attr)) { 06207 val_type = NML_VALTYPE_ARRAY; 06208 } 06209 else { 06210 val_type = NML_VALTYPE_SCALAR; 06211 } 06212 06213 # if defined(_BITFIELD_RIGHT_TO_LEFT) /* Most x86 platforms */ 06214 the_constant[0] = val_type; 06215 # else 06216 06217 the_constant[0] = 0; 06218 the_constant[1] = 0; 06219 06220 goli_ptr = (nmlist_goli_t *)the_constant; 06221 06222 goli_ptr->valtype = val_type; 06223 # endif 06224 06225 gen_opnd(&opnd, 06226 ntr_const_tbl((sizeof(nmlist_goli_t) == 8) ? Integer_8 : 06227 Integer_4, 06228 FALSE, 06229 the_constant), 06230 CN_Tbl_Idx, 06231 line, 06232 col); 06233 06234 gen_array_element_init(static_tmp_idx, 06235 &idx_constant, 06236 &opnd, 06237 Init_Opr, 06238 NULL_IDX); 06239 06240 06241 /***************************************\ 06242 |* set the fcd for the group item name *| 06243 \***************************************/ 06244 06245 put_string_in_tmp(AT_OBJ_NAME_PTR(comp_attr), 06246 AT_NAME_LEN(comp_attr), 06247 &opnd); 06248 06249 06250 # ifdef _INIT_RELOC_BASE_OFFSET 06251 if (in_module) { 06252 /* Check to make sure that SB_FIRST_ATTR_IDX has a value.*/ 06253 /* Create a temp as an overlay for the first object if */ 06254 /* there is no FIRST attr. */ 06255 06256 attr_idx = find_left_attr(&opnd); 06257 06258 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) { 06259 set_sb_first_attr_idx(attr_idx); 06260 } 06261 } 06262 # endif 06263 06264 /* tmp is character */ 06265 06266 # if defined(GENERATE_WHIRL) 06267 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 06268 Loc_Opr, CRI_Ch_Ptr_8, line, col, 06269 NO_Tbl_Idx, NULL_IDX); 06270 # else 06271 loc_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 06272 Aloc_Opr, CRI_Ch_Ptr_8, line, col, 06273 NO_Tbl_Idx, NULL_IDX); 06274 # endif 06275 06276 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col); 06277 06278 gen_array_element_init(in_module ? static_tmp_idx : tmp_idx, 06279 &idx_constant, 06280 &opnd, 06281 in_module ? Init_Reloc_Opr : Asg_Opr, 06282 NULL_IDX); 06283 06284 if (two_word_fcd) { 06285 /* fill in the length explicitly */ 06286 06287 if (char_len_in_bytes) { 06288 /* length is in bytes on solaris */ 06289 num = AT_NAME_LEN(comp_attr); 06290 } 06291 else { 06292 /* length is in bits on mpp. */ 06293 num = AT_NAME_LEN(comp_attr) * CHAR_BIT; 06294 } 06295 06296 gen_opnd(&opnd, 06297 C_INT_TO_CN(type_idx2, num), 06298 CN_Tbl_Idx, 06299 line, 06300 col); 06301 06302 gen_array_element_init(static_tmp_idx, 06303 &idx_constant, 06304 &opnd, 06305 Init_Opr, 06306 NULL_IDX); 06307 06308 } 06309 06310 /*******************************************\ 06311 |* Now for the varieties of the third word *| 06312 \*******************************************/ 06313 06314 NTR_IR_TBL(struct_idx); 06315 IR_OPR(struct_idx) = Struct_Opr; 06316 IR_TYPE_IDX(struct_idx) = ATD_TYPE_IDX(comp_attr); 06317 IR_LINE_NUM(struct_idx) = line; 06318 IR_COL_NUM(struct_idx) = col; 06319 06320 COPY_OPND(IR_OPND_L(struct_idx), (*base_opnd)); 06321 IR_FLD_R(struct_idx) = AT_Tbl_Idx; 06322 IR_IDX_R(struct_idx) = comp_attr; 06323 IR_LINE_NUM_R(struct_idx) = line; 06324 IR_COL_NUM_R(struct_idx) = col; 06325 06326 gen_opnd(&opnd, struct_idx, IR_Tbl_Idx, line, col); 06327 06328 switch (val_type) { 06329 case NML_VALTYPE_SCALAR : 06330 /* get scalar type tbl */ 06331 06332 loc_idx = gen_ir(AT_Tbl_Idx, create_scalar_type_tbl(&opnd, 06333 in_module), 06334 Loc_Opr, CRI_Ptr_8, line, col, 06335 NO_Tbl_Idx, NULL_IDX); 06336 06337 break; 06338 06339 case NML_VALTYPE_ARRAY : 06340 /* get dope vector */ 06341 06342 exp_desc = init_exp_desc; 06343 ok = gen_whole_subscript(&opnd, &exp_desc); 06344 06345 if (in_module) { 06346 namelist_static_dv_whole_def(&l_opnd, &opnd); 06347 } 06348 else { 06349 dv_tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 06350 06351 ATD_TYPE_IDX(dv_tmp_idx) = ATD_TYPE_IDX(comp_attr); 06352 ATD_STOR_BLK_IDX(dv_tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 06353 AT_SEMANTICS_DONE(dv_tmp_idx) = TRUE; 06354 06355 /* Positions 1-7 are deferred shape entries in the bd table. */ 06356 06357 ATD_ARRAY_IDX(dv_tmp_idx) = exp_desc.rank; 06358 ATD_IM_A_DOPE(dv_tmp_idx) = FALSE; 06359 06360 gen_opnd(&l_opnd, dv_tmp_idx, AT_Tbl_Idx, line, col); 06361 06362 exp_desc.type_idx = ATD_TYPE_IDX(comp_attr); 06363 exp_desc.type = TYP_TYPE(exp_desc.type_idx); 06364 exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx); 06365 06366 if (exp_desc.type == Character) { 06367 exp_desc.char_len.fld = TYP_FLD(exp_desc.type_idx); 06368 exp_desc.char_len.idx = TYP_IDX(exp_desc.type_idx); 06369 } 06370 gen_dv_whole_def(&l_opnd, &opnd, &exp_desc); 06371 } 06372 06373 # if defined(GENERATE_WHIRL) 06374 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd), 06375 Loc_Opr, CRI_Ptr_8, line, col, 06376 NO_Tbl_Idx, NULL_IDX); 06377 # else 06378 loc_idx = gen_ir(OPND_FLD(l_opnd), OPND_IDX(l_opnd), 06379 in_module ? Aloc_Opr : Loc_Opr, CRI_Ptr_8, line, col, 06380 NO_Tbl_Idx, NULL_IDX); 06381 # endif 06382 break; 06383 06384 case NML_VALTYPE_STRCT : 06385 case NML_VALTYPE_STRCT_ARRAY : 06386 /* get struct tbl */ 06387 06388 loc_idx = gen_ir(AT_Tbl_Idx, create_strct_tbl(&opnd, in_module), 06389 Loc_Opr, CRI_Ptr_8, line, col, 06390 NO_Tbl_Idx, NULL_IDX); 06391 06392 break; 06393 } 06394 06395 # ifdef _INIT_RELOC_BASE_OFFSET 06396 if (in_module) { 06397 06398 /* Check to make sure that SB_FIRST_ATTR_IDX has a value.*/ 06399 /* Create a temp as an overlay for the first object if */ 06400 /* there is no FIRST attr. */ 06401 06402 attr_idx = find_left_attr(&(IR_OPND_L(loc_idx))); 06403 06404 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) { 06405 set_sb_first_attr_idx(attr_idx); 06406 } 06407 } 06408 # endif 06409 06410 gen_opnd(&opnd, loc_idx, IR_Tbl_Idx, line, col); 06411 06412 gen_array_element_init(in_module ? static_tmp_idx : tmp_idx, 06413 &idx_constant, 06414 &opnd, 06415 in_module ? Init_Reloc_Opr : Asg_Opr, 06416 NULL_IDX); 06417 06418 sn_idx = SN_SIBLING_LINK(sn_idx); 06419 } 06420 06421 06422 TRACE (Func_Exit, "create_strct_tbl", NULL); 06423 06424 return(in_module ? static_tmp_idx : tmp_idx); 06425 06426 } /* create_strct_tbl */ 06427 06428 /******************************************************************************\ 06429 |* *| 06430 |* Description: *| 06431 |* Put a string into the constant table, initialize a static tmp with *| 06432 |* the constant, return the tmp idx. *| 06433 |* *| 06434 |* Input parameters: *| 06435 |* str - address of string. *| 06436 |* *| 06437 |* Output parameters: *| 06438 |* NONE *| 06439 |* *| 06440 |* Returns: *| 06441 |* tmp_idx *| 06442 |* *| 06443 \******************************************************************************/ 06444 06445 static void put_string_in_tmp(char *str, 06446 int len, 06447 opnd_type *opnd) 06448 06449 { 06450 int col; 06451 int const_idx; 06452 int init_idx; 06453 int line; 06454 int list_idx; 06455 boolean ok; 06456 int save_curr_stmt_sh_idx; 06457 int tmp_idx; 06458 int type_idx; 06459 06460 06461 /* NOTE - If this is ever called with a str that is not on a word boundary */ 06462 /* the call to ntr_const_tbl will not work correctly. ntr_const_tbl*/ 06463 /* will have to be called with a NULL, and the string hand copied. */ 06464 06465 TRACE (Func_Entry, "put_string_in_tmp", NULL); 06466 06467 line = SH_GLB_LINE(curr_stmt_sh_idx); 06468 col = SH_COL_NUM(curr_stmt_sh_idx); 06469 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 06470 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 06471 06472 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 06473 TYP_TYPE(TYP_WORK_IDX) = Character; 06474 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 06475 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 06476 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 06477 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, len); 06478 type_idx = ntr_type_tbl(); 06479 const_idx = ntr_const_tbl(type_idx, 06480 TRUE, 06481 (long_type *) str); 06482 06483 tmp_idx = gen_compiler_tmp(line, col, Shared, TRUE); 06484 06485 ATD_TYPE_IDX(tmp_idx) = type_idx; 06486 ATD_SAVED(tmp_idx) = TRUE; 06487 ATD_DATA_INIT(tmp_idx) = TRUE; 06488 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 06489 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 06490 06491 OPND_FLD((*opnd)) = AT_Tbl_Idx; 06492 OPND_IDX((*opnd)) = tmp_idx; 06493 OPND_LINE_NUM((*opnd)) = line; 06494 OPND_COL_NUM((*opnd)) = col; 06495 06496 ok = gen_whole_substring(opnd, 0); 06497 06498 NTR_IR_TBL(init_idx); 06499 IR_OPR(init_idx) = Init_Opr; 06500 IR_TYPE_IDX(init_idx) = TYPELESS_DEFAULT_TYPE; 06501 06502 IR_LINE_NUM(init_idx) = line; 06503 IR_COL_NUM(init_idx) = col; 06504 IR_LINE_NUM_R(init_idx) = line; 06505 IR_COL_NUM_R(init_idx) = col; 06506 06507 COPY_OPND(IR_OPND_L(init_idx), (*opnd)); 06508 06509 NTR_IR_LIST_TBL(list_idx); 06510 IR_FLD_R(init_idx) = IL_Tbl_Idx; 06511 IR_IDX_R(init_idx) = list_idx; 06512 IR_LIST_CNT_R(init_idx) = 3; 06513 06514 IL_FLD(list_idx) = CN_Tbl_Idx; 06515 IL_IDX(list_idx) = const_idx; 06516 IL_LINE_NUM(list_idx) = line; 06517 IL_COL_NUM(list_idx) = col; 06518 06519 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 06520 06521 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 06522 list_idx = IL_NEXT_LIST_IDX(list_idx); 06523 IL_FLD(list_idx) = CN_Tbl_Idx; 06524 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 06525 IL_LINE_NUM(list_idx) = line; 06526 IL_COL_NUM(list_idx) = col; 06527 06528 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 06529 06530 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 06531 list_idx = IL_NEXT_LIST_IDX(list_idx); 06532 IL_FLD(list_idx) = CN_Tbl_Idx; 06533 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 06534 IL_LINE_NUM(list_idx) = line; 06535 IL_COL_NUM(list_idx) = col; 06536 06537 gen_sh(After, 06538 Assignment_Stmt, 06539 line, 06540 col, 06541 FALSE, 06542 FALSE, 06543 TRUE); 06544 06545 SH_IR_IDX(curr_stmt_sh_idx) = init_idx; 06546 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 06547 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 06548 06549 TRACE (Func_Exit, "put_string_in_tmp", NULL); 06550 06551 return; 06552 06553 } /* put_string_in_tmp */ 06554 06555 /******************************************************************************\ 06556 |* *| 06557 |* Description: *| 06558 |* Take a reference and return the base attr and the offset to the *| 06559 |* subobject (if any). This is used for Init_Reloc_Opr stuff because *| 06560 |* rcg doesn't handle this very well. *| 06561 |* *| 06562 |* Input parameters: *| 06563 |* ref_opnd - address of opnd pointing to reference tree. *| 06564 |* *| 06565 |* Output parameters: *| 06566 |* base_opnd - address of opnd to point to base attr. *| 06567 |* *| 06568 |* Returns: *| 06569 |* the offset in bits. *| 06570 |* *| 06571 \******************************************************************************/ 06572 06573 # ifdef _INIT_RELOC_BASE_OFFSET 06574 static int change_to_base_and_offset(opnd_type *ref_opnd, 06575 opnd_type *base_opnd) 06576 06577 06578 { 06579 int col; 06580 size_offset_type cpnt_offset; 06581 int line; 06582 int offset_idx; 06583 size_offset_type offset; 06584 opnd_type opnd; 06585 boolean unused; 06586 06587 06588 TRACE (Func_Entry, "change_to_base_and_offset", NULL); 06589 06590 if (OPND_FLD((*ref_opnd)) == AT_Tbl_Idx) { 06591 offset_idx = CN_INTEGER_ZERO_IDX; 06592 COPY_OPND((*base_opnd), (*ref_opnd)); 06593 } 06594 else { 06595 COPY_OPND(opnd, (*ref_opnd)); 06596 06597 offset.idx = CN_INTEGER_ZERO_IDX; 06598 offset.fld = CN_Tbl_Idx; 06599 06600 while (OPND_FLD(opnd) != AT_Tbl_Idx) { 06601 06602 switch (IR_OPR(OPND_IDX(opnd))) { 06603 case Whole_Subscript_Opr : 06604 case Section_Subscript_Opr : 06605 case Subscript_Opr : 06606 case Whole_Substring_Opr : 06607 case Substring_Opr : 06608 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 06609 break; 06610 06611 case Struct_Opr : 06612 06613 cpnt_offset.idx = ATD_CPNT_OFFSET_IDX(IR_IDX_R(OPND_IDX(opnd))); 06614 cpnt_offset.fld = ATD_OFFSET_FLD(IR_IDX_R(OPND_IDX(opnd))); 06615 06616 size_offset_binary_calc(&offset, 06617 &cpnt_offset, 06618 Plus_Opr, 06619 &offset); 06620 06621 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 06622 break; 06623 06624 default : 06625 find_opnd_line_and_column(&opnd, &line, &col); 06626 PRINTMSG(line, 1048, Internal, col); 06627 break; 06628 } 06629 } 06630 06631 if (offset.fld == NO_Tbl_Idx) { 06632 offset_idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 06633 } 06634 else if (offset.fld == CN_Tbl_Idx) { 06635 offset_idx = offset.idx; 06636 } 06637 else { 06638 PRINTMSG(OPND_LINE_NUM(opnd), 1201, Internal, OPND_COL_NUM(opnd), 06639 AT_OBJ_NAME_PTR(IR_IDX_R(OPND_IDX(opnd)))); 06640 } 06641 06642 COPY_OPND((*base_opnd), opnd); 06643 06644 if (TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(opnd))) == Character) { 06645 unused = gen_whole_substring(base_opnd, 0); 06646 } 06647 } 06648 06649 TRACE (Func_Exit, "change_to_base_and_offset", NULL); 06650 06651 return(offset_idx); 06652 06653 } /* change_to_base_and_offset */ 06654 # endif 06655 06656 /******************************************************************************\ 06657 |* *| 06658 |* Description: *| 06659 |* Set the defined flag on all the namelist group attrs. Check for *| 06660 |* live do control variables and intent in dummy args. *| 06661 |* *| 06662 |* Input parameters: *| 06663 |* NONE *| 06664 |* *| 06665 |* Output parameters: *| 06666 |* NONE *| 06667 |* *| 06668 |* Returns: *| 06669 |* NOTHING *| 06670 |* *| 06671 \******************************************************************************/ 06672 06673 static boolean do_read_namelist_semantics(opnd_type *namelist_opnd) 06674 06675 { 06676 int attr_idx; 06677 int col; 06678 int line; 06679 int namelist_attr; 06680 opnd_type opnd; 06681 boolean semantically_correct = TRUE; 06682 int sn_idx; 06683 06684 06685 TRACE (Func_Entry, "do_read_namelist_semantics", NULL); 06686 06687 namelist_attr = OPND_IDX((*namelist_opnd)); 06688 line = OPND_LINE_NUM((*namelist_opnd)); 06689 col = OPND_COL_NUM((*namelist_opnd)); 06690 06691 sn_idx = ATN_FIRST_NAMELIST_IDX(namelist_attr); 06692 06693 while (sn_idx != NULL_IDX) { 06694 attr_idx = SN_ATTR_IDX(sn_idx); 06695 AT_DEFINED(attr_idx) = TRUE; 06696 06697 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 06698 06699 gen_opnd(&opnd, attr_idx, AT_Tbl_Idx, line, col); 06700 06701 if (! check_for_legal_define(&opnd)) { 06702 semantically_correct = FALSE; 06703 sn_idx = SN_SIBLING_LINK(sn_idx); 06704 continue; 06705 } 06706 } 06707 06708 if (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 06709 AT_DEF_IN_CHILD(attr_idx) = TRUE; 06710 06711 do { 06712 attr_idx = AT_ATTR_LINK(attr_idx); 06713 AT_DEF_IN_CHILD(attr_idx) = TRUE; 06714 } 06715 while (AT_ATTR_LINK(attr_idx) != NULL_IDX); 06716 } 06717 06718 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 06719 ATD_CLASS(attr_idx) == Dummy_Argument && 06720 ATD_INTENT(attr_idx) == Intent_In) { 06721 PRINTMSG(line, 890, Error, col, AT_OBJ_NAME_PTR(attr_idx)); 06722 semantically_correct = FALSE; 06723 } 06724 06725 sn_idx = SN_SIBLING_LINK(sn_idx); 06726 } 06727 06728 TRACE (Func_Exit, "do_read_namelist_semantics", NULL); 06729 06730 return(semantically_correct); 06731 06732 } /* do_read_namelist_semantics */ 06733 06734 /******************************************************************************\ 06735 |* *| 06736 |* Description: *| 06737 |* Set the referenced field on all the namelist group attrs. *| 06738 |* *| 06739 |* Input parameters: *| 06740 |* NONE *| 06741 |* *| 06742 |* Output parameters: *| 06743 |* NONE *| 06744 |* *| 06745 |* Returns: *| 06746 |* NOTHING *| 06747 |* *| 06748 \******************************************************************************/ 06749 06750 static void do_write_namelist_semantics(opnd_type *namelist_opnd) 06751 06752 { 06753 int attr_idx; 06754 int namelist_attr; 06755 int sn_idx; 06756 06757 TRACE (Func_Entry, "do_write_namelist_semantics", NULL); 06758 06759 namelist_attr = OPND_IDX((*namelist_opnd)); 06760 06761 sn_idx = ATN_FIRST_NAMELIST_IDX(namelist_attr); 06762 06763 while (sn_idx != NULL_IDX) { 06764 attr_idx = SN_ATTR_IDX(sn_idx); 06765 AT_REFERENCED(attr_idx) = Referenced; 06766 06767 if (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 06768 AT_REF_IN_CHILD(attr_idx) = TRUE; 06769 06770 do { 06771 attr_idx = AT_ATTR_LINK(attr_idx); 06772 AT_REF_IN_CHILD(attr_idx) = TRUE; 06773 } 06774 while (AT_ATTR_LINK(attr_idx) != NULL_IDX); 06775 } 06776 06777 sn_idx = SN_SIBLING_LINK(sn_idx); 06778 } 06779 06780 TRACE (Func_Exit, "do_write_namelist_semantics", NULL); 06781 06782 return; 06783 06784 } /* do_write_namelist_semantics */ 06785 06786 /******************************************************************************\ 06787 |* *| 06788 |* Description: *| 06789 |* This routine breaks up structure objects in io lists into component *| 06790 |* references. *| 06791 |* *| 06792 |* Input parameters: *| 06793 |* NONE *| 06794 |* *| 06795 |* Output parameters: *| 06796 |* NONE *| 06797 |* *| 06798 |* Returns: *| 06799 |* NOTHING *| 06800 |* *| 06801 \******************************************************************************/ 06802 06803 static int discombobulate_structure_ref(opnd_type *base_opnd, 06804 int type_idx, 06805 int *list_idx) 06806 06807 { 06808 int attr_idx; 06809 int cnt; 06810 int col; 06811 int deref_idx; 06812 expr_arg_type exp_desc; 06813 boolean first_item = TRUE; 06814 int imp_idx; 06815 int ir_idx; 06816 int line; 06817 opnd_type loc_base_opnd; 06818 int new_list_idx; 06819 int next_list_idx; 06820 int num_items = 0; 06821 boolean ok; 06822 opnd_type opnd; 06823 int sn_idx; 06824 int struct_idx; 06825 int tmp_list_idx; 06826 06827 06828 TRACE (Func_Entry, "discombobulate_structure_ref", NULL); 06829 06830 new_list_idx = *list_idx; 06831 next_list_idx = IL_NEXT_LIST_IDX(new_list_idx); 06832 06833 attr_idx = find_base_attr(base_opnd, &line, &col); 06834 06835 sn_idx = ATT_FIRST_CPNT_IDX(type_idx); 06836 06837 COPY_OPND(loc_base_opnd, (*base_opnd)); 06838 06839 while (sn_idx != NULL_IDX) { 06840 attr_idx = SN_ATTR_IDX(sn_idx); 06841 06842 NTR_IR_TBL(struct_idx); 06843 IR_OPR(struct_idx) = Struct_Opr; 06844 IR_TYPE_IDX(struct_idx) = ATD_TYPE_IDX(attr_idx); 06845 IR_LINE_NUM(struct_idx) = line; 06846 IR_COL_NUM(struct_idx) = col; 06847 COPY_OPND(IR_OPND_L(struct_idx), loc_base_opnd); 06848 06849 if (SN_SIBLING_LINK(sn_idx) != NULL_IDX) { 06850 copy_subtree(&loc_base_opnd, &loc_base_opnd); 06851 } 06852 06853 IR_FLD_R(struct_idx) = AT_Tbl_Idx; 06854 IR_IDX_R(struct_idx) = attr_idx; 06855 IR_LINE_NUM_R(struct_idx) = line; 06856 IR_COL_NUM_R(struct_idx) = col; 06857 06858 OPND_FLD(opnd) = IR_Tbl_Idx; 06859 OPND_IDX(opnd) = struct_idx; 06860 06861 if (ATD_POINTER(attr_idx)) { 06862 NTR_IR_TBL(deref_idx); 06863 IR_OPR(deref_idx) = Dv_Deref_Opr; 06864 IR_TYPE_IDX(deref_idx) = ATD_TYPE_IDX(attr_idx); 06865 IR_LINE_NUM(deref_idx) = line; 06866 IR_COL_NUM(deref_idx) = col; 06867 COPY_OPND(IR_OPND_L(deref_idx), opnd); 06868 OPND_FLD(opnd) = IR_Tbl_Idx; 06869 OPND_IDX(opnd) = deref_idx; 06870 } 06871 06872 if (ATD_ARRAY_IDX(attr_idx)) { 06873 ok = gen_whole_subscript(&opnd, &exp_desc); 06874 } 06875 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 06876 ok = gen_whole_substring(&opnd, 0); 06877 } 06878 06879 if (first_item) { 06880 first_item = FALSE; 06881 } 06882 else { 06883 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(new_list_idx)); 06884 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(new_list_idx)) = new_list_idx; 06885 new_list_idx = IL_NEXT_LIST_IDX(new_list_idx); 06886 num_items++; 06887 } 06888 06889 COPY_OPND(IL_OPND(new_list_idx), opnd); 06890 06891 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure) { 06892 06893 if (ATD_ARRAY_IDX(attr_idx)) { 06894 tmp_list_idx = new_list_idx; 06895 imp_idx = change_section_to_do(&tmp_list_idx); 06896 COPY_OPND(opnd, IL_OPND(tmp_list_idx)); 06897 cnt = discombobulate_structure_ref( &opnd, 06898 TYP_IDX(ATD_TYPE_IDX(attr_idx)), 06899 &tmp_list_idx); 06900 IR_LIST_CNT_L(imp_idx) += cnt; 06901 } 06902 else { 06903 num_items += discombobulate_structure_ref( 06904 &opnd, 06905 TYP_IDX(ATD_TYPE_IDX(attr_idx)), 06906 &new_list_idx); 06907 } 06908 } 06909 else { 06910 /* insert the Io_Item_Type_Code_Opr */ 06911 06912 COPY_OPND(opnd, IL_OPND(new_list_idx)); 06913 06914 NTR_IR_TBL(ir_idx); 06915 IR_OPR(ir_idx) = Io_Item_Type_Code_Opr; 06916 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx); 06917 IR_LINE_NUM(ir_idx) = line; 06918 IR_COL_NUM(ir_idx) = col; 06919 06920 COPY_OPND(IR_OPND_L(ir_idx), opnd); 06921 IL_FLD(new_list_idx) = IR_Tbl_Idx; 06922 IL_IDX(new_list_idx) = ir_idx; 06923 } 06924 06925 sn_idx = SN_SIBLING_LINK(sn_idx); 06926 } 06927 06928 IL_NEXT_LIST_IDX(new_list_idx) = next_list_idx; 06929 *list_idx = new_list_idx; 06930 06931 TRACE (Func_Exit, "discombobulate_structure_ref", NULL); 06932 06933 return(num_items); 06934 06935 } /* discombobulate_structure_ref */ 06936 06937 /******************************************************************************\ 06938 |* *| 06939 |* Description: *| 06940 |* This routine checks the existing subtree that is type structure and *| 06941 |* creates implied do loops for any sections. *| 06942 |* *| 06943 |* Input parameters: *| 06944 |* NONE *| 06945 |* *| 06946 |* Output parameters: *| 06947 |* NONE *| 06948 |* *| 06949 |* Returns: *| 06950 |* NOTHING *| 06951 |* *| 06952 \******************************************************************************/ 06953 06954 static int change_section_to_do(int *list_idx) 06955 06956 { 06957 int col; 06958 expr_arg_type exp_desc; 06959 int imp_idx; 06960 int ir_idx; 06961 int i; 06962 int k; 06963 int line; 06964 opnd_type opnd; 06965 int rank = 1; 06966 int return_imp_idx; 06967 int return_list_idx; 06968 int sub_list_idx; 06969 int tmp_idx; 06970 int tmp_list_idx; 06971 opnd_type tmp_opnd; 06972 int trip_list_idx; 06973 06974 06975 TRACE (Func_Entry, "change_section_to_do", NULL); 06976 06977 COPY_OPND(opnd, IL_OPND((*list_idx))); 06978 find_opnd_line_and_column(&opnd, &line, &col); 06979 06980 while (OPND_FLD(opnd) == IR_Tbl_Idx) { 06981 06982 ir_idx = OPND_IDX(opnd); 06983 06984 if (IR_OPR(ir_idx) == Whole_Subscript_Opr || 06985 IR_OPR(ir_idx) == Section_Subscript_Opr) { 06986 06987 IR_OPR(ir_idx) = Subscript_Opr; 06988 06989 /* create first implied do */ 06990 NTR_IR_TBL(imp_idx); 06991 return_imp_idx = imp_idx; 06992 IR_OPR(imp_idx) = Implied_Do_Opr; 06993 IR_TYPE_IDX(imp_idx) = TYPELESS_DEFAULT_TYPE; 06994 IR_LINE_NUM(imp_idx) = line; 06995 IR_COL_NUM(imp_idx) = col; 06996 06997 NTR_IR_LIST_TBL(return_list_idx); 06998 IR_FLD_L(imp_idx) = IL_Tbl_Idx; 06999 IR_LIST_CNT_L(imp_idx) = 1; 07000 IR_IDX_L(imp_idx) = return_list_idx; 07001 07002 COPY_OPND(IL_OPND(return_list_idx), IL_OPND((*list_idx))); 07003 IL_FLD((*list_idx)) = IR_Tbl_Idx; 07004 IL_IDX((*list_idx)) = imp_idx; 07005 07006 sub_list_idx = IR_IDX_R(ir_idx); 07007 for (i = 0; i < IR_LIST_CNT_R(ir_idx); i++) { 07008 07009 if (IL_VECTOR_SUBSCRIPT(sub_list_idx)) { 07010 /* ultimately we must have a triplet opr. */ 07011 /* this section just finds that triplet opr */ 07012 07013 COPY_OPND(tmp_opnd, IL_OPND(sub_list_idx)); 07014 07015 trip_list_idx = NULL_IDX; 07016 while (trip_list_idx == NULL_IDX) { 07017 07018 while (OPND_FLD(tmp_opnd) == IR_Tbl_Idx) { 07019 07020 if (IR_OPR(OPND_IDX(tmp_opnd)) == Whole_Subscript_Opr || 07021 IR_OPR(OPND_IDX(tmp_opnd)) == Section_Subscript_Opr) { 07022 07023 tmp_list_idx = IR_IDX_R(OPND_IDX(tmp_opnd)); 07024 07025 for (k = 0; k < IR_LIST_CNT_R(OPND_IDX(tmp_opnd)); 07026 k++) { 07027 if (IL_VECTOR_SUBSCRIPT(tmp_list_idx)) { 07028 COPY_OPND(tmp_opnd, IL_OPND(tmp_list_idx)); 07029 break; 07030 } 07031 else if (IL_FLD(tmp_list_idx) == IR_Tbl_Idx && 07032 IR_OPR(IL_IDX(tmp_list_idx)) == Triplet_Opr) { 07033 07034 trip_list_idx = tmp_list_idx; 07035 break; 07036 } 07037 07038 tmp_list_idx = IL_NEXT_LIST_IDX(tmp_list_idx); 07039 } 07040 break; 07041 } 07042 07043 COPY_OPND(tmp_opnd, IR_OPND_L(OPND_IDX(tmp_opnd))); 07044 } 07045 } 07046 } 07047 else { 07048 trip_list_idx = sub_list_idx; 07049 } 07050 07051 if (IL_FLD(trip_list_idx) == IR_Tbl_Idx && 07052 IR_OPR(IL_IDX(trip_list_idx)) == Triplet_Opr) { 07053 07054 if (rank > 1) { 07055 /* generate new implied do */ 07056 NTR_IR_LIST_TBL(tmp_list_idx); 07057 IL_FLD(tmp_list_idx) = IR_Tbl_Idx; 07058 IL_IDX(tmp_list_idx) = imp_idx; 07059 07060 NTR_IR_TBL(imp_idx); 07061 IR_OPR(imp_idx) = Implied_Do_Opr; 07062 IR_TYPE_IDX(imp_idx) = TYPELESS_DEFAULT_TYPE; 07063 IR_LINE_NUM(imp_idx) = line; 07064 IR_COL_NUM(imp_idx) = col; 07065 IR_FLD_L(imp_idx) = IL_Tbl_Idx; 07066 IR_LIST_CNT_L(imp_idx) = 1; 07067 IR_IDX_L(imp_idx) = tmp_list_idx; 07068 IL_IDX((*list_idx)) = imp_idx; 07069 } 07070 07071 /* create the tmp implied do control variable. */ 07072 07073 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 07074 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE; 07075 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 07076 AT_SEMANTICS_DONE(tmp_idx)= TRUE; 07077 07078 /* hook in control var. */ 07079 07080 NTR_IR_LIST_TBL(tmp_list_idx); 07081 IR_FLD_R(imp_idx) = IL_Tbl_Idx; 07082 IR_LIST_CNT_R(imp_idx) = 4; 07083 IR_IDX_R(imp_idx) = tmp_list_idx; 07084 07085 IL_FLD(tmp_list_idx) = AT_Tbl_Idx; 07086 IL_IDX(tmp_list_idx) = tmp_idx; 07087 IL_LINE_NUM(tmp_list_idx) = line; 07088 IL_COL_NUM(tmp_list_idx) = col; 07089 07090 /* second is start opnd */ 07091 07092 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(tmp_list_idx)); 07093 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(tmp_list_idx)) = tmp_list_idx; 07094 tmp_list_idx = IL_NEXT_LIST_IDX(tmp_list_idx); 07095 07096 COPY_OPND(IL_OPND(tmp_list_idx), 07097 IL_OPND(IR_IDX_L(IL_IDX(trip_list_idx)))); 07098 07099 COPY_OPND(tmp_opnd, IL_OPND(tmp_list_idx)); 07100 set_up_exp_desc(&tmp_opnd, &exp_desc); 07101 cast_to_cg_default(&tmp_opnd, &exp_desc); 07102 COPY_OPND(IL_OPND(tmp_list_idx), tmp_opnd); 07103 07104 /* third is end opnd */ 07105 07106 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(tmp_list_idx)); 07107 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(tmp_list_idx)) = tmp_list_idx; 07108 tmp_list_idx = IL_NEXT_LIST_IDX(tmp_list_idx); 07109 07110 COPY_OPND(IL_OPND(tmp_list_idx), 07111 IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_L( 07112 IL_IDX(trip_list_idx))))); 07113 07114 COPY_OPND(tmp_opnd, IL_OPND(tmp_list_idx)); 07115 set_up_exp_desc(&tmp_opnd, &exp_desc); 07116 cast_to_cg_default(&tmp_opnd, &exp_desc); 07117 COPY_OPND(IL_OPND(tmp_list_idx), tmp_opnd); 07118 07119 /* fourth is stride opnd */ 07120 07121 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(tmp_list_idx)); 07122 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(tmp_list_idx)) = tmp_list_idx; 07123 tmp_list_idx = IL_NEXT_LIST_IDX(tmp_list_idx); 07124 07125 COPY_OPND(IL_OPND(tmp_list_idx), 07126 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX( 07127 IR_IDX_L(IL_IDX(trip_list_idx)))))); 07128 07129 COPY_OPND(tmp_opnd, IL_OPND(tmp_list_idx)); 07130 set_up_exp_desc(&tmp_opnd, &exp_desc); 07131 cast_to_cg_default(&tmp_opnd, &exp_desc); 07132 COPY_OPND(IL_OPND(tmp_list_idx), tmp_opnd); 07133 07134 /* replace triplet with tmp control variable */ 07135 07136 IL_FLD(trip_list_idx) = AT_Tbl_Idx; 07137 IL_IDX(trip_list_idx) = tmp_idx; 07138 IL_LINE_NUM(trip_list_idx) = line; 07139 IL_COL_NUM(trip_list_idx) = col; 07140 07141 rank++; 07142 } 07143 07144 07145 07146 sub_list_idx = IL_NEXT_LIST_IDX(sub_list_idx); 07147 } 07148 break; 07149 } 07150 07151 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 07152 } 07153 07154 (*list_idx) = return_list_idx; 07155 07156 TRACE (Func_Exit, "change_section_to_do", NULL); 07157 07158 return(return_imp_idx); 07159 07160 } /* change_section_to_do */ 07161 07162 /******************************************************************************\ 07163 |* *| 07164 |* Description: *| 07165 |* <description> *| 07166 |* *| 07167 |* Input parameters: *| 07168 |* NONE *| 07169 |* *| 07170 |* Output parameters: *| 07171 |* NONE *| 07172 |* *| 07173 |* Returns: *| 07174 |* NOTHING *| 07175 |* *| 07176 \******************************************************************************/ 07177 07178 static void process_deferred_io_list(void) 07179 07180 { 07181 int ir_idx; 07182 int new_root; 07183 int next_stmt_idx; 07184 int save_curr_stmt_sh_idx; 07185 07186 07187 TRACE (Func_Entry, "process_deferred_io_list", NULL); 07188 07189 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 07190 07191 alt_return_branch_idx = NULL_IDX; 07192 07193 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 07194 07195 if (io_stmt_must_be_split) { 07196 07197 if (IR_OPR(ir_idx) == Alt_Return_Opr) { 07198 07199 # ifdef _DEBUG 07200 if (IR_OPR(SH_IR_IDX(SH_NEXT_IDX(curr_stmt_sh_idx))) != Br_True_Opr) { 07201 PRINTMSG(stmt_start_line, 737, Internal, stmt_start_col); 07202 } 07203 # endif 07204 alt_return_branch_idx = SH_IR_IDX(SH_NEXT_IDX(curr_stmt_sh_idx)); 07205 ir_idx = IR_IDX_R(ir_idx); 07206 } 07207 else if (IR_OPR(ir_idx) == Asg_Opr) { 07208 ir_idx = IR_IDX_R(ir_idx); 07209 } 07210 07211 new_root = copy_text_for_expansion(FL_IO_FIRST); 07212 07213 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col, 07214 FALSE, FALSE, TRUE); 07215 07216 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root; 07217 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07218 07219 if (alt_return_branch_idx) { 07220 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col, 07221 FALSE, FALSE, TRUE); 07222 07223 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = alt_return_branch_idx; 07224 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07225 } 07226 07227 if (stmt_type == Inquire_Stmt) { 07228 IL_IDX(IR_IDX_L(ir_idx)) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 07229 FL_IO_MIDDLE); 07230 } 07231 else { 07232 IL_IDX(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)))) = 07233 C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 07234 FL_IO_MIDDLE); 07235 } 07236 07237 new_root = copy_text_for_expansion(FL_IO_LAST); 07238 07239 if (alt_return_branch_idx) { 07240 gen_sh(After, If_Stmt, stmt_start_line, stmt_start_col, 07241 FALSE, FALSE, TRUE); 07242 07243 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx; 07244 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 07245 07246 } 07247 07248 gen_sh(After, stmt_type, stmt_start_line, stmt_start_col, 07249 FALSE, FALSE, TRUE); 07250 07251 SH_IR_IDX(curr_stmt_sh_idx) = new_root; 07252 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 07253 07254 next_stmt_idx = curr_stmt_sh_idx; 07255 07256 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 07257 07258 expand_io_list(); 07259 07260 curr_stmt_sh_idx = next_stmt_idx; 07261 } 07262 else { 07263 next_stmt_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 07264 07265 expand_io_list(); 07266 07267 curr_stmt_sh_idx = SH_PREV_IDX(next_stmt_idx); 07268 } 07269 07270 TRACE (Func_Exit, "process_deferred_io_list", NULL); 07271 07272 return; 07273 07274 } /* process_deferred_io_list */ 07275 07276 /******************************************************************************\ 07277 |* *| 07278 |* Description: *| 07279 |* <description> *| 07280 |* *| 07281 |* Input parameters: *| 07282 |* NONE *| 07283 |* *| 07284 |* Output parameters: *| 07285 |* NONE *| 07286 |* *| 07287 |* Returns: *| 07288 |* NOTHING *| 07289 |* *| 07290 \******************************************************************************/ 07291 07292 static void expand_io_list(void) 07293 07294 { 07295 int cnt = 0; 07296 expr_arg_type exp_desc; 07297 int i; 07298 int imp_idx; 07299 int io_idx; 07300 int ir_idx; 07301 opnd_type left_opnd; 07302 int list_idx; 07303 int new_root; 07304 int next_stmt_idx; 07305 opnd_type opnd; 07306 int prev_list_idx; 07307 int save_curr_stmt_sh_idx; 07308 int struct_list_idx; 07309 int tmp_asg_sh_idx; 07310 int tmp_idx; 07311 07312 07313 TRACE (Func_Entry, "expand_io_list", NULL); 07314 07315 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 07316 07317 next_stmt_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 07318 07319 if (IR_OPR(ir_idx) == Alt_Return_Opr) { 07320 ir_idx = IR_IDX_R(ir_idx); 07321 next_stmt_idx = SH_NEXT_IDX(next_stmt_idx); 07322 } 07323 else if (IR_OPR(ir_idx) == Asg_Opr) { 07324 ir_idx = IR_IDX_R(ir_idx); 07325 } 07326 07327 list_idx = IR_IDX_R(ir_idx); 07328 prev_list_idx = NULL_IDX; 07329 07330 while (list_idx != NULL_IDX) { 07331 cnt++; 07332 new_root = NULL_IDX; 07333 07334 if (IL_NONDEFAULT_IMP_DO_LCV(list_idx)) { 07335 /* put the assignment of the original lcv in place */ 07336 07337 if (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 07338 new_root = copy_text_for_expansion(FL_IO_MIDDLE); 07339 07340 if (IR_OPR(new_root) == Alt_Return_Opr || 07341 IR_OPR(new_root) == Asg_Opr) { 07342 07343 io_idx = IR_IDX_R(new_root); 07344 } 07345 else { 07346 io_idx = new_root; 07347 } 07348 07349 IR_FLD_R(io_idx) = IL_Tbl_Idx; 07350 IR_IDX_R(io_idx) = IL_NEXT_LIST_IDX(list_idx); 07351 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt; 07352 } 07353 07354 gen_sh(After, stmt_type, stmt_start_line, stmt_start_col, 07355 FALSE, FALSE, TRUE); 07356 07357 SH_IR_IDX(curr_stmt_sh_idx) = IL_IDX(IR_IDX_R(IL_IDX(list_idx))); 07358 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 07359 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07360 07361 # ifdef _DEBUG 07362 if (IL_FLD(IR_IDX_R(IL_IDX(list_idx))) != IR_Tbl_Idx || 07363 IR_OPR(IL_IDX(IR_IDX_R(IL_IDX(list_idx)))) != Asg_Opr || 07364 IR_FLD_R(IL_IDX(IR_IDX_R(IL_IDX(list_idx)))) != AT_Tbl_Idx) { 07365 07366 PRINTMSG(stmt_start_line, 1050, Internal, stmt_start_col); 07367 } 07368 # endif 07369 IL_FLD(IR_IDX_R(IL_IDX(list_idx))) = AT_Tbl_Idx; 07370 IL_IDX(IR_IDX_R(IL_IDX(list_idx))) = 07371 IR_IDX_R(IL_IDX(IR_IDX_R(IL_IDX(list_idx)))); 07372 IL_LINE_NUM(IR_IDX_R(IL_IDX(list_idx))) = stmt_start_line; 07373 IL_COL_NUM(IR_IDX_R(IL_IDX(list_idx))) = stmt_start_col; 07374 07375 IL_NONDEFAULT_IMP_DO_LCV(list_idx) = FALSE; 07376 07377 07378 if (new_root) { 07379 07380 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 07381 07382 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 07383 IR_LIST_CNT_R(ir_idx) = cnt; 07384 07385 curr_stmt_sh_idx = next_stmt_idx; 07386 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col, 07387 FALSE, FALSE, TRUE); 07388 07389 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root; 07390 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07391 07392 if (alt_return_branch_idx) { 07393 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col, 07394 FALSE, FALSE, TRUE); 07395 07396 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07397 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx; 07398 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 07399 } 07400 07401 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07402 07403 expand_io_list(); 07404 07405 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 07406 } 07407 } 07408 07409 07410 if (IL_MUST_BE_LOOP(list_idx)) { 07411 07412 if (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 07413 new_root = copy_text_for_expansion(FL_IO_MIDDLE); 07414 07415 if (IR_OPR(new_root) == Alt_Return_Opr || 07416 IR_OPR(new_root) == Asg_Opr) { 07417 07418 io_idx = IR_IDX_R(new_root); 07419 } 07420 else { 07421 io_idx = new_root; 07422 } 07423 07424 IR_FLD_R(io_idx) = IL_Tbl_Idx; 07425 IR_IDX_R(io_idx) = IL_NEXT_LIST_IDX(list_idx); 07426 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt; 07427 } 07428 07429 if (cnt == 1) { 07430 expand_imp_do(list_idx, 0); 07431 } 07432 else { 07433 IL_NEXT_LIST_IDX(prev_list_idx) = NULL_IDX; 07434 IR_LIST_CNT_R(ir_idx) = cnt - 1; 07435 07436 expand_imp_do(list_idx, next_stmt_idx); 07437 } 07438 07439 if (new_root) { 07440 curr_stmt_sh_idx = next_stmt_idx; 07441 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col, 07442 FALSE, FALSE, TRUE); 07443 07444 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root; 07445 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07446 07447 if (alt_return_branch_idx) { 07448 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col, 07449 FALSE, FALSE, TRUE); 07450 07451 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07452 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx; 07453 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 07454 } 07455 07456 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07457 07458 expand_io_list(); 07459 } 07460 07461 break; 07462 } 07463 else if (stmt_type == Read_Stmt && 07464 IL_ARG_DESC_VARIANT(list_idx) && 07465 (arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.vector_subscript || 07466 arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.dist_reshape_ref)) { 07467 07468 COPY_OPND(opnd, IL_OPND(list_idx)); 07469 07470 if (OPND_FLD(opnd) == IR_Tbl_Idx && 07471 IR_OPR(OPND_IDX(opnd)) == Io_Item_Type_Code_Opr) { 07472 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 07473 } 07474 07475 if (IL_HAS_FUNCTIONS(list_idx) || 07476 three_call_model) { 07477 07478 if (cnt > 1) { 07479 07480 new_root = copy_text_for_expansion(FL_IO_MIDDLE); 07481 07482 if (IR_OPR(new_root) == Alt_Return_Opr || 07483 IR_OPR(new_root) == Asg_Opr) { 07484 io_idx = IR_IDX_R(new_root); 07485 } 07486 else { 07487 io_idx = new_root; 07488 } 07489 07490 IR_FLD_R(io_idx) = IL_Tbl_Idx; 07491 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt + 1; 07492 IR_IDX_R(io_idx) = list_idx; 07493 07494 IL_NEXT_LIST_IDX(prev_list_idx) = NULL_IDX; 07495 IR_LIST_CNT_R(ir_idx) = cnt - 1; 07496 07497 curr_stmt_sh_idx = next_stmt_idx; 07498 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col, 07499 FALSE, FALSE, TRUE); 07500 07501 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root; 07502 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07503 07504 if (alt_return_branch_idx) { 07505 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col, 07506 FALSE, FALSE, TRUE); 07507 07508 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07509 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx; 07510 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 07511 } 07512 07513 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07514 ir_idx = io_idx; 07515 cnt = 1; 07516 new_root = NULL_IDX; 07517 } 07518 } 07519 07520 exp_desc = arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed; 07521 process_deferred_functions(&opnd); 07522 07523 gen_runtime_checks(&opnd); 07524 07525 if (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 07526 new_root = copy_text_for_expansion(FL_IO_MIDDLE); 07527 07528 if (IR_OPR(new_root) == Alt_Return_Opr || 07529 IR_OPR(new_root) == Asg_Opr) { 07530 07531 io_idx = IR_IDX_R(new_root); 07532 } 07533 else { 07534 io_idx = new_root; 07535 } 07536 07537 IR_FLD_R(io_idx) = IL_Tbl_Idx; 07538 IR_IDX_R(io_idx) = IL_NEXT_LIST_IDX(list_idx); 07539 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt; 07540 } 07541 07542 07543 /* Create a temp assignment (Before) and then move just the */ 07544 /* tmp asg stmt from before to after. All the other generated */ 07545 /* stmts will be in the right place. Go to tmp asg and switch */ 07546 /* the left and right sides. Then place the temp in the io */ 07547 /* list. If there were more io list items following, split the */ 07548 /* list and start with the new io stmt. */ 07549 07550 tmp_idx = create_tmp_asg(&opnd, 07551 &arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed, 07552 &left_opnd, 07553 Intent_In, 07554 TRUE, 07555 FALSE); 07556 07557 /* move the tmp assign from before the curr stmt to after */ 07558 # ifdef _DEBUG 07559 if (OPND_FLD(left_opnd) == IR_Tbl_Idx && 07560 IR_OPR(OPND_IDX(left_opnd)) == Stmt_Expansion_Opr) { 07561 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 07562 "no Stmt_Expansion_Opr", "expand_io_list"); 07563 } 07564 # endif 07565 07566 tmp_asg_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07567 07568 SH_PREV_IDX(curr_stmt_sh_idx) = SH_PREV_IDX(tmp_asg_sh_idx); 07569 07570 if (SH_PREV_IDX(curr_stmt_sh_idx)) { 07571 SH_NEXT_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = curr_stmt_sh_idx; 07572 } 07573 07574 SH_NEXT_IDX(tmp_asg_sh_idx) = SH_NEXT_IDX(curr_stmt_sh_idx); 07575 if (SH_NEXT_IDX(tmp_asg_sh_idx)) { 07576 SH_PREV_IDX(SH_NEXT_IDX(tmp_asg_sh_idx)) = tmp_asg_sh_idx; 07577 } 07578 SH_NEXT_IDX(curr_stmt_sh_idx) = tmp_asg_sh_idx; 07579 SH_PREV_IDX(tmp_asg_sh_idx) = curr_stmt_sh_idx; 07580 07581 07582 curr_stmt_sh_idx = tmp_asg_sh_idx; 07583 COPY_OPND(IR_OPND_L(SH_IR_IDX(curr_stmt_sh_idx)), 07584 IR_OPND_R(SH_IR_IDX(curr_stmt_sh_idx))); 07585 COPY_OPND(IR_OPND_R(SH_IR_IDX(curr_stmt_sh_idx)), 07586 left_opnd); 07587 07588 copy_subtree(&left_opnd, &left_opnd); 07589 07590 if (IL_FLD(list_idx) == IR_Tbl_Idx && 07591 IR_OPR(IL_IDX(list_idx)) == Io_Item_Type_Code_Opr) { 07592 07593 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), left_opnd); 07594 IR_TYPE_IDX(IL_IDX(list_idx)) = 07595 arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.type_idx; 07596 } 07597 else { 07598 COPY_OPND(IL_OPND(list_idx), left_opnd); 07599 } 07600 07601 if (new_root) { 07602 07603 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 07604 IR_LIST_CNT_R(ir_idx) = cnt; 07605 07606 curr_stmt_sh_idx = next_stmt_idx; 07607 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col, 07608 FALSE, FALSE, TRUE); 07609 07610 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root; 07611 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07612 07613 if (alt_return_branch_idx) { 07614 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col, 07615 FALSE, FALSE, TRUE); 07616 07617 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07618 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx; 07619 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 07620 } 07621 07622 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07623 07624 expand_io_list(); 07625 } 07626 07627 if (IL_STRUCT_REF(list_idx)) { 07628 07629 exp_desc = arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed; 07630 07631 if (exp_desc.rank > 0) { 07632 struct_list_idx = list_idx; 07633 imp_idx = change_section_to_do(&struct_list_idx); 07634 COPY_OPND(opnd, IL_OPND(struct_list_idx)); 07635 i = discombobulate_structure_ref(&opnd, 07636 TYP_IDX(exp_desc.type_idx), 07637 &struct_list_idx); 07638 IR_LIST_CNT_L(imp_idx) += i; 07639 } 07640 else { 07641 COPY_OPND(opnd, IL_OPND(list_idx)); 07642 i = discombobulate_structure_ref(&opnd, 07643 TYP_IDX(exp_desc.type_idx), 07644 &list_idx); 07645 IR_LIST_CNT_R(ir_idx) += i; 07646 } 07647 } 07648 07649 break; 07650 } 07651 else if (IL_MUST_FLATTEN(list_idx) && FALSE ) { 07652 07653 COPY_OPND(opnd, IL_OPND(list_idx)); 07654 07655 if (OPND_FLD(opnd) == IR_Tbl_Idx && 07656 IR_OPR(OPND_IDX(opnd)) == Io_Item_Type_Code_Opr) { 07657 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 07658 } 07659 07660 if (IL_HAS_FUNCTIONS(list_idx) || 07661 three_call_model) { 07662 07663 if ((stmt_type == Read_Stmt || 07664 three_call_model) && 07665 cnt > 1) { 07666 07667 new_root = copy_text_for_expansion(FL_IO_MIDDLE); 07668 07669 if (IR_OPR(new_root) == Alt_Return_Opr || 07670 IR_OPR(new_root) == Asg_Opr) { 07671 io_idx = IR_IDX_R(new_root); 07672 } 07673 else { 07674 io_idx = new_root; 07675 } 07676 07677 IR_FLD_R(io_idx) = IL_Tbl_Idx; 07678 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt + 1; 07679 IR_IDX_R(io_idx) = list_idx; 07680 07681 IL_NEXT_LIST_IDX(prev_list_idx) = NULL_IDX; 07682 IR_LIST_CNT_R(ir_idx) = cnt - 1; 07683 07684 curr_stmt_sh_idx = next_stmt_idx; 07685 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col, 07686 FALSE, FALSE, TRUE); 07687 07688 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root; 07689 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07690 07691 if (alt_return_branch_idx) { 07692 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col, 07693 FALSE, FALSE, TRUE); 07694 07695 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07696 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx; 07697 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 07698 } 07699 07700 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07701 ir_idx = io_idx; 07702 cnt = 1; 07703 } 07704 07705 } 07706 07707 exp_desc = arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed; 07708 process_deferred_functions(&opnd); 07709 07710 gen_runtime_checks(&opnd); 07711 07712 tmp_idx = create_tmp_asg(&opnd, 07713 &arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed, 07714 &left_opnd, 07715 (stmt_type == Read_Stmt ? 07716 Intent_Out : Intent_In), 07717 TRUE, 07718 FALSE); 07719 07720 copy_subtree(&left_opnd, &left_opnd); 07721 07722 if (IL_FLD(list_idx) == IR_Tbl_Idx && 07723 IR_OPR(IL_IDX(list_idx)) == Io_Item_Type_Code_Opr) { 07724 07725 COPY_OPND(IR_OPND_L(IL_IDX(list_idx)), left_opnd); 07726 IR_TYPE_IDX(IL_IDX(list_idx)) = 07727 arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed.type_idx; 07728 } 07729 else { 07730 COPY_OPND(IL_OPND(list_idx), left_opnd); 07731 } 07732 } 07733 else if (IL_HAS_FUNCTIONS(list_idx) || 07734 three_call_model) { 07735 07736 if ((stmt_type == Read_Stmt || 07737 three_call_model) && 07738 cnt > 1) { 07739 07740 new_root = copy_text_for_expansion(FL_IO_MIDDLE); 07741 07742 if (IR_OPR(new_root) == Alt_Return_Opr || 07743 IR_OPR(new_root) == Asg_Opr) { 07744 07745 io_idx = IR_IDX_R(new_root); 07746 } 07747 else { 07748 io_idx = new_root; 07749 } 07750 07751 IR_FLD_R(io_idx) = IL_Tbl_Idx; 07752 IR_LIST_CNT_R(io_idx) = IR_LIST_CNT_R(ir_idx) - cnt + 1; 07753 IR_IDX_R(io_idx) = list_idx; 07754 07755 IL_NEXT_LIST_IDX(prev_list_idx) = NULL_IDX; 07756 IR_LIST_CNT_R(ir_idx) = cnt - 1; 07757 07758 curr_stmt_sh_idx = next_stmt_idx; 07759 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col, 07760 FALSE, FALSE, TRUE); 07761 07762 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root; 07763 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07764 07765 if (alt_return_branch_idx) { 07766 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col, 07767 FALSE, FALSE, TRUE); 07768 07769 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07770 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx; 07771 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 07772 } 07773 07774 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07775 ir_idx = io_idx; 07776 cnt = 1; 07777 } 07778 07779 COPY_OPND(opnd, IL_OPND(list_idx)); 07780 process_deferred_functions(&opnd); 07781 COPY_OPND(IL_OPND(list_idx), opnd); 07782 07783 gen_runtime_checks(&opnd); 07784 } 07785 else if (IL_HAS_CONSTRUCTOR(list_idx)) { 07786 COPY_OPND(opnd, IL_OPND(list_idx)); 07787 process_deferred_functions(&opnd); 07788 COPY_OPND(IL_OPND(list_idx), opnd); 07789 07790 gen_runtime_checks(&opnd); 07791 } 07792 07793 if (IL_STRUCT_REF(list_idx)) { 07794 07795 exp_desc = arg_info_list[IL_ARG_DESC_IDX(list_idx)].ed; 07796 07797 if (exp_desc.rank > 0) { 07798 struct_list_idx = list_idx; 07799 imp_idx = change_section_to_do(&struct_list_idx); 07800 COPY_OPND(opnd, IL_OPND(struct_list_idx)); 07801 i = discombobulate_structure_ref(&opnd, 07802 TYP_IDX(exp_desc.type_idx), 07803 &struct_list_idx); 07804 IR_LIST_CNT_L(imp_idx) += i; 07805 } 07806 else { 07807 COPY_OPND(opnd, IL_OPND(list_idx)); 07808 i = discombobulate_structure_ref(&opnd, 07809 TYP_IDX(exp_desc.type_idx), 07810 &list_idx); 07811 IR_LIST_CNT_R(ir_idx) += i; 07812 } 07813 } 07814 07815 prev_list_idx = list_idx; 07816 list_idx = IL_NEXT_LIST_IDX(list_idx); 07817 } 07818 07819 TRACE (Func_Exit, "expand_io_list", NULL); 07820 07821 return; 07822 07823 } /* expand_io_list */ 07824 07825 /******************************************************************************\ 07826 |* *| 07827 |* Description: *| 07828 |* <description> *| 07829 |* *| 07830 |* Input parameters: *| 07831 |* NONE *| 07832 |* *| 07833 |* Output parameters: *| 07834 |* NONE *| 07835 |* *| 07836 |* Returns: *| 07837 |* NOTHING *| 07838 |* *| 07839 \******************************************************************************/ 07840 07841 static void expand_imp_do(int top_list_idx, 07842 int next_stmt_idx) 07843 07844 { 07845 opnd_type end_opnd; 07846 int imp_do_idx; 07847 opnd_type inc_opnd; 07848 int io_idx; 07849 int ir_idx; 07850 int lcv_attr; 07851 int list_idx; 07852 int new_root; 07853 opnd_type start_opnd; 07854 07855 07856 TRACE (Func_Entry, "expand_imp_do", NULL); 07857 07858 # ifdef _DEBUG 07859 if (! io_stmt_must_be_split) { 07860 PRINTMSG(stmt_start_line, 433, Internal, stmt_start_col); 07861 } 07862 # endif 07863 07864 imp_do_idx = IL_IDX(top_list_idx); 07865 07866 ir_idx = SH_IR_IDX(curr_stmt_sh_idx); 07867 07868 if (IR_OPR(ir_idx) == Alt_Return_Opr || 07869 IR_OPR(ir_idx) == Asg_Opr) { 07870 07871 ir_idx = IR_IDX_R(ir_idx); 07872 } 07873 07874 if (next_stmt_idx) { 07875 07876 new_root = copy_text_for_expansion(FL_IO_MIDDLE); 07877 07878 if (IR_OPR(new_root) == Alt_Return_Opr || 07879 IR_OPR(new_root) == Asg_Opr) { 07880 07881 io_idx = IR_IDX_R(new_root); 07882 } 07883 else { 07884 io_idx = new_root; 07885 } 07886 07887 COPY_OPND(IR_OPND_R(io_idx), IR_OPND_L(imp_do_idx)); 07888 07889 curr_stmt_sh_idx = next_stmt_idx; 07890 gen_sh(Before, stmt_type, stmt_start_line, stmt_start_col, 07891 FALSE, FALSE, TRUE); 07892 07893 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = new_root; 07894 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 07895 07896 if (alt_return_branch_idx) { 07897 gen_sh(Before, If_Stmt, stmt_start_line, stmt_start_col, 07898 FALSE, FALSE, TRUE); 07899 07900 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07901 SH_IR_IDX(curr_stmt_sh_idx) = alt_return_branch_idx; 07902 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 07903 } 07904 07905 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 07906 07907 } 07908 else { 07909 /* this is the first item */ 07910 /* so no new stmt. */ 07911 07912 COPY_OPND(IR_OPND_R(ir_idx), IR_OPND_L(imp_do_idx)); 07913 } 07914 07915 /* process right side first */ 07916 07917 list_idx = IR_IDX_R(imp_do_idx); 07918 lcv_attr = IL_IDX(list_idx); 07919 list_idx = IL_NEXT_LIST_IDX(list_idx); 07920 COPY_OPND(start_opnd, IL_OPND(list_idx)); 07921 07922 if (IL_HAS_FUNCTIONS(list_idx)) { 07923 process_deferred_functions(&start_opnd); 07924 COPY_OPND(IL_OPND(list_idx), start_opnd); 07925 } 07926 07927 gen_runtime_checks(&start_opnd); 07928 07929 list_idx = IL_NEXT_LIST_IDX(list_idx); 07930 COPY_OPND(end_opnd, IL_OPND(list_idx)); 07931 07932 if (IL_HAS_FUNCTIONS(list_idx)) { 07933 process_deferred_functions(&end_opnd); 07934 COPY_OPND(IL_OPND(list_idx), end_opnd); 07935 } 07936 07937 gen_runtime_checks(&end_opnd); 07938 07939 list_idx = IL_NEXT_LIST_IDX(list_idx); 07940 COPY_OPND(inc_opnd, IL_OPND(list_idx)); 07941 07942 if (IL_HAS_FUNCTIONS(list_idx)) { 07943 process_deferred_functions(&inc_opnd); 07944 COPY_OPND(IL_OPND(list_idx), inc_opnd); 07945 } 07946 07947 gen_runtime_checks(&inc_opnd); 07948 07949 create_loop_stmts(lcv_attr, &start_opnd, &end_opnd, &inc_opnd, 07950 curr_stmt_sh_idx, 07951 (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) == Alt_Return_Opr ? 07952 SH_NEXT_IDX(curr_stmt_sh_idx) : curr_stmt_sh_idx)); 07953 07954 expand_io_list(); 07955 07956 TRACE (Func_Exit, "expand_imp_do", NULL); 07957 07958 return; 07959 07960 } /* expand_imp_do */ 07961 07962 /******************************************************************************\ 07963 |* *| 07964 |* Description: *| 07965 |* <description> *| 07966 |* *| 07967 |* Input parameters: *| 07968 |* NONE *| 07969 |* *| 07970 |* Output parameters: *| 07971 |* NONE *| 07972 |* *| 07973 |* Returns: *| 07974 |* NOTHING *| 07975 |* *| 07976 \******************************************************************************/ 07977 07978 static int copy_text_for_expansion(int flflag) 07979 07980 { 07981 int new_alt_idx; 07982 int new_io_idx; 07983 int new_root; 07984 int old_alt_idx; 07985 int old_io_idx; 07986 opnd_type opnd; 07987 07988 07989 TRACE (Func_Entry, "copy_text_for_expansion", NULL); 07990 07991 # ifdef _DEBUG 07992 if (! io_stmt_must_be_split) { 07993 PRINTMSG(stmt_start_line, 433, Internal, stmt_start_col); 07994 } 07995 # endif 07996 07997 if (alt_return_branch_idx || 07998 stmt_type == Inquire_Stmt) { 07999 08000 NTR_IR_TBL(new_alt_idx); 08001 old_alt_idx = SH_IR_IDX(curr_stmt_sh_idx); 08002 COPY_TBL_NTRY(ir_tbl, new_alt_idx, old_alt_idx); 08003 NTR_IR_TBL(new_io_idx); 08004 old_io_idx = IR_IDX_R(old_alt_idx); 08005 COPY_TBL_NTRY(ir_tbl, new_io_idx, old_io_idx); 08006 IR_OPND_R(new_io_idx) = null_opnd; 08007 IR_IDX_R(new_alt_idx) = new_io_idx; 08008 new_root = new_alt_idx; 08009 } 08010 else { 08011 NTR_IR_TBL(new_io_idx); 08012 old_io_idx = SH_IR_IDX(curr_stmt_sh_idx); 08013 COPY_TBL_NTRY(ir_tbl, new_io_idx, old_io_idx); 08014 IR_OPND_R(new_io_idx) = null_opnd; 08015 new_root = new_io_idx; 08016 } 08017 08018 copy_subtree(&IR_OPND_L(old_io_idx), &opnd); 08019 COPY_OPND(IR_OPND_L(new_io_idx), opnd); 08020 08021 if (stmt_type == Inquire_Stmt) { 08022 IL_IDX(IR_IDX_L(new_io_idx)) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08023 flflag); 08024 } 08025 else { 08026 IL_IDX(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L(new_io_idx)))) = 08027 C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08028 flflag); 08029 } 08030 08031 TRACE (Func_Exit, "copy_text_for_expansion", NULL); 08032 08033 return(new_root); 08034 08035 } /* copy_text_for_expansion */ 08036 08037 /******************************************************************************\ 08038 |* *| 08039 |* Description: *| 08040 |* Create the argument descriptor for calls to open, close, inquire, *| 08041 |* buffer in, and buffer out. *| 08042 |* *| 08043 |* Input parameters: *| 08044 |* NONE *| 08045 |* *| 08046 |* Output parameters: *| 08047 |* NONE *| 08048 |* *| 08049 |* Returns: *| 08050 |* NOTHING *| 08051 |* *| 08052 \******************************************************************************/ 08053 08054 static void create_io_call_descriptor(int call_idx, 08055 io_descriptor_type call_type) 08056 08057 { 08058 int asg_idx; 08059 int bd_idx; 08060 int col; 08061 boolean gen_descriptor; 08062 int item_cnt; 08063 int line; 08064 int list_idx; 08065 int list2_idx; 08066 int loc_idx; 08067 int offset; 08068 int shift_idx; 08069 int subscript_idx; 08070 long64 the_constant; 08071 int tmp_idx; 08072 int type_idx; 08073 int version_cn_idx; 08074 08075 # define IO_CALL_VERSION 0 08076 08077 08078 TRACE (Func_Entry, "create_io_call_descriptor", NULL); 08079 08080 col = IR_COL_NUM(call_idx); 08081 line = IR_LINE_NUM(call_idx); 08082 08083 # if defined(GENERATE_WHIRL) 08084 type_idx = SA_INTEGER_DEFAULT_TYPE; 08085 # else 08086 type_idx = CG_INTEGER_DEFAULT_TYPE; 08087 # endif 08088 08089 version_cn_idx = C_INT_TO_CN(type_idx, IO_CALL_VERSION); /* BRIANJ */ 08090 08091 # if defined(_FILE_IO_OPRS) 08092 if (call_type == Buffer_Desc) { 08093 gen_descriptor = TRUE; 08094 } 08095 else { 08096 gen_descriptor = FALSE; 08097 } 08098 # else 08099 gen_descriptor = TRUE; 08100 # endif 08101 08102 if (! gen_descriptor) { 08103 /* place version constant as first list item */ 08104 NTR_IR_LIST_TBL(list_idx); 08105 IL_NEXT_LIST_IDX(list_idx) = IR_IDX_R(call_idx); 08106 IR_IDX_R(call_idx) = list_idx; 08107 IR_LIST_CNT_R(call_idx) += 1; 08108 08109 IL_FLD(list_idx) = CN_Tbl_Idx; 08110 IL_IDX(list_idx) = version_cn_idx; 08111 IL_LINE_NUM(list_idx) = line; 08112 IL_COL_NUM(list_idx) = col; 08113 08114 } 08115 else { 08116 /* create integer array for descriptor */ 08117 08118 tmp_idx = gen_compiler_tmp(line, col, Priv, TRUE); 08119 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 08120 ATD_TYPE_IDX(tmp_idx) = type_idx; 08121 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 08122 08123 bd_idx = reserve_array_ntry(1); 08124 BD_RANK(bd_idx) = 1; 08125 BD_ARRAY_CLASS(bd_idx) = Explicit_Shape; 08126 BD_ARRAY_SIZE(bd_idx) = Constant_Size; 08127 BD_LINE_NUM(bd_idx) = line; 08128 BD_COLUMN_NUM(bd_idx) = col; 08129 BD_RESOLVED(bd_idx) = TRUE; 08130 08131 if (two_word_fcd) { 08132 the_constant = descriptor_size_tbl[call_type]; 08133 } 08134 else { 08135 the_constant = 1 + IR_LIST_CNT_R(call_idx); 08136 } 08137 08138 # if defined(GENERATE_WHIRL) 08139 /* the version item is always 64 bits */ 08140 if (TYP_LINEAR(type_idx) == Integer_4) { 08141 the_constant++; 08142 } 08143 # endif 08144 08145 BD_LEN_FLD(bd_idx) = CN_Tbl_Idx; 08146 BD_LEN_IDX(bd_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08147 the_constant); 08148 08149 BD_LB_FLD(bd_idx, 1) = CN_Tbl_Idx; 08150 BD_LB_IDX(bd_idx, 1) = CN_INTEGER_ONE_IDX; 08151 08152 BD_UB_FLD(bd_idx, 1) = CN_Tbl_Idx; 08153 BD_UB_IDX(bd_idx, 1) = BD_LEN_IDX(bd_idx); 08154 08155 BD_XT_FLD(bd_idx, 1) = CN_Tbl_Idx; 08156 BD_XT_IDX(bd_idx, 1) = BD_LEN_IDX(bd_idx); 08157 08158 BD_SM_FLD(bd_idx, 1) = CN_Tbl_Idx; 08159 BD_SM_IDX(bd_idx, 1) = CN_INTEGER_ONE_IDX; 08160 08161 ATD_ARRAY_IDX(tmp_idx) = ntr_array_in_bd_tbl(bd_idx); 08162 08163 08164 /* fill in the descriptor fields */ 08165 08166 item_cnt = 0; 08167 08168 NTR_IR_TBL(asg_idx); 08169 IR_OPR(asg_idx) = Asg_Opr; 08170 IR_TYPE_IDX(asg_idx) = type_idx; 08171 IR_LINE_NUM(asg_idx) = line; 08172 IR_COL_NUM(asg_idx) = col; 08173 NTR_IR_TBL(subscript_idx); 08174 IR_OPR(subscript_idx) = Subscript_Opr; 08175 IR_TYPE_IDX(subscript_idx) = type_idx; 08176 IR_LINE_NUM(subscript_idx) = line; 08177 IR_COL_NUM(subscript_idx) = col; 08178 IR_FLD_L(subscript_idx) = AT_Tbl_Idx; 08179 IR_IDX_L(subscript_idx) = tmp_idx; 08180 IR_LINE_NUM_L(subscript_idx) = line; 08181 IR_COL_NUM_L(subscript_idx) = col; 08182 08183 NTR_IR_LIST_TBL(list2_idx); 08184 IR_FLD_R(subscript_idx) = IL_Tbl_Idx; 08185 IR_LIST_CNT_R(subscript_idx) = 1; 08186 IR_IDX_R(subscript_idx) = list2_idx; 08187 IL_FLD(list2_idx) = CN_Tbl_Idx; 08188 IL_IDX(list2_idx) = CN_INTEGER_ONE_IDX; 08189 IL_LINE_NUM(list2_idx) = line; 08190 IL_COL_NUM(list2_idx) = col; 08191 08192 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 08193 IR_IDX_L(asg_idx) = subscript_idx; 08194 08195 IR_FLD_R(asg_idx) = CN_Tbl_Idx; 08196 # if defined(GENERATE_WHIRL) 08197 if (TYP_LINEAR(type_idx) == Integer_4) { 08198 IR_IDX_R(asg_idx) = CN_INTEGER_ZERO_IDX; 08199 } 08200 else { 08201 IR_IDX_R(asg_idx) = version_cn_idx; 08202 } 08203 # else 08204 IR_IDX_R(asg_idx) = version_cn_idx; 08205 # endif 08206 IR_LINE_NUM_R(asg_idx) = line; 08207 IR_COL_NUM_R(asg_idx) = col; 08208 08209 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 08210 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 08211 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 08212 08213 item_cnt++; 08214 the_constant = 2; 08215 08216 # if defined(GENERATE_WHIRL) 08217 if (TYP_LINEAR(type_idx) == Integer_4) { 08218 NTR_IR_TBL(asg_idx); 08219 IR_OPR(asg_idx) = Asg_Opr; 08220 IR_TYPE_IDX(asg_idx) = type_idx; 08221 IR_LINE_NUM(asg_idx) = line; 08222 IR_COL_NUM(asg_idx) = col; 08223 NTR_IR_TBL(subscript_idx); 08224 IR_OPR(subscript_idx) = Subscript_Opr; 08225 IR_TYPE_IDX(subscript_idx) = type_idx; 08226 IR_LINE_NUM(subscript_idx) = line; 08227 IR_COL_NUM(subscript_idx) = col; 08228 IR_FLD_L(subscript_idx) = AT_Tbl_Idx; 08229 IR_IDX_L(subscript_idx) = tmp_idx; 08230 IR_LINE_NUM_L(subscript_idx) = line; 08231 IR_COL_NUM_L(subscript_idx) = col; 08232 08233 NTR_IR_LIST_TBL(list2_idx); 08234 IR_FLD_R(subscript_idx) = IL_Tbl_Idx; 08235 IR_LIST_CNT_R(subscript_idx) = 1; 08236 IR_IDX_R(subscript_idx) = list2_idx; 08237 IL_FLD(list2_idx) = CN_Tbl_Idx; 08238 IL_IDX(list2_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08239 the_constant); 08240 IL_LINE_NUM(list2_idx) = line; 08241 IL_COL_NUM(list2_idx) = col; 08242 08243 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 08244 IR_IDX_L(asg_idx) = subscript_idx; 08245 08246 IR_FLD_R(asg_idx) = CN_Tbl_Idx; 08247 IR_IDX_R(asg_idx) = version_cn_idx; 08248 IR_LINE_NUM_R(asg_idx) = line; 08249 IR_COL_NUM_R(asg_idx) = col; 08250 08251 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 08252 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 08253 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 08254 08255 the_constant++; 08256 } 08257 # endif 08258 08259 list_idx = IR_IDX_R(call_idx); 08260 08261 while (list_idx) { 08262 08263 NTR_IR_TBL(asg_idx); 08264 IR_OPR(asg_idx) = Asg_Opr; 08265 IR_TYPE_IDX(asg_idx) = type_idx; 08266 IR_LINE_NUM(asg_idx) = line; 08267 IR_COL_NUM(asg_idx) = col; 08268 NTR_IR_TBL(subscript_idx); 08269 IR_OPR(subscript_idx) = Subscript_Opr; 08270 IR_TYPE_IDX(subscript_idx) = type_idx; 08271 IR_LINE_NUM(subscript_idx) = line; 08272 IR_COL_NUM(subscript_idx) = col; 08273 IR_FLD_L(subscript_idx) = AT_Tbl_Idx; 08274 IR_IDX_L(subscript_idx) = tmp_idx; 08275 IR_LINE_NUM_L(subscript_idx) = line; 08276 IR_COL_NUM_L(subscript_idx) = col; 08277 08278 NTR_IR_LIST_TBL(list2_idx); 08279 IR_FLD_R(subscript_idx) = IL_Tbl_Idx; 08280 IR_LIST_CNT_R(subscript_idx) = 1; 08281 IR_IDX_R(subscript_idx) = list2_idx; 08282 IL_FLD(list2_idx) = CN_Tbl_Idx; 08283 IL_IDX(list2_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08284 the_constant); 08285 IL_LINE_NUM(list2_idx) = line; 08286 IL_COL_NUM(list2_idx) = col; 08287 08288 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 08289 IR_IDX_L(asg_idx) = subscript_idx; 08290 08291 if (IL_FLD(list_idx) == IR_Tbl_Idx && 08292 IR_OPR(IL_IDX(list_idx)) == Aloc_Opr) { 08293 08294 IR_OPR(IL_IDX(list_idx)) = Loc_Opr; 08295 } 08296 08297 COPY_OPND(IR_OPND_R(asg_idx), IL_OPND(list_idx)); 08298 08299 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 08300 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 08301 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 08302 08303 offset = offset_tbl[call_type][item_cnt]; 08304 08305 if (two_word_fcd) { 08306 08307 if (IL_FLD(list_idx) != IR_Tbl_Idx || 08308 IR_OPR(IL_IDX(list_idx)) != Loc_Opr || 08309 TYP_LINEAR(IR_TYPE_IDX(IL_IDX(list_idx))) != CRI_Ch_Ptr_8) { 08310 /* no character argument */ 08311 the_constant += offset; 08312 } 08313 else { 08314 the_constant++; 08315 08316 if (offset == 2) { 08317 /* fill in the length */ 08318 NTR_IR_TBL(asg_idx); 08319 IR_OPR(asg_idx) = Asg_Opr; 08320 IR_TYPE_IDX(asg_idx) = type_idx; 08321 IR_LINE_NUM(asg_idx) = line; 08322 IR_COL_NUM(asg_idx) = col; 08323 NTR_IR_TBL(subscript_idx); 08324 IR_OPR(subscript_idx) = Subscript_Opr; 08325 IR_TYPE_IDX(subscript_idx) = type_idx; 08326 IR_LINE_NUM(subscript_idx) = line; 08327 IR_COL_NUM(subscript_idx) = col; 08328 IR_FLD_L(subscript_idx) = AT_Tbl_Idx; 08329 IR_IDX_L(subscript_idx) = tmp_idx; 08330 IR_LINE_NUM_L(subscript_idx) = line; 08331 IR_COL_NUM_L(subscript_idx) = col; 08332 08333 NTR_IR_LIST_TBL(list2_idx); 08334 IR_FLD_R(subscript_idx) = IL_Tbl_Idx; 08335 IR_LIST_CNT_R(subscript_idx) = 1; 08336 IR_IDX_R(subscript_idx) = list2_idx; 08337 IL_FLD(list2_idx) = CN_Tbl_Idx; 08338 IL_IDX(list2_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08339 the_constant); 08340 IL_LINE_NUM(list2_idx) = line; 08341 IL_COL_NUM(list2_idx) = col; 08342 08343 IR_FLD_L(asg_idx) = IR_Tbl_Idx; 08344 IR_IDX_L(asg_idx) = subscript_idx; 08345 08346 # ifdef _DEBUG 08347 if (IL_FLD(list_idx) != IR_Tbl_Idx || 08348 IR_OPR(IL_IDX(list_idx)) != Loc_Opr || 08349 IR_FLD_L(IL_IDX(list_idx)) != IR_Tbl_Idx || 08350 (IR_OPR(IR_IDX_L(IL_IDX(list_idx))) != Substring_Opr && 08351 IR_OPR(IR_IDX_L(IL_IDX(list_idx))) != 08352 Whole_Substring_Opr)) { 08353 08354 PRINTMSG(line, 1022, Internal, col); 08355 } 08356 # endif 08357 08358 if (char_len_in_bytes) { 08359 /* length is in bytes on solaris */ 08360 COPY_OPND(IR_OPND_R(asg_idx), 08361 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_R( 08362 IR_IDX_L(IL_IDX(list_idx))))))); 08363 } 08364 else { 08365 /* length is in bits on mpp. shift left 3 */ 08366 NTR_IR_TBL(shift_idx); 08367 IR_OPR(shift_idx) = Shiftl_Opr; 08368 IR_TYPE_IDX(shift_idx) = type_idx; 08369 IR_LINE_NUM(shift_idx) = line; 08370 IR_COL_NUM(shift_idx) = col; 08371 08372 NTR_IR_LIST_TBL(list2_idx); 08373 IR_FLD_L(shift_idx) = IL_Tbl_Idx; 08374 IR_IDX_L(shift_idx) = list2_idx; 08375 IR_LIST_CNT_L(shift_idx) = 2; 08376 08377 COPY_OPND(IL_OPND(list2_idx), 08378 IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_R( 08379 IR_IDX_L(IL_IDX(list_idx))))))); 08380 08381 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx)); 08382 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx; 08383 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 08384 08385 IL_LINE_NUM(list2_idx) = line; 08386 IL_COL_NUM(list2_idx) = col; 08387 IL_FLD(list2_idx) = CN_Tbl_Idx; 08388 IL_IDX(list2_idx) = CN_INTEGER_THREE_IDX; 08389 IR_FLD_R(asg_idx) = IR_Tbl_Idx; 08390 IR_IDX_R(asg_idx) = shift_idx; 08391 } 08392 08393 gen_sh(Before,Assignment_Stmt,line,col,FALSE,FALSE,TRUE); 08394 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 08395 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 08396 08397 the_constant++; 08398 } 08399 } 08400 } 08401 else { 08402 the_constant++; 08403 } 08404 08405 list_idx = IL_NEXT_LIST_IDX(list_idx); 08406 item_cnt++; 08407 } 08408 08409 /* replace the call list with the descriptor */ 08410 08411 # if 0 08412 if (IR_IDX_L(call_idx) == glb_tbl_idx[Buffer_In_Attr_Idx] || 08413 IR_IDX_L(call_Idx) == glb_tbl_idx[Buffer_Out_Attr_Idx]) { 08414 08415 list_idx = IR_IDX_R(call_idx); 08416 } 08417 else { 08418 IR_LIST_CNT_R(call_idx) = 1; 08419 NTR_IR_LIST_TBL(list_idx); 08420 IR_IDX_R(call_idx) = list_idx; 08421 } 08422 # else 08423 08424 IR_LIST_CNT_R(call_idx) = 1; 08425 NTR_IR_LIST_TBL(list_idx); 08426 IR_IDX_R(call_idx) = list_idx; 08427 08428 # endif 08429 08430 NTR_IR_TBL(loc_idx); 08431 IR_OPR(loc_idx) = Aloc_Opr; 08432 IR_TYPE_IDX(loc_idx) = CRI_Ptr_8; 08433 IR_LINE_NUM(loc_idx) = line; 08434 IR_COL_NUM(loc_idx) = col; 08435 08436 IR_FLD_L(loc_idx) = AT_Tbl_Idx; 08437 IR_IDX_L(loc_idx) = tmp_idx; 08438 IR_LINE_NUM_L(loc_idx) = line; 08439 IR_COL_NUM_L(loc_idx) = col; 08440 08441 IL_FLD(list_idx) = IR_Tbl_Idx; 08442 IL_IDX(list_idx) = loc_idx; 08443 08444 } 08445 08446 TRACE (Func_Exit, "create_io_call_descriptor", NULL); 08447 08448 return; 08449 08450 } /* create_io_call_descriptor */ 08451 08452 /******************************************************************************\ 08453 |* *| 08454 |* Description: *| 08455 |* <description> *| 08456 |* *| 08457 |* Input parameters: *| 08458 |* NONE *| 08459 |* *| 08460 |* Output parameters: *| 08461 |* NONE *| 08462 |* *| 08463 |* Returns: *| 08464 |* NOTHING *| 08465 |* *| 08466 \******************************************************************************/ 08467 08468 void set_sb_first_attr_idx(int attr_idx) 08469 08470 { 08471 int tmp_idx; 08472 int type_idx; 08473 08474 TRACE (Func_Entry, "set_sb_first_attr_idx", NULL); 08475 08476 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 08477 TYP_TYPE(TYP_WORK_IDX) = Typeless; 08478 TYP_LINEAR(TYP_WORK_IDX) = Long_Typeless; 08479 TYP_BIT_LEN(TYP_WORK_IDX) = CHAR_BIT; 08480 type_idx = ntr_type_tbl(); 08481 08482 tmp_idx = gen_compiler_tmp(stmt_start_line, stmt_start_col, Priv, TRUE); 08483 08484 ATD_TYPE_IDX(tmp_idx) = type_idx; 08485 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 08486 ATD_OFFSET_ASSIGNED(tmp_idx) = TRUE; 08487 ATD_OFFSET_IDX(tmp_idx) = CN_INTEGER_ZERO_IDX; 08488 ATD_OFFSET_FLD(tmp_idx) = CN_Tbl_Idx; 08489 08490 ATD_STOR_BLK_IDX(tmp_idx) = ATD_STOR_BLK_IDX(attr_idx); 08491 08492 SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) = tmp_idx; 08493 08494 TRACE (Func_Exit, "set_sb_first_attr_idx", NULL); 08495 08496 return; 08497 08498 } /* set_sb_first_attr_idx */ 08499 08500 /******************************************************************************\ 08501 |* *| 08502 |* Description: *| 08503 |* <description> *| 08504 |* *| 08505 |* Input parameters: *| 08506 |* NONE *| 08507 |* *| 08508 |* Output parameters: *| 08509 |* NONE *| 08510 |* *| 08511 |* Returns: *| 08512 |* NOTHING *| 08513 |* *| 08514 \******************************************************************************/ 08515 08516 # ifdef _NO_IO_ALTERNATE_RETURN 08517 static void add_alt_return_lbl(int ir_idx, 08518 int lbl_attr_idx) 08519 08520 { 08521 08522 int list_idx; 08523 08524 TRACE (Func_Entry, "add_alt_return_lbl", NULL); 08525 08526 list_idx = IR_IDX_R(ir_idx); 08527 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) { 08528 list_idx = IL_NEXT_LIST_IDX(list_idx); 08529 } 08530 08531 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 08532 IL_ARG_DESC_VARIANT(IL_NEXT_LIST_IDX(list_idx)) = TRUE; 08533 list_idx = IL_NEXT_LIST_IDX(list_idx); 08534 08535 if (lbl_attr_idx != NULL_IDX) { 08536 IL_FLD(list_idx) = AT_Tbl_Idx; 08537 IL_IDX(list_idx) = lbl_attr_idx; 08538 } 08539 IL_LINE_NUM(list_idx) = IR_LINE_NUM(ir_idx); 08540 IL_COL_NUM(list_idx) = IR_COL_NUM(ir_idx); 08541 08542 IR_LIST_CNT_R(ir_idx) += 1; 08543 08544 TRACE (Func_Exit, "add_alt_return_lbl", NULL); 08545 08546 return; 08547 08548 } /* add_alt_return_lbl */ 08549 # endif 08550 08551 /******************************************************************************\ 08552 |* *| 08553 |* Description: *| 08554 |* <description> *| 08555 |* *| 08556 |* Input parameters: *| 08557 |* NONE *| 08558 |* *| 08559 |* Output parameters: *| 08560 |* NONE *| 08561 |* *| 08562 |* Returns: *| 08563 |* NOTHING *| 08564 |* *| 08565 \******************************************************************************/ 08566 08567 static boolean item_has_bounds_chk(opnd_type *top_opnd) 08568 08569 { 08570 08571 boolean bounds_chk = FALSE; 08572 int ir_idx; 08573 int list_idx; 08574 opnd_type opnd; 08575 08576 TRACE (Func_Entry, "item_has_bounds_chk", NULL); 08577 08578 switch (OPND_FLD((*top_opnd))) { 08579 case IR_Tbl_Idx: 08580 ir_idx = OPND_IDX((*top_opnd)); 08581 08582 if (IR_OPR(ir_idx) == Substring_Opr && 08583 cmd_line_flags.runtime_substring && 08584 ATD_CLASS(find_left_attr(&IR_OPND_L(ir_idx))) != Compiler_Tmp) { 08585 08586 bounds_chk = TRUE; 08587 } 08588 else if ((IR_OPR(ir_idx) == Subscript_Opr || 08589 IR_OPR(ir_idx) == Section_Subscript_Opr) && 08590 needs_bounds_check(ir_idx)) { 08591 08592 bounds_chk = TRUE; 08593 } 08594 else if (IR_OPR(ir_idx) == Dv_Deref_Opr && 08595 cmd_line_flags.runtime_ptr_chk && 08596 ATD_CLASS(find_left_attr(&IR_OPND_L(ir_idx))) != Compiler_Tmp) { 08597 08598 bounds_chk = TRUE; 08599 } 08600 else { 08601 COPY_OPND(opnd, IR_OPND_L(ir_idx)); 08602 bounds_chk = item_has_bounds_chk(&opnd); 08603 08604 if (! bounds_chk) { 08605 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 08606 bounds_chk = item_has_bounds_chk(&opnd); 08607 } 08608 } 08609 break; 08610 08611 case IL_Tbl_Idx: 08612 list_idx = OPND_IDX((*top_opnd)); 08613 08614 while (list_idx) { 08615 COPY_OPND(opnd, IL_OPND(list_idx)); 08616 08617 if (item_has_bounds_chk(&opnd)) { 08618 bounds_chk = TRUE; 08619 break; 08620 } 08621 list_idx = IL_NEXT_LIST_IDX(list_idx); 08622 } 08623 break; 08624 } 08625 08626 TRACE (Func_Exit, "item_has_bounds_chk", NULL); 08627 08628 return(bounds_chk); 08629 08630 } /* item_has_bounds_chk */ 08631 08632 /******************************************************************************\ 08633 |* *| 08634 |* Description: *| 08635 |* <description> *| 08636 |* *| 08637 |* Input parameters: *| 08638 |* NONE *| 08639 |* *| 08640 |* Output parameters: *| 08641 |* NONE *| 08642 |* *| 08643 |* Returns: *| 08644 |* NOTHING *| 08645 |* *| 08646 \******************************************************************************/ 08647 08648 static void gen_array_element_init(int attr_idx, 08649 long_type *idx_constant, 08650 opnd_type *rhs_opnd, 08651 int opr, 08652 int offset) 08653 08654 { 08655 int asg_idx; 08656 opnd_type opnd[2]; 08657 int col; 08658 int i; 08659 int line; 08660 int list_idx; 08661 int num_values = 1; 08662 int sub_idx; 08663 int type_idx; 08664 08665 TRACE (Func_Entry, "gen_array_element_init", NULL); 08666 08667 find_opnd_line_and_column(rhs_opnd, &line, &col); 08668 08669 type_idx = ATD_TYPE_IDX(attr_idx); 08670 08671 if (OPND_FLD((*rhs_opnd)) == CN_Tbl_Idx) { 08672 08673 if (TYP_LINEAR(type_idx) == Integer_4 && 08674 sizeof(long_type) == 4 && 08675 TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*rhs_opnd)))) == Integer_8) { 08676 gen_opnd(&(opnd[0]), 08677 ntr_const_tbl(Integer_4, 08678 FALSE, 08679 &CP_CONSTANT(CN_POOL_IDX( 08680 OPND_IDX((*rhs_opnd))))), 08681 CN_Tbl_Idx, 08682 line, 08683 col); 08684 gen_opnd(&(opnd[1]), 08685 ntr_const_tbl(Integer_4, 08686 FALSE, 08687 &CP_CONSTANT(1 + CN_POOL_IDX( 08688 OPND_IDX((*rhs_opnd))))), 08689 CN_Tbl_Idx, 08690 line, 08691 col); 08692 num_values = 2; 08693 } 08694 else { 08695 opnd[0] = *rhs_opnd; 08696 } 08697 } 08698 else { 08699 opnd[0] = *rhs_opnd; 08700 } 08701 08702 # ifdef _DEBUG 08703 # ifndef _INIT_RELOC_BASE_OFFSET 08704 if (offset) { 08705 PRINTMSG(line, 626, Internal, col, 08706 "offset == 0", "gen_array_element_init"); 08707 } 08708 # endif 08709 # endif 08710 08711 for (i = 0; i < num_values; i++) { 08712 NTR_IR_TBL(sub_idx); 08713 IR_OPR(sub_idx) = Subscript_Opr; 08714 IR_TYPE_IDX(sub_idx) = type_idx; 08715 IR_LINE_NUM(sub_idx) = line; 08716 IR_COL_NUM(sub_idx) = col; 08717 08718 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 08719 IR_IDX_L(sub_idx) = attr_idx; 08720 IR_LINE_NUM_L(sub_idx) = line; 08721 IR_COL_NUM_L(sub_idx) = col; 08722 08723 list_idx = gen_il(1, 08724 FALSE, 08725 line, 08726 col, 08727 CN_Tbl_Idx, 08728 ntr_const_tbl(CG_INTEGER_DEFAULT_TYPE, 08729 FALSE, 08730 idx_constant)); 08731 08732 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 08733 IR_IDX_R(sub_idx) = list_idx; 08734 IR_LIST_CNT_R(sub_idx) = 1; 08735 08736 08737 if (opr == Asg_Opr) { 08738 asg_idx = gen_ir(IR_Tbl_Idx, sub_idx, 08739 Asg_Opr, type_idx, line, col, 08740 OPND_FLD(opnd[i]), OPND_IDX(opnd[i])); 08741 } 08742 else if (opr == Init_Opr) { 08743 asg_idx = gen_ir(IR_Tbl_Idx, sub_idx, 08744 Init_Opr, type_idx, line, col, 08745 IL_Tbl_Idx, gen_il(3, 08746 FALSE, 08747 line, 08748 col, 08749 OPND_FLD(opnd[i]), 08750 OPND_IDX(opnd[i]), 08751 CN_Tbl_Idx, 08752 CN_INTEGER_ONE_IDX, 08753 CN_Tbl_Idx, 08754 CN_INTEGER_ZERO_IDX)); 08755 } 08756 else if (opr == Init_Reloc_Opr) { 08757 asg_idx = gen_ir(IR_Tbl_Idx, sub_idx, 08758 Init_Reloc_Opr, type_idx, line, col, 08759 IL_Tbl_Idx, gen_il(2, 08760 FALSE, 08761 line, 08762 col, 08763 OPND_FLD(opnd[i]), 08764 OPND_IDX(opnd[i]), 08765 CN_Tbl_Idx, 08766 offset ? offset 08767 : CN_INTEGER_ZERO_IDX)); 08768 } 08769 else { 08770 PRINTMSG(line, 626, Internal, col, 08771 "Asg_Opr or Init_Opr", "gen_array_element_init"); 08772 } 08773 08774 gen_sh(After, Assignment_Stmt, line, col, 08775 FALSE, FALSE, TRUE); 08776 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 08777 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 08778 08779 *idx_constant += 1; 08780 } 08781 08782 TRACE (Func_Exit, "gen_array_element_init", NULL); 08783 08784 return; 08785 08786 } /* gen_array_element_init */
1.7.6.1 
