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(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
03965 }
03966
03967 list_idx = IL_NEXT_LIST_IDX(list_idx);
03968 }
03969
03970 ZERO_ARRAY:
03971
03972 if (list_idx == NULL_IDX) {
03973
03974 *element = -1;
03975
03976
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
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++) {
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
04055
04056
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 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
04072 result_value[1] = result_value[1] << 32;
04073
04074
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
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
04112 result_value[0] = result_value[0] <<
04113 (bit_offset % TARGET_BITS_PER_WORD);
04114
04115
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
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
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
04213
04214
04215
04216
04217 exp_desc->constant = FALSE;
04218
04219
04220
04221
04222
04223 char_ptr = (char *) &(CN_CONST(the_cn_idx))
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) {
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
04247
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
04258 result_value[1] = result_value[1] << 32;
04259
04260
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
04296 result_value[0] = result_value[0] <<
04297 (bit_offset % TARGET_BITS_PER_WORD);
04298
04299
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
04323
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
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
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
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
04510
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
04552
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
04563 result_value[1] = result_value[1] << 32;
04564
04565
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
04602 result_value[0] = result_value[0] <<
04603 ((cn_bit_offset + bit_offset) % TARGET_BITS_PER_WORD);
04604
04605
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
04628
04629 i = 1;
04630 while (i <= BD_RANK(bd_idx)) {
04631
04632 if (! rank_array[i]) {
04633
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 }
04691
04692
04693
04694
04695
04696
04697
04698
04699
04700
04701
04702
04703
04704
04705
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
04722
04723 MEM_ALLOC(char_result_buffer, char, new_size);
04724
04725 }
04726 else {
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 }
04739
04740
04741
04742
04743
04744
04745
04746
04747
04748
04749
04750
04751
04752
04753
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 }
04852
04853
04854
04855
04856
04857
04858
04859
04860
04861
04862
04863
04864
04865
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
04898
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
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
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
05043
05044
05045
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 }
05085
05086
05087
05088
05089
05090
05091
05092
05093
05094
05095
05096
05097
05098
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
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
05179
05180
05181
05182
05183
05184
05185
05186
05187
05188
05189
05190
05191
05192
05193
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
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
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
05298
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
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 }
05393
05394
05395
05396
05397
05398
05399
05400
05401
05402
05403
05404
05405
05406
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 }
05497
05498
05499
05500
05501
05502
05503
05504
05505
05506
05507
05508
05509
05510
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
05585
05586 if (exp_desc_r.rank == exp_desc_l.rank) {
05587
05588 for (i = 0; i < exp_desc_r.rank; i++) {
05589
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
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 }
05725
05726
05727
05728
05729
05730
05731
05732
05733
05734
05735
05736
05737
05738
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
05795 if (exp_desc_r.rank == exp_desc_l.rank) {
05796
05797 for (i = 0; i < exp_desc_r.rank; i++) {
05798
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
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 }
05875
05876
05877
05878
05879
05880
05881
05882
05883
05884
05885
05886
05887
05888
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 }
05962
05963
05964
05965
05966
05967
05968
05969
05970
05971
05972
05973
05974
05975
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];
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 }
06080
06081
06082
06083
06084
06085
06086
06087
06088
06089
06090
06091
06092
06093
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 }
06211
06212
06213
06214
06215
06216
06217
06218
06219
06220
06221
06222
06223
06224
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
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
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 }
06511
06512
06513
06514
06515
06516
06517
06518
06519
06520
06521
06522
06523
06524
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
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
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 }
06818
06819
06820
06821
06822
06823
06824
06825
06826
06827
06828
06829
06830
06831
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
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
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 }
06918
06919
06920
06921
06922
06923
06924
06925
06926
06927
06928
06929
06930
06931
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
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 }
07026
07027
07028
07029
07030
07031
07032
07033
07034
07035
07036
07037
07038
07039
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 }
07112
07113
07114
07115
07116
07117
07118
07119
07120
07121
07122
07123
07124
07125
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
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
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 }
07200
07201
07202
07203
07204
07205
07206
07207
07208
07209
07210
07211
07212
07213
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
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
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 }
07335
07336
07337
07338
07339
07340
07341
07342
07343
07344
07345
07346
07347
07348
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
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
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];
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 }
07566 }
07567 }
07568
07569 TRACE (Func_Exit, "interpret_unary_intrinsic_opr", NULL);
07570
07571 return(ok);
07572
07573 }
07574
07575
07576
07577
07578
07579
07580
07581
07582
07583
07584
07585
07586
07587
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
07664
07665 if (exp_desc_r.rank == exp_desc_l.rank) {
07666
07667 for (i = 0; i < exp_desc_r.rank; i++) {
07668
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
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 }
07816
07817
07818
07819
07820
07821
07822
07823
07824
07825
07826
07827
07828
07829
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
07906
07907 if (exp_desc->rank == exp_desc_l.rank) {
07908
07909 for (i = 0; i < exp_desc->rank; i++) {
07910
07911
07912 if (fold_relationals(OPND_IDX(exp_desc_l.shape[i]),
07913 OPND_IDX(exp_desc->shape[i]),
07914 Ne_Opr)) {
07915
07916
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
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 }
08047
08048
08049
08050
08051
08052
08053
08054
08055
08056
08057
08058
08059
08060
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
08137
08138 if (exp_desc->rank == exp_desc_x.rank) {
08139
08140 for (i = 0; i < exp_desc->rank; i++) {
08141
08142
08143 if (fold_relationals(OPND_IDX(exp_desc_x.shape[i]),
08144 OPND_IDX(exp_desc->shape[i]),
08145 Ne_Opr)) {
08146
08147
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 }
08255
08256
08257
08258
08259
08260
08261
08262
08263
08264
08265
08266
08267
08268
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
08344
08345 if (exp_desc->rank == exp_desc_x.rank) {
08346
08347 for (i = 0; i < exp_desc->rank; i++) {
08348
08349
08350 if (fold_relationals(OPND_IDX(exp_desc_x.shape[i]),
08351 OPND_IDX(exp_desc->shape[i]),
08352 Ne_Opr)) {
08353
08354
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 }
08459
08460
08461
08462
08463
08464
08465
08466
08467
08468
08469
08470
08471
08472
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
08549
08550 if (exp_desc->rank == exp_desc_l.rank) {
08551
08552 for (i = 0; i < exp_desc->rank; i++) {
08553
08554
08555 if (fold_relationals(OPND_IDX(exp_desc_l.shape[i]),
08556 OPND_IDX(exp_desc->shape[i]),
08557 Ne_Opr)) {
08558
08559
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;
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;
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;
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 }
