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