00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
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"
00040
00041 # include "host.m"
00042 # include "host.h"
00043 # include "target.m"
00044 # include "target.h"
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
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
00118
00119
00120
00121
00122
00123
00124
00125
00126
00127
00128
00129
00130
00131
00132
00133
00134
00135
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
00180
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
00225
00226 if (IR_OPR(ir_idx) != Constant_Struct_Construct_Opr &&
00227 exp_desc->constructor_size_level == Simple_Expr_Size) {
00228
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
00269
00270
00271
00272
00273 if (ok &&
00274 ! single_value_array &&
00275 OPND_FLD(exp_desc->shape[0]) == CN_Tbl_Idx &&
00276 compare_cn_and_value(OPND_IDX(exp_desc->shape[0]),
00277 5000,
00278 Gt_Opr)) {
00279
00280
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
00290
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
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
00369
00370 the_cn_idx = ntr_const_tbl(type_idx, FALSE, NULL);
00371 the_cn_bit_offset = 0;
00372
00373
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 }
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
00397
00398 cast_to_type_idx(&single_value_opnd,
00399 &save_exp_desc,
00400 target_type_idx);
00401 }
00402 }
00403
00404
00405 check_type_conversion = FALSE;
00406
00407 if (! ok) {
00408 goto EXIT;
00409 }
00410
00411 exp_desc->constructor = TRUE;
00412
00413 # if 0
00414
00415
00416
00417 if (stmt_type == Data_Stmt) {
00418
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
00430
00431
00432
00433 if (OPND_FLD(init_target_opnd) != NO_Tbl_Idx) {
00434 tmp_idx = find_left_attr(&init_target_opnd);
00435
00436
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
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
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
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 }
00625
00626
00627
00628
00629
00630
00631
00632
00633
00634
00635
00636
00637
00638
00639
00640
00641
00642
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
00692
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
00709
00710
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
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
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
00815
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
00929
00930 the_cn_idx = ntr_const_tbl(type_idx, FALSE, NULL);
00931 the_cn_bit_offset = 0;
00932
00933
00934
00935 if (num_elements == 0) {
00936
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 }
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
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
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 }
01179
01180
01181
01182
01183
01184
01185
01186
01187
01188
01189
01190
01191
01192
01193
01194
01195
01196
01197
01198
01199
01200
01201
01202
01203
01204
01205
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 }
01233
01234
01235
01236
01237
01238
01239
01240
01241
01242
01243
01244
01245
01246
01247
01248
01249
01250
01251
01252
01253
01254
01255
01256
01257
01258
01259
01260
01261
01262
01263
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],
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
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
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
01487 exp_desc->constant = TRUE;
01488 }
01489 }
01490 else if (ATD_IM_A_DOPE(attr_idx)) {
01491
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
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
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
01657 process_deferred_functions(top_opnd);
01658
01659 ok = interpret_constructor(top_opnd, exp_desc, count, element);
01660 break;
01661
01662
01663
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
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
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
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
01852
01853
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
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
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 }
01894
01895
01896
01897
01898
01899
01900
01901
01902
01903
01904
01905
01906
01907
01908
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
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 }
01973
01974
01975
01976
01977
01978
01979
01980
01981
01982
01983
01984
01985
01986
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
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 &&
02100 bits == TARGET_BITS_PER_WORD) {
02101
02102
02103
02104
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;
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;
02116
02117 CP_CONSTANT(CN_POOL_IDX(the_cn_idx)+cn_word_offset) |= result_value[1];
02118 # endif
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 }
02181
02182
02183
02184
02185
02186
02187
02188
02189
02190
02191
02192
02193
02194
02195
02196
02197
02198
02199
02200
02201
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
02252
02253 if (! count) {
02254
02255
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
02265
02266
02267
02268 GET_LCV_CONST(lcv_idx, loc_value[0],
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
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
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
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
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
02481
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
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
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
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
02597
02598
02599
02600 GET_LCV_CONST(lcv_idx, loc_value[0],
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
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
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
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
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
02843
02844
02845
02846 if (*element == 1) {
02847
02848
02849
02850
02851
02852
02853
02854
02855
02856
02857
02858
02859
02860
02861
02862
02863
02864
02865
02866
02867
02868
02869
02870
02871
02872
02873
02874
02875
02876
02877
02878
02879
02880
02881
02882
02883
02884
02885
02886
02887
02888
02889
02890
02891
02892
02893
02894
02895
02896
02897
02898
02899
02900
02901
02902
02903
02904
02905
02906
02907
02908 AT_REFERENCED(lcv_idx) = Not_Referenced;
02909
02910
02911
02912
02913
02914 GET_LCV_CONST(lcv_idx, loc_value[0],
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
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
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
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
03029
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
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
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
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
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
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
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
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
03271 FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(list_idx));
03272 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
03273
03274
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 }
03295
03296
03297
03298
03299
03300
03301
03302
03303
03304
03305
03306
03307
03308
03309
03310
03311
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
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
03528
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
03542
03543
03544
03545
03546
03547
03548
03549
03550
03551
03552
03553
03554
03555
03556
03557
03558
03559
03560
03561
03562
03563
03564
03565
03566
03567
03568
03569
03570
03571
03572
03573
03574
03575
03576
03577
03578
03579
03580
03581
03582
03583
03584
03585
03586
03587
03588
03589
03590
03591
03592
03593
03594
03595
03596
03597
03598
03599
03600
03601
03602
03603
03604
03605
03606
03607
03608
03609
03610
03611
03612
03613
03614
03615
03616
03617
03618
03619
03620
03621
03622
03623
03624
03625
03626
03627
03628
03629
03630
03631
03632
03633
03634
03635
03636
03637
03638
03639
03640
03641
03642
03643
03644
03645
03646
03647
03648
03649
03650
03651
03652
03653
03654
03655
03656
03657
03658
03659
03660
03661
03662
03663
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,
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
03723 cn_bit_offset = (substring_offset * CHAR_BIT) + bit_offset;
03724 }
03725 else {
03726
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
03801 zero_size_array = TRUE;
03802 }
03803
03804
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
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
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
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</