|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 00037 static char USMID[] = "\n@(#)5.0_pl/sources/s_intrin.c 5.31 10/27/99 16:50:34\n"; 00038 00039 # include "defines.h" /* Machine dependent ifdefs */ 00040 # include "host.m" /* Host machine dependent macros.*/ 00041 # include "host.h" /* Host machine dependent header.*/ 00042 # include "target.m" /* Target machine dependent macros.*/ 00043 # include "target.h" /* Target machine dependent header.*/ 00044 # include "globals.m" 00045 # include "tokens.m" 00046 # include "sytb.m" 00047 # include "s_globals.m" 00048 # include "debug.m" 00049 # include "fmath.h" 00050 # include "globals.h" 00051 # include "tokens.h" 00052 # include "sytb.h" 00053 # include "s_globals.h" 00054 00055 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX) 00056 # include <fortran.h> 00057 # endif 00058 00059 00060 extern boolean has_present_opr; 00061 00062 00063 00064 /******************************************************************************\ 00065 |* *| 00066 |* Description: *| 00067 |* generate an array constructor of lower and upper bounds from a bd ntry*| 00068 |* *| 00069 |* Input parameters: *| 00070 |* NONE *| 00071 |* *| 00072 |* Output parameters: *| 00073 |* NONE *| 00074 |* *| 00075 |* Returns: *| 00076 |* NOTHING *| 00077 |* *| 00078 \******************************************************************************/ 00079 00080 static void generate_bounds_list(int bd_idx, 00081 opnd_type *result_opnd, 00082 expr_arg_type *exp_desc) 00083 00084 { 00085 00086 int col; 00087 int i; 00088 int ir_idx; 00089 int line; 00090 int list_idx = NULL_IDX; 00091 opnd_type opnd; 00092 cif_usage_code_type save_xref_state; 00093 00094 00095 TRACE (Func_Entry, "generate_bounds_list", NULL); 00096 00097 find_opnd_line_and_column(result_opnd, &line, &col); 00098 00099 NTR_IR_TBL(ir_idx); 00100 IR_OPR(ir_idx) = Array_Construct_Opr; 00101 IR_LINE_NUM(ir_idx) = line; 00102 IR_COL_NUM(ir_idx) = col; 00103 00104 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 00105 IR_LIST_CNT_R(ir_idx) = 2 * BD_RANK(bd_idx); 00106 00107 00108 for (i = 1; i <= BD_RANK(bd_idx); i++) { 00109 if (list_idx == NULL_IDX) { 00110 NTR_IR_LIST_TBL(list_idx); 00111 IR_IDX_R(ir_idx) = list_idx; 00112 } 00113 else { 00114 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 00115 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 00116 list_idx = IL_NEXT_LIST_IDX(list_idx); 00117 } 00118 00119 IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i); 00120 IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i); 00121 IL_LINE_NUM(list_idx) = line; 00122 IL_COL_NUM(list_idx) = col; 00123 00124 COPY_OPND(opnd, IL_OPND(list_idx)); 00125 cast_opnd_to_type_idx(&opnd, CG_INTEGER_DEFAULT_TYPE); 00126 COPY_OPND(IL_OPND(list_idx), opnd); 00127 00128 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 00129 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 00130 list_idx = IL_NEXT_LIST_IDX(list_idx); 00131 00132 if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size && 00133 i == BD_RANK(bd_idx)) { 00134 00135 IL_FLD(list_idx) = CN_Tbl_Idx; 00136 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 00137 } 00138 else { 00139 IL_FLD(list_idx) = BD_UB_FLD(bd_idx, i); 00140 IL_IDX(list_idx) = BD_UB_IDX(bd_idx, i); 00141 } 00142 00143 IL_LINE_NUM(list_idx) = line; 00144 IL_COL_NUM(list_idx) = col; 00145 00146 COPY_OPND(opnd, IL_OPND(list_idx)); 00147 cast_opnd_to_type_idx(&opnd, CG_INTEGER_DEFAULT_TYPE); 00148 COPY_OPND(IL_OPND(list_idx), opnd); 00149 } 00150 00151 save_xref_state = xref_state; 00152 xref_state = CIF_No_Usage_Rec; 00153 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 00154 OPND_IDX((*result_opnd)) = ir_idx; 00155 exp_desc->rank = 0; 00156 expr_semantics(result_opnd, exp_desc); 00157 xref_state = save_xref_state; 00158 00159 TRACE (Func_Exit, "generate_bounds_list", NULL); 00160 00161 return; 00162 00163 } /* generate_bounds_list */ 00164 00165 00166 00167 /******************************************************************************\ 00168 |* *| 00169 |* Description: *| 00170 |* <description> *| 00171 |* *| 00172 |* Input parameters: *| 00173 |* NONE *| 00174 |* *| 00175 |* Output parameters: *| 00176 |* NONE *| 00177 |* *| 00178 |* Returns: *| 00179 |* NOTHING *| 00180 |* *| 00181 \******************************************************************************/ 00182 00183 static int cri_ptr_type(int type_idx) 00184 00185 { 00186 int ptr_type; 00187 00188 00189 TRACE (Func_Entry, "cri_ptr_type", NULL); 00190 00191 ptr_type = CRI_Ptr_8; 00192 00193 # ifdef _TRANSFORM_CHAR_SEQUENCE 00194 if (TYP_TYPE(type_idx) == Character || 00195 (TYP_TYPE(type_idx) == Structure && 00196 ATT_CHAR_SEQ(TYP_IDX(type_idx)))) 00197 # else 00198 if (TYP_TYPE(type_idx) == Character) 00199 # endif 00200 { 00201 00202 ptr_type = CRI_Ch_Ptr_8; 00203 } 00204 # ifdef _TARGET32 00205 else if (TARGET_32BIT_DOUBLE_WORD_STORAGE_TYPE(type_idx) || 00206 TYP_LINEAR(type_idx) == Complex_4) { 00207 00208 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 00209 TYP_TYPE(TYP_WORK_IDX) = CRI_Ptr; 00210 TYP_LINEAR(TYP_WORK_IDX) = CRI_Ptr_8; 00211 TYP_PTR_INCREMENT(TYP_WORK_IDX) = 64; 00212 ptr_type = ntr_type_tbl(); 00213 00214 } 00215 # endif 00216 00217 # ifdef _TARGET_OS_MAX 00218 else if (TARGET_MAX_HALF_WORD_STORAGE_TYPE(type_idx)) { 00219 00220 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 00221 TYP_TYPE(TYP_WORK_IDX) = CRI_Ptr; 00222 TYP_LINEAR(TYP_WORK_IDX) = CRI_Ptr_8; 00223 TYP_PTR_INCREMENT(TYP_WORK_IDX) = 32; 00224 ptr_type = ntr_type_tbl(); 00225 } 00226 # endif 00227 00228 00229 TRACE (Func_Exit, "cri_ptr_type", NULL); 00230 00231 return(ptr_type); 00232 00233 } /* cri_ptr_type */ 00234 00235 00236 /******************************************************************************\ 00237 |* *| 00238 |* Description: *| 00239 |* <description> *| 00240 |* *| 00241 |* Input parameters: *| 00242 |* NONE *| 00243 |* *| 00244 |* Output parameters: *| 00245 |* NONE *| 00246 |* *| 00247 |* Returns: *| 00248 |* NOTHING *| 00249 |* *| 00250 \******************************************************************************/ 00251 00252 #if defined(GENERATE_WHIRL) 00253 #if COMPILER_VERSION < 730 00254 static void dummydummydummy(void *a, void *b){} 00255 #endif 00256 #endif 00257 00258 static boolean optimize_reshape(opnd_type *result_opnd, 00259 expr_arg_type *res_exp_desc) 00260 00261 { 00262 int asg_idx; 00263 int attr_idx; 00264 int bd_idx; 00265 int col; 00266 expr_arg_type exp_desc1; 00267 expr_arg_type exp_desc2; 00268 expr_arg_type exp_desc4; 00269 long i; 00270 int info_idx1; 00271 int info_idx2; 00272 int info_idx4; 00273 int ir_idx; 00274 int line; 00275 int list_idx1; 00276 int list_idx2; 00277 int list_idx3; 00278 int list_idx4; 00279 expr_arg_type loc_exp_desc; 00280 int loc_idx; 00281 opnd_type l_opnd; 00282 boolean ok; 00283 opnd_type opnd; 00284 boolean optimized = FALSE; 00285 boolean equal = TRUE; 00286 int ptee_idx; 00287 int ptr_idx; 00288 opnd_type r_opnd; 00289 int type_idx; 00290 int unused1; 00291 int unused2; 00292 00293 00294 TRACE (Func_Entry, "optimize_reshape", NULL); 00295 00296 if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx && 00297 IR_OPR(OPND_IDX((*result_opnd))) == Call_Opr) { 00298 00299 ir_idx = OPND_IDX((*result_opnd)); 00300 00301 list_idx1 = IR_IDX_R(ir_idx); 00302 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 00303 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 00304 list_idx4 = IL_NEXT_LIST_IDX(list_idx3); 00305 00306 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 00307 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 00308 00309 #if defined(GENERATE_WHIRL) 00310 #if COMPILER_VERSION < 730 00311 /* Work around 7.2.1.2 optimizer bug */ 00312 dummydummydummy(&info_idx1,&info_idx2); 00313 #endif 00314 #endif 00315 00316 exp_desc1 = arg_info_list[info_idx1].ed; 00317 exp_desc2 = arg_info_list[info_idx2].ed; 00318 00319 if (IL_FLD(list_idx4) != NO_Tbl_Idx) { 00320 info_idx4 = IL_ARG_DESC_IDX(list_idx4); 00321 exp_desc4 = arg_info_list[info_idx4].ed; 00322 00323 if (exp_desc4.foldable) { 00324 00325 attr_idx = find_base_attr(&IL_OPND(list_idx4), &line, &col); 00326 loc_exp_desc = init_exp_desc; 00327 loc_exp_desc.type_idx = ATD_TYPE_IDX(attr_idx); 00328 loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx); 00329 loc_exp_desc.linear_type = TYP_LINEAR(loc_exp_desc.type_idx); 00330 00331 loc_exp_desc.foldable = TRUE; 00332 loc_exp_desc.constant = TRUE; 00333 00334 for (i = 1; i <= res_exp_desc->rank; i++) { 00335 change_section_to_this_element(&IL_OPND(list_idx4), 00336 &opnd, 00337 i); 00338 00339 ok = fold_aggragate_expression(&opnd, 00340 &loc_exp_desc, 00341 TRUE); 00342 00343 equal = equal && compare_cn_and_value(OPND_IDX(opnd), i, Eq_Opr); 00344 } 00345 00346 if (equal && compare_cn_and_value(OPND_IDX(exp_desc4.shape[0]), 00347 (long) res_exp_desc->rank, 00348 Eq_Opr)) { 00349 IL_OPND(list_idx4) = null_opnd; 00350 } 00351 } 00352 00353 } 00354 00355 if (IL_FLD(list_idx3) == NO_Tbl_Idx && 00356 IL_FLD(list_idx4) == NO_Tbl_Idx) { 00357 00358 if (exp_desc1.reference || 00359 exp_desc1.tmp_reference) { 00360 00361 if (! exp_desc1.contig_array) { 00362 goto EXIT; 00363 } 00364 00365 attr_idx = find_base_attr(&IL_OPND(list_idx1), &line, &col); 00366 00367 if (ATD_POINTER(attr_idx)) { 00368 goto EXIT; 00369 } 00370 00371 if (ATD_ARRAY_IDX(attr_idx) && 00372 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape) { 00373 goto EXIT; 00374 } 00375 } 00376 else { 00377 /* not a reference, this would be a copy in anyway */ 00378 00379 COPY_OPND(r_opnd, IL_OPND(list_idx1)); 00380 attr_idx = create_tmp_asg(&r_opnd, 00381 &exp_desc1, 00382 &l_opnd, 00383 Intent_In, 00384 FALSE, 00385 FALSE); 00386 00387 COPY_OPND(IL_OPND(list_idx1), l_opnd); 00388 arg_info_list[info_idx1].ed = exp_desc1; 00389 } 00390 00391 00392 if (! exp_desc2.reference && 00393 ! exp_desc2.tmp_reference) { 00394 00395 COPY_OPND(r_opnd, IL_OPND(list_idx2)); 00396 attr_idx = create_tmp_asg(&r_opnd, 00397 &exp_desc2, 00398 &l_opnd, 00399 Intent_In, 00400 FALSE, 00401 FALSE); 00402 00403 COPY_OPND(IL_OPND(list_idx2), l_opnd); 00404 arg_info_list[info_idx2].ed = exp_desc2; 00405 } 00406 00407 attr_idx = find_base_attr(&IL_OPND(list_idx2), &line, &col); 00408 loc_exp_desc = init_exp_desc; 00409 loc_exp_desc.type_idx = ATD_TYPE_IDX(attr_idx); 00410 loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx); 00411 loc_exp_desc.linear_type = TYP_LINEAR(loc_exp_desc.type_idx); 00412 00413 if (exp_desc2.foldable) { 00414 loc_exp_desc.foldable = TRUE; 00415 loc_exp_desc.constant = TRUE; 00416 } 00417 00418 for (i = 1; i <= res_exp_desc->rank; i++) { 00419 00420 change_section_to_this_element(&IL_OPND(list_idx2), 00421 &opnd, 00422 i); 00423 if (exp_desc2.foldable) { 00424 ok = fold_aggragate_expression(&opnd, 00425 &loc_exp_desc, 00426 TRUE); 00427 } 00428 00429 COPY_OPND(res_exp_desc->shape[i-1], opnd); 00430 } 00431 00432 if (gen_bd_entry(NULL, res_exp_desc, &bd_idx, line, col)) { 00433 /* intentionally blank */ 00434 } 00435 00436 type_idx = cri_ptr_type(exp_desc1.type_idx); 00437 00438 /* generate the ptr/pointee pair */ 00439 00440 ptr_idx = gen_compiler_tmp(line, col, Shared, TRUE); 00441 ATD_TYPE_IDX(ptr_idx) = type_idx; 00442 AT_SEMANTICS_DONE(ptr_idx) = TRUE; 00443 ATD_STOR_BLK_IDX(ptr_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 00444 00445 ptee_idx = gen_compiler_tmp(line, col, Shared, TRUE); 00446 ATD_CLASS(ptee_idx) = CRI__Pointee; 00447 AT_SEMANTICS_DONE(ptee_idx) = TRUE; 00448 ATD_STOR_BLK_IDX(ptee_idx) = SCP_SB_BASED_IDX(curr_scp_idx); 00449 ATD_TYPE_IDX(ptee_idx) = exp_desc1.type_idx; 00450 ATD_ARRAY_IDX(ptee_idx) = bd_idx; 00451 ATD_PTR_IDX(ptee_idx) = ptr_idx; 00452 00453 /* generate assignment to ptr */ 00454 00455 attr_idx = find_base_attr(&IL_OPND(list_idx1), &unused1, &unused2); 00456 00457 # if defined(GENERATE_WHIRL) 00458 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 00459 ATD_NOT_PT_UNIQUE_MEM(attr_idx) = TRUE; 00460 } 00461 # endif 00462 00463 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 00464 ATD_CLASS(attr_idx) == Compiler_Tmp && 00465 exp_desc1.type != Character && 00466 ATD_IM_A_DOPE(attr_idx)) { 00467 00468 asg_idx = gen_ir(AT_Tbl_Idx, ptr_idx, 00469 Asg_Opr, type_idx, line, col, 00470 IR_Tbl_Idx, gen_ir(AT_Tbl_Idx, attr_idx, 00471 Dv_Access_Base_Addr, 00472 SA_INTEGER_DEFAULT_TYPE,line,col, 00473 NO_Tbl_Idx, NULL_IDX)); 00474 00475 } 00476 else { 00477 00478 COPY_OPND(opnd, IL_OPND(list_idx1)); 00479 unused1 = NULL_IDX; 00480 unused2 = NULL_IDX; 00481 make_base_subtree(&opnd, &r_opnd, &unused1, &unused2); 00482 00483 loc_idx = gen_ir(OPND_FLD(r_opnd), OPND_IDX(r_opnd), 00484 Loc_Opr, type_idx, line, col, 00485 NO_Tbl_Idx, NULL_IDX); 00486 00487 # ifdef _TRANSFORM_CHAR_SEQUENCE 00488 if (exp_desc1.type == Structure && 00489 ATT_CHAR_SEQ(TYP_IDX(exp_desc1.type_idx))) { 00490 00491 COPY_OPND(opnd, IR_OPND_L(loc_idx)); 00492 transform_char_sequence_ref(&opnd, exp_desc1.type_idx); 00493 COPY_OPND(IR_OPND_L(loc_idx), opnd); 00494 } 00495 # endif 00496 00497 asg_idx = gen_ir(AT_Tbl_Idx, ptr_idx, 00498 Asg_Opr, type_idx, line, col, 00499 IR_Tbl_Idx, loc_idx); 00500 00501 } 00502 00503 gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE); 00504 00505 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 00506 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00507 00508 gen_opnd(result_opnd, ptee_idx, AT_Tbl_Idx, line, col); 00509 00510 res_exp_desc->tmp_reference = TRUE; 00511 ok = gen_whole_subscript(result_opnd, res_exp_desc); 00512 00513 optimized = TRUE; 00514 } 00515 } 00516 00517 EXIT: 00518 00519 TRACE (Func_Exit, "optimize_reshape", NULL); 00520 00521 return(optimized); 00522 00523 } /* optimize_reshape */ 00524 00525 00526 /******************************************************************************\ 00527 |* *| 00528 |* Description: *| 00529 |* Check conformance of the operands to an elemental intrinsic. *| 00530 |* Also, return the index of the argument to extract the rank/shape from.*| 00531 |* *| 00532 |* Input parameters: *| 00533 |* NONE *| 00534 |* *| 00535 |* Output parameters: *| 00536 |* NONE *| 00537 |* *| 00538 |* Returns: *| 00539 |* NOTHING *| 00540 |* *| 00541 \******************************************************************************/ 00542 00543 void conform_check(int check_args, 00544 int ir_idx, 00545 expr_arg_type *res_exp_desc, 00546 int *spec_idx, 00547 boolean assumed_size_allowed) 00548 { 00549 int line; 00550 int col; 00551 int which_arg; 00552 int max_rank; 00553 int attr_idx; 00554 int temp_ir_idx; 00555 int i; 00556 int info_idx; 00557 00558 00559 TRACE (Func_Entry, "conform_check", NULL); 00560 00561 max_rank = 0; 00562 00563 temp_ir_idx = IR_IDX_R(ir_idx); 00564 00565 if (temp_ir_idx != NULL_IDX) { /* are there any arguments */ 00566 which_arg = IL_ARG_DESC_IDX(temp_ir_idx); 00567 } 00568 00569 res_exp_desc->will_fold_later = TRUE; 00570 res_exp_desc->foldable = TRUE; 00571 00572 for (i = 1; i <= IR_LIST_CNT_R(ir_idx); i++) { 00573 00574 if (IL_FLD(temp_ir_idx) == NO_Tbl_Idx) { 00575 temp_ir_idx = IL_NEXT_LIST_IDX(temp_ir_idx); 00576 continue; 00577 } 00578 00579 info_idx = IL_ARG_DESC_IDX(temp_ir_idx); 00580 00581 if (! assumed_size_allowed && 00582 arg_info_list[info_idx].ed.rank != 0 && 00583 (IL_FLD(temp_ir_idx) == AT_Tbl_Idx || 00584 (IL_FLD(temp_ir_idx) == IR_Tbl_Idx && 00585 IR_OPR(IL_IDX(temp_ir_idx)) == Whole_Substring_Opr && 00586 IR_FLD_L(IL_IDX(temp_ir_idx)) == AT_Tbl_Idx))) { 00587 00588 PRINTMSG(arg_info_list[info_idx].line, 412, Error, 00589 arg_info_list[info_idx].col); 00590 } 00591 00592 attr_idx = 0; 00593 if ((IL_FLD(temp_ir_idx) == IR_Tbl_Idx) && 00594 ((IR_OPR(IL_IDX(temp_ir_idx)) == Whole_Subscript_Opr) || 00595 (IR_OPR(IL_IDX(temp_ir_idx)) == Section_Subscript_Opr))) { 00596 attr_idx = find_base_attr(&IL_OPND(temp_ir_idx), &line, &col); 00597 } 00598 00599 if ((check_args != 0) && 00600 (i >= check_args) && 00601 (arg_info_list[info_idx].ed.rank != max_rank) && 00602 (attr_idx != 0) && 00603 (!(ATP_INTRIN_ENUM(*spec_idx) == Present_Intrinsic)) && 00604 (AT_OPTIONAL(attr_idx))) { 00605 PRINTMSG(arg_info_list[info_idx].line, 947, Error, 00606 arg_info_list[info_idx].col); 00607 } 00608 00609 if (!arg_info_list[info_idx].ed.foldable && 00610 !arg_info_list[info_idx].ed.will_fold_later) { 00611 res_exp_desc->will_fold_later = FALSE; 00612 } 00613 00614 if (! arg_info_list[info_idx].ed.foldable) { 00615 res_exp_desc->foldable = FALSE; 00616 } 00617 00618 if (max_rank != 0 && 00619 AT_ELEMENTAL_INTRIN(*spec_idx) && 00620 arg_info_list[info_idx].ed.rank != 0 && 00621 max_rank != arg_info_list[info_idx].ed.rank) { 00622 PRINTMSG(arg_info_list[info_idx].line, 363, Error, 00623 arg_info_list[info_idx].col); 00624 } 00625 00626 if (arg_info_list[info_idx].ed.rank > max_rank) { 00627 max_rank = arg_info_list[info_idx].ed.rank; 00628 which_arg = info_idx; 00629 } 00630 00631 temp_ir_idx = IL_NEXT_LIST_IDX(temp_ir_idx); 00632 } 00633 00634 if (ATP_PGM_UNIT(*spec_idx) != Subroutine) { 00635 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 00636 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 00637 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 00638 } 00639 res_exp_desc->rank = max_rank; 00640 00641 if (max_rank > 0 && AT_ELEMENTAL_INTRIN(*spec_idx)) { 00642 COPY_SHAPE(res_exp_desc->shape, 00643 arg_info_list[which_arg].ed.shape, 00644 arg_info_list[which_arg].ed.rank); 00645 } 00646 00647 TRACE (Func_Exit, "conform_check", NULL); 00648 00649 } /* conform_check */ 00650 00651 00652 /******************************************************************************\ 00653 |* *| 00654 |* Description: *| 00655 |* Function SIN(X) intrinsic. *| 00656 |* Function DSIN(X) intrinsic. *| 00657 |* Function QSIN(X) intrinsic. *| 00658 |* Function CSIN(X) intrinsic. *| 00659 |* Function CDSIN(X) intrinsic. *| 00660 |* Function CQSIN(X) intrinsic. *| 00661 |* Function SIND(X) intrinsic. *| 00662 |* Function DSIND(X) intrinsic. *| 00663 |* Function QSIND(X) intrinsic. *| 00664 |* Function SINH(X) intrinsic. *| 00665 |* Function DSINH(X) intrinsic. *| 00666 |* Function QSINH(X) intrinsic. *| 00667 |* Function ASIN(X) intrinsic. *| 00668 |* Function DASIN(X) intrinsic. *| 00669 |* Function QASIN(X) intrinsic. *| 00670 |* Function ASIND(X) intrinsic. *| 00671 |* Function DASIND(X) intrinsic. *| 00672 |* Function QASIND(X) intrinsic. *| 00673 |* Function COS(X) intrinsic. *| 00674 |* Function DCOS(X) intrinsic. *| 00675 |* Function QCOS(X) intrinsic. *| 00676 |* Function CCOS(X) intrinsic. *| 00677 |* Function CDCOS(X) intrinsic. *| 00678 |* Function CQCOS(X) intrinsic. *| 00679 |* Function COSD(X) intrinsic. *| 00680 |* Function DCOSD(X) intrinsic. *| 00681 |* Function QCOSD(X) intrinsic. *| 00682 |* Function COSH(X) intrinsic. *| 00683 |* Function DCOSH(X) intrinsic. *| 00684 |* Function QCOSH(X) intrinsic. *| 00685 |* Function ACOS(X) intrinsic. *| 00686 |* Function DACOS(X) intrinsic. *| 00687 |* Function QACOS(X) intrinsic. *| 00688 |* Function ACOSD(X) intrinsic. *| 00689 |* Function DACOSD(X) intrinsic. *| 00690 |* Function QACOSD(X) intrinsic. *| 00691 |* Function TAN(X) intrinsic. *| 00692 |* Function DTAN(X) intrinsic. *| 00693 |* Function QTAN(X) intrinsic. *| 00694 |* Function TAND(X) intrinsic. *| 00695 |* Function DTAND(X) intrinsic. *| 00696 |* Function QTAND(X) intrinsic. *| 00697 |* Function TANH(X) intrinsic. *| 00698 |* Function DTANH(X) intrinsic. *| 00699 |* Function QTANH(X) intrinsic. *| 00700 |* Function ATAN(X) intrinsic. *| 00701 |* Function DATAN(X) intrinsic. *| 00702 |* Function QATAN(X) intrinsic. *| 00703 |* Function ATAND(X) intrinsic. *| 00704 |* Function DATAND(X) intrinsic. *| 00705 |* Function QATAND(X) intrinsic. *| 00706 |* Function LOG(X) intrinsic. *| 00707 |* Function DLOG(X) intrinsic. *| 00708 |* Function QLOG(X) intrinsic. *| 00709 |* Function CDLOG(X) intrinsic. *| 00710 |* Function CQLOG(X) intrinsic. *| 00711 |* Function LOG10(X) intrinsic. *| 00712 |* Function DLOG10(X) intrinsic. *| 00713 |* Function QLOG10(X) intrinsic. *| 00714 |* Function EXP(X) intrinsic. *| 00715 |* Function DEXP(X) intrinsic. *| 00716 |* Function QEXP(X) intrinsic. *| 00717 |* Function CEXP(X) intrinsic. *| 00718 |* Function CDEXP(X) intrinsic. *| 00719 |* Function CQEXP(X) intrinsic. *| 00720 |* Function COT(X) intrinsic. *| 00721 |* Function DCOT(X) intrinsic. *| 00722 |* Function QCOT(X) intrinsic. *| 00723 |* Function SQRT(X) intrinsic. *| 00724 |* Function DSQRT(X) intrinsic. *| 00725 |* Function QSQRT(X) intrinsic. *| 00726 |* Function CSQRT(X) intrinsic. *| 00727 |* Function CDSQRT(X) intrinsic. *| 00728 |* Function CQSQRT(X) intrinsic. *| 00729 |* *| 00730 |* Input parameters: *| 00731 |* NONE *| 00732 |* *| 00733 |* Output parameters: *| 00734 |* NONE *| 00735 |* *| 00736 |* Returns: *| 00737 |* NOTHING *| 00738 |* *| 00739 \******************************************************************************/ 00740 00741 void sin_intrinsic(opnd_type *result_opnd, 00742 expr_arg_type *res_exp_desc, 00743 int *spec_idx) 00744 { 00745 00746 int info_idx1; 00747 int list_idx1; 00748 int ir_idx; 00749 00750 00751 TRACE (Func_Entry, "sin_intrinsic", NULL); 00752 00753 ir_idx = OPND_IDX((*result_opnd)); 00754 list_idx1 = IR_IDX_R(ir_idx); 00755 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 00756 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 00757 00758 conform_check(0, 00759 ir_idx, 00760 res_exp_desc, 00761 spec_idx, 00762 FALSE); 00763 00764 IR_TYPE_IDX(ir_idx) = arg_info_list[info_idx1].ed.type_idx; 00765 IR_RANK(ir_idx) = res_exp_desc->rank; 00766 00767 00768 switch (ATP_INTRIN_ENUM(*spec_idx)) { 00769 case Sin_Intrinsic: 00770 case Dsin_Intrinsic: 00771 case Qsin_Intrinsic: 00772 case Csin_Intrinsic: 00773 case Cdsin_Intrinsic: 00774 case Cqsin_Intrinsic: 00775 /* IR_OPR(ir_idx) = Sin_Opr; */ 00776 break; 00777 00778 case Sind_Intrinsic: 00779 case Dsind_Intrinsic: 00780 case Qsind_Intrinsic: 00781 /* IR_OPR(ir_idx) = Sind_Opr; */ 00782 break; 00783 00784 case Cos_Intrinsic: 00785 case Dcos_Intrinsic: 00786 case Qcos_Intrinsic: 00787 case Ccos_Intrinsic: 00788 case Cdcos_Intrinsic: 00789 case Cqcos_Intrinsic: 00790 /* IR_OPR(ir_idx) = Cos_Opr; */ 00791 break; 00792 00793 case Cosd_Intrinsic: 00794 case Dcosd_Intrinsic: 00795 case Qcosd_Intrinsic: 00796 /* IR_OPR(ir_idx) = Cosd_Opr; */ 00797 break; 00798 00799 case Log_Intrinsic: 00800 case Alog_Intrinsic: 00801 case Dlog_Intrinsic: 00802 case Qlog_Intrinsic: 00803 case Clog_Intrinsic: 00804 case Cdlog_Intrinsic: 00805 case Cqlog_Intrinsic: 00806 if ((IL_FLD(list_idx1) == CN_Tbl_Idx) && 00807 (arg_info_list[info_idx1].ed.type == Real)) { 00808 00809 if (fold_relationals(IL_IDX(list_idx1), 00810 CN_INTEGER_ZERO_IDX, 00811 Le_Opr)) { 00812 00813 PRINTMSG(arg_info_list[info_idx1].line, 1062, Error, 00814 arg_info_list[info_idx1].col); 00815 } 00816 } 00817 00818 /* IR_OPR(ir_idx) = Log_E_Opr; */ 00819 break; 00820 00821 case Log10_Intrinsic: 00822 case Alog10_Intrinsic: 00823 case Dlog10_Intrinsic: 00824 case Qlog10_Intrinsic: 00825 /* IR_OPR(ir_idx) = Log_10_Opr; */ 00826 break; 00827 00828 case Tan_Intrinsic: 00829 case Dtan_Intrinsic: 00830 case Qtan_Intrinsic: 00831 /* IR_OPR(ir_idx) = Tan_Opr; */ 00832 break; 00833 00834 case Tand_Intrinsic: 00835 case Dtand_Intrinsic: 00836 case Qtand_Intrinsic: 00837 /* IR_OPR(ir_idx) = Tand_Opr; */ 00838 break; 00839 00840 case Tanh_Intrinsic: 00841 case Dtanh_Intrinsic: 00842 case Qtanh_Intrinsic: 00843 /* IR_OPR(ir_idx) = Tanh_Opr; */ 00844 break; 00845 00846 case Sinh_Intrinsic: 00847 case Dsinh_Intrinsic: 00848 case Qsinh_Intrinsic: 00849 /* IR_OPR(ir_idx) = Sinh_Opr; */ 00850 break; 00851 00852 case Cosh_Intrinsic: 00853 case Dcosh_Intrinsic: 00854 case Qcosh_Intrinsic: 00855 /* IR_OPR(ir_idx) = Cosh_Opr; */ 00856 break; 00857 00858 case Acos_Intrinsic: 00859 case Dacos_Intrinsic: 00860 case Qacos_Intrinsic: 00861 /* IR_OPR(ir_idx) = Acos_Opr; */ 00862 break; 00863 00864 case Acosd_Intrinsic: 00865 case Dacosd_Intrinsic: 00866 case Qacosd_Intrinsic: 00867 /* IR_OPR(ir_idx) = Acosd_Opr; */ 00868 break; 00869 00870 case Asin_Intrinsic: 00871 case Dasin_Intrinsic: 00872 case Qasin_Intrinsic: 00873 /* IR_OPR(ir_idx) = Asin_Opr; */ 00874 break; 00875 00876 case Asind_Intrinsic: 00877 case Dasind_Intrinsic: 00878 case Qasind_Intrinsic: 00879 /* IR_OPR(ir_idx) = Asind_Opr; */ 00880 break; 00881 00882 case Atan_Intrinsic: 00883 case Datan_Intrinsic: 00884 case Qatan_Intrinsic: 00885 /* IR_OPR(ir_idx) = Atan_Opr; */ 00886 break; 00887 00888 case Atand_Intrinsic: 00889 case Datand_Intrinsic: 00890 case Qatand_Intrinsic: 00891 /* IR_OPR(ir_idx) = Atand_Opr; */ 00892 break; 00893 00894 case Cot_Intrinsic: 00895 case Dcot_Intrinsic: 00896 case Qcot_Intrinsic: 00897 /* IR_OPR(ir_idx) = Cot_Opr; */ 00898 break; 00899 00900 case Exp_Intrinsic: 00901 case Dexp_Intrinsic: 00902 case Qexp_Intrinsic: 00903 case Cexp_Intrinsic: 00904 case Cdexp_Intrinsic: 00905 case Cqexp_Intrinsic: 00906 /* IR_OPR(ir_idx) = Exp_Opr; */ 00907 break; 00908 00909 case Sqrt_Intrinsic: 00910 case Dsqrt_Intrinsic: 00911 case Qsqrt_Intrinsic: 00912 case Csqrt_Intrinsic: 00913 case Cdsqrt_Intrinsic: 00914 case Cqsqrt_Intrinsic: 00915 if ((IL_FLD(list_idx1) == CN_Tbl_Idx) && 00916 (arg_info_list[info_idx1].ed.type == Real)) { 00917 00918 if (fold_relationals(IL_IDX(list_idx1), 00919 CN_INTEGER_ZERO_IDX, 00920 Lt_Opr)) { 00921 00922 PRINTMSG(arg_info_list[info_idx1].line, 1062, Error, 00923 arg_info_list[info_idx1].col); 00924 } 00925 } 00926 00927 /* IR_OPR(ir_idx) = Sqrt_Opr; */ 00928 break; 00929 00930 default: 00931 PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, IR_COL_NUM(ir_idx), 00932 "sin_intrinsic"); 00933 break; 00934 } 00935 00936 # if 0 00937 00938 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 00939 IR_OPND_R(ir_idx) = null_opnd; 00940 00941 /* must reset foldable and will_fold_later because there is no */ 00942 /* folder for this intrinsic in constructors. */ 00943 00944 # if defined(_USE_FOLD_DOT_f) 00945 if (IR_OPR(ir_idx) != Sqrt_Opr) { 00946 # endif 00947 res_exp_desc->foldable = FALSE; 00948 res_exp_desc->will_fold_later = FALSE; 00949 # if defined(_USE_FOLD_DOT_f) 00950 } 00951 # endif 00952 00953 /* set this flag so this opr is pulled off io lists */ 00954 io_item_must_flatten = TRUE; 00955 00956 # endif 00957 00958 res_exp_desc->foldable = FALSE; 00959 res_exp_desc->will_fold_later = FALSE; 00960 00961 TRACE (Func_Exit, "sin_intrinsic", NULL); 00962 00963 } /* sin_intrinsic */ 00964 00965 00966 /******************************************************************************\ 00967 |* *| 00968 |* Description: *| 00969 |* Function ABS(A) intrinsic. *| 00970 |* *| 00971 |* Input parameters: *| 00972 |* NONE *| 00973 |* *| 00974 |* Output parameters: *| 00975 |* NONE *| 00976 |* *| 00977 |* Returns: *| 00978 |* NOTHING *| 00979 |* *| 00980 \******************************************************************************/ 00981 00982 void abs_intrinsic(opnd_type *result_opnd, 00983 expr_arg_type *res_exp_desc, 00984 int *spec_idx) 00985 { 00986 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 00987 int ir_idx; 00988 int info_idx1; 00989 int list_idx1; 00990 int type_idx; 00991 00992 00993 TRACE (Func_Entry, "abs_intrinsic", NULL); 00994 00995 ir_idx = OPND_IDX((*result_opnd)); 00996 list_idx1 = IR_IDX_R(ir_idx); 00997 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 00998 type_idx = arg_info_list[info_idx1].ed.type_idx; 00999 01000 if (TYP_TYPE(type_idx) == Complex) { 01001 switch (TYP_LINEAR(type_idx)) { 01002 case Complex_16: 01003 type_idx = Real_16; 01004 break; 01005 01006 case Complex_8: 01007 type_idx = Real_8; 01008 break; 01009 01010 case Complex_4: 01011 type_idx = Real_4; 01012 break; 01013 } 01014 } 01015 01016 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 01017 01018 conform_check(0, 01019 ir_idx, 01020 res_exp_desc, 01021 spec_idx, 01022 FALSE); 01023 01024 01025 IR_TYPE_IDX(ir_idx) = type_idx; 01026 IR_RANK(ir_idx) = res_exp_desc->rank; 01027 01028 01029 res_exp_desc->type_idx = type_idx; 01030 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 01031 res_exp_desc->type = TYP_TYPE(type_idx); 01032 res_exp_desc->shape_known = TRUE; /* April try */ 01033 01034 /**************************/ 01035 /* some kind of intrinsic functions keep shape in expressions 01036 others not */ 01037 01038 # if 0 /* April */ 01039 01040 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 01041 arg_info_list[info_idx1].ed.type == Integer && 01042 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 01043 arg_info_list[info_idx1].ed.type_idx, 01044 NULL, 01045 NULL_IDX, 01046 folded_const, 01047 &type_idx, 01048 IR_LINE_NUM(ir_idx), 01049 IR_COL_NUM(ir_idx), 01050 1, 01051 Abs_Opr)) { 01052 01053 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 01054 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 01055 FALSE, 01056 folded_const); 01057 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 01058 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 01059 res_exp_desc->constant = TRUE; 01060 res_exp_desc->foldable = TRUE; 01061 } 01062 else { 01063 IR_OPR(ir_idx) = Abs_Opr; 01064 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 01065 IR_OPND_R(ir_idx) = null_opnd; 01066 01067 if (arg_info_list[info_idx1].ed.type != Integer) { 01068 /* must reset foldable and will_fold_later because there is no */ 01069 /* folder for this intrinsic in constructors. */ 01070 01071 res_exp_desc->foldable = FALSE; 01072 res_exp_desc->will_fold_later = FALSE; 01073 } 01074 } 01075 01076 # endif 01077 res_exp_desc->foldable = FALSE; 01078 res_exp_desc->will_fold_later = FALSE; 01079 01080 01081 TRACE (Func_Exit, "abs_intrinsic", NULL); 01082 01083 } /* abs_intrinsic */ 01084 01085 01086 /******************************************************************************\ 01087 |* *| 01088 |* Description: *| 01089 |* Function ATAN2(Y, X) intrinsic. *| 01090 |* Function ATAN2D(Y, X) intrinsic. *| 01091 |* *| 01092 |* Input parameters: *| 01093 |* NONE *| 01094 |* *| 01095 |* Output parameters: *| 01096 |* NONE *| 01097 |* *| 01098 |* Returns: *| 01099 |* NOTHING *| 01100 |* *| 01101 \******************************************************************************/ 01102 01103 void atan2_intrinsic(opnd_type *result_opnd, 01104 expr_arg_type *res_exp_desc, 01105 int *spec_idx) 01106 { 01107 int ir_idx; 01108 int info_idx1; 01109 int info_idx2; 01110 int list_idx1; 01111 int list_idx2; 01112 01113 01114 TRACE (Func_Entry, "atan2_intrinsic", NULL); 01115 01116 ir_idx = OPND_IDX((*result_opnd)); 01117 list_idx1 = IR_IDX_R(ir_idx); 01118 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 01119 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 01120 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 01121 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 01122 01123 conform_check(0, 01124 ir_idx, 01125 res_exp_desc, 01126 spec_idx, 01127 FALSE); 01128 01129 if (arg_info_list[info_idx1].ed.linear_type != 01130 arg_info_list[info_idx2].ed.linear_type) { 01131 PRINTMSG(arg_info_list[info_idx2].line, 774, Error, 01132 arg_info_list[info_idx2].col); 01133 } 01134 01135 IR_TYPE_IDX(ir_idx) = arg_info_list[info_idx1].ed.type_idx; 01136 IR_RANK(ir_idx) = res_exp_desc->rank; 01137 01138 switch (ATP_INTRIN_ENUM(*spec_idx)) { 01139 case Atan2_Intrinsic: 01140 case Datan2_Intrinsic: 01141 case Qatan2_Intrinsic: 01142 /* IR_OPR(ir_idx) = Atan2_Opr; */ 01143 break; 01144 01145 case Atan2d_Intrinsic: 01146 case Datan2d_Intrinsic: 01147 case Qatan2d_Intrinsic: 01148 /* IR_OPR(ir_idx) = Atan2d_Opr; */ 01149 break; 01150 01151 default: 01152 PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, IR_COL_NUM(ir_idx), 01153 "atan2_intrinsic"); 01154 break; 01155 } 01156 01157 # if 0 01158 01159 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 01160 IR_OPND_R(ir_idx) = null_opnd; 01161 01162 /* must reset foldable and will_fold_later because there is no */ 01163 /* folder for this intrinsic in constructors. */ 01164 01165 # endif 01166 01167 res_exp_desc->foldable = FALSE; 01168 res_exp_desc->will_fold_later = FALSE; 01169 01170 TRACE (Func_Exit, "atan2_intrinsic", NULL); 01171 01172 } /* atan2_intrinsic */ 01173 01174 01175 /******************************************************************************\ 01176 |* *| 01177 |* Description: *| 01178 |* Function AIMAG(Z) intrinsic. *| 01179 |* *| 01180 |* Input parameters: *| 01181 |* NONE *| 01182 |* *| 01183 |* Output parameters: *| 01184 |* NONE *| 01185 |* *| 01186 |* Returns: *| 01187 |* NOTHING *| 01188 |* *| 01189 \******************************************************************************/ 01190 01191 void aimag_intrinsic(opnd_type *result_opnd, 01192 expr_arg_type *res_exp_desc, 01193 int *spec_idx) 01194 { 01195 int ir_idx; 01196 int type_idx; 01197 int info_idx1; 01198 int list_idx1; 01199 01200 01201 TRACE (Func_Entry, "aimag_intrinsic", NULL); 01202 01203 ir_idx = OPND_IDX((*result_opnd)); 01204 list_idx1 = IR_IDX_R(ir_idx); 01205 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 01206 01207 switch (arg_info_list[info_idx1].ed.linear_type) { 01208 case Complex_4: type_idx = Real_4; break; 01209 case Complex_8: type_idx = Real_8; break; 01210 case Complex_16: type_idx = Real_16; break; 01211 } 01212 01213 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 01214 01215 conform_check(0, 01216 ir_idx, 01217 res_exp_desc, 01218 spec_idx, 01219 FALSE); 01220 01221 IR_TYPE_IDX(ir_idx) = type_idx; 01222 IR_RANK(ir_idx) = res_exp_desc->rank; 01223 01224 # if 0 01225 01226 IR_OPR(ir_idx) = Aimag_Opr; 01227 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 01228 IR_OPND_R(ir_idx) = null_opnd; 01229 01230 /* must reset foldable and will_fold_later because there is no */ 01231 /* folder for this intrinsic in constructors. */ 01232 01233 # endif 01234 01235 res_exp_desc->foldable = FALSE; 01236 res_exp_desc->will_fold_later = FALSE; 01237 01238 01239 TRACE (Func_Exit, "aimag_intrinsic", NULL); 01240 01241 } /* aimag_intrinsic */ 01242 01243 01244 01245 /******************************************************************************\ 01246 |* *| 01247 |* Description: *| 01248 |* Function SHORT(A) intrinsic. *| 01249 |* Function LONG(A) intrinsic. *| 01250 |* Function IDINT(A) intrinsic. *| 01251 |* Function IIDINT(A) intrinsic. *| 01252 |* Function JIDINT(A) intrinsic. *| 01253 |* Function KIDINT(A) intrinsic. *| 01254 |* Function IQINT(A) intrinsic. *| 01255 |* Function IIQINT(A) intrinsic. *| 01256 |* Function JIQINT(A) intrinsic. *| 01257 |* Function KIQINT(A) intrinsic. *| 01258 |* Function INT(A, KIND) intrinsic. *| 01259 |* Function INT1(A) intrinsic. *| 01260 |* Function INT2(A) intrinsic. *| 01261 |* Function INT4(A) intrinsic. *| 01262 |* Function INT8(A) intrinsic. *| 01263 |* Function IINT(A) intrinsic. *| 01264 |* Function JINT(A) intrinsic. *| 01265 |* Function KINT(A) intrinsic. *| 01266 |* Function IFIX(A) intrinsic. *| 01267 |* Function IIFIX(A) intrinsic. *| 01268 |* Function JIFIX(A) intrinsic. *| 01269 |* Function KIFIX(A) intrinsic. *| 01270 |* *| 01271 |* Input parameters: *| 01272 |* NONE *| 01273 |* *| 01274 |* Output parameters: *| 01275 |* NONE *| 01276 |* *| 01277 |* Returns: *| 01278 |* NOTHING *| 01279 |* *| 01280 \******************************************************************************/ 01281 01282 void int_intrinsic(opnd_type *result_opnd, 01283 expr_arg_type *res_exp_desc, 01284 int *spec_idx) 01285 { 01286 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 01287 int ir_idx; 01288 int list_idx1; 01289 int list_idx2; 01290 int info_idx1; 01291 int info_idx2; 01292 opnd_type opnd; 01293 int type_idx; 01294 01295 01296 TRACE (Func_Entry, "int_intrinsic", NULL); 01297 01298 ir_idx = OPND_IDX((*result_opnd)); 01299 list_idx1 = IR_IDX_R(ir_idx); 01300 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 01301 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 01302 01303 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 01304 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 01305 kind_to_linear_type(&((IL_OPND(list_idx2))), 01306 ATP_RSLT_IDX(*spec_idx), 01307 arg_info_list[info_idx2].ed.kind0seen, 01308 arg_info_list[info_idx2].ed.kind0E0seen, 01309 arg_info_list[info_idx2].ed.kind0D0seen, 01310 ! arg_info_list[info_idx2].ed.kindnotconst); 01311 } 01312 else { 01313 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 01314 } 01315 01316 if (ATP_INTRIN_ENUM(*spec_idx) == Int1_Intrinsic) { 01317 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_1; 01318 } 01319 else if (ATP_INTRIN_ENUM(*spec_idx) == Short_Intrinsic || 01320 ATP_INTRIN_ENUM(*spec_idx) == Int2_Intrinsic || 01321 ATP_INTRIN_ENUM(*spec_idx) == Iint_Intrinsic || 01322 ATP_INTRIN_ENUM(*spec_idx) == Iifix_Intrinsic || 01323 ATP_INTRIN_ENUM(*spec_idx) == Iidint_Intrinsic || 01324 ATP_INTRIN_ENUM(*spec_idx) == Iiqint_Intrinsic) { 01325 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_2; 01326 } 01327 else if (ATP_INTRIN_ENUM(*spec_idx) == Long_Intrinsic || 01328 ATP_INTRIN_ENUM(*spec_idx) == Int4_Intrinsic || 01329 ATP_INTRIN_ENUM(*spec_idx) == Jint_Intrinsic || 01330 ATP_INTRIN_ENUM(*spec_idx) == Jifix_Intrinsic || 01331 ATP_INTRIN_ENUM(*spec_idx) == Jidint_Intrinsic || 01332 ATP_INTRIN_ENUM(*spec_idx) == Jiqint_Intrinsic) { 01333 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_4; 01334 } 01335 else if (ATP_INTRIN_ENUM(*spec_idx) == Kint_Intrinsic || 01336 ATP_INTRIN_ENUM(*spec_idx) == Int8_Intrinsic || 01337 ATP_INTRIN_ENUM(*spec_idx) == Kifix_Intrinsic || 01338 ATP_INTRIN_ENUM(*spec_idx) == Kidint_Intrinsic || 01339 ATP_INTRIN_ENUM(*spec_idx) == Kiqint_Intrinsic) { 01340 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 01341 } 01342 01343 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 01344 01345 conform_check(0, 01346 ir_idx, 01347 res_exp_desc, 01348 spec_idx, 01349 FALSE); 01350 01351 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 01352 01353 if (arg_info_list[info_idx1].ed.type == Real) { 01354 COPY_OPND(opnd, IL_OPND(list_idx1)); 01355 look_for_real_div(&opnd); 01356 COPY_OPND(IL_OPND(list_idx1), opnd); 01357 } 01358 01359 01360 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 01361 IR_RANK(ir_idx) = res_exp_desc->rank; 01362 01363 res_exp_desc->type_idx = type_idx; 01364 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 01365 01366 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 01367 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 01368 arg_info_list[info_idx1].ed.type_idx, 01369 NULL, 01370 NULL_IDX, 01371 folded_const, 01372 &type_idx, 01373 IR_LINE_NUM(ir_idx), 01374 IR_COL_NUM(ir_idx), 01375 1, 01376 Int_Opr)) { 01377 01378 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 01379 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 01380 FALSE, 01381 folded_const); 01382 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 01383 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 01384 res_exp_desc->constant = TRUE; 01385 res_exp_desc->foldable = TRUE; 01386 } 01387 else { 01388 IR_OPR(ir_idx) = Int_Opr; 01389 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 01390 IR_OPND_R(ir_idx) = null_opnd; 01391 IR_LIST_CNT_L(ir_idx) = 1; 01392 IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)) = NULL_IDX; 01393 } 01394 01395 01396 TRACE (Func_Exit, "int_intrinsic", NULL); 01397 01398 } /* int_intrinsic */ 01399 01400 01401 /******************************************************************************\ 01402 |* *| 01403 |* Description: *| 01404 |* Function IAND(I, J) intrinsic. *| 01405 |* Function IIAND(I, J) intrinsic. *| 01406 |* Function JIAND(I, J) intrinsic. *| 01407 |* Function KIAND(I, J) intrinsic. *| 01408 |* Function AND(I, J) intrinsic. *| 01409 |* Function IEOR(I, J) intrinsic. *| 01410 |* Function IIEOR(I, J) intrinsic. *| 01411 |* Function JIEOR(I, J) intrinsic. *| 01412 |* Function KIEOR(I, J) intrinsic. *| 01413 |* Function NEQV(I, J) intrinsic. *| 01414 |* Function XOR(I, J) intrinsic. *| 01415 |* Function IOR(I, J) intrinsic. *| 01416 |* Function IIOR(I, J) intrinsic. *| 01417 |* Function JIOR(I, J) intrinsic. *| 01418 |* Function KIOR(I, J) intrinsic. *| 01419 |* Function OR(I, J) intrinsic. *| 01420 |* Function EQV(I, J) intrinsic. *| 01421 |* *| 01422 |* Input parameters: *| 01423 |* NONE *| 01424 |* *| 01425 |* Output parameters: *| 01426 |* NONE *| 01427 |* *| 01428 |* Returns: *| 01429 |* NOTHING *| 01430 |* *| 01431 \******************************************************************************/ 01432 01433 void iand_intrinsic(opnd_type *result_opnd, 01434 expr_arg_type *res_exp_desc, 01435 int *spec_idx) 01436 { 01437 opnd_type opnd; 01438 int cn_idx; 01439 int cn_idx2; 01440 int typeless_idx; 01441 int minus_idx; 01442 int column; 01443 int info_idx1; 01444 int info_idx2; 01445 int line; 01446 int list_idx1; 01447 int list_idx2; 01448 long num; 01449 int shiftl_idx; 01450 int shiftr_idx; 01451 int first_idx; 01452 int second_idx; 01453 int not_idx; 01454 int ir_idx; 01455 boolean ok = TRUE; 01456 operator_type opr; 01457 int type_idx; 01458 01459 01460 TRACE (Func_Entry, "iand_intrinsic", NULL); 01461 01462 ir_idx = OPND_IDX((*result_opnd)); 01463 01464 list_idx1 = IR_IDX_R(ir_idx); 01465 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 01466 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 01467 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 01468 01469 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 01470 (arg_info_list[info_idx1].ed.linear_type == Short_Typeless_Const || 01471 arg_info_list[info_idx1].ed.linear_type == Short_Char_Const)) { 01472 01473 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx1), 01474 &line, 01475 &column); 01476 01477 if (arg_info_list[info_idx1].ed.type == Character) { 01478 PRINTMSG(line, 161, Ansi, column); 01479 } 01480 01481 type_idx = arg_info_list[info_idx2].ed.type_idx; 01482 01483 if (arg_info_list[info_idx2].ed.type == Character || 01484 arg_info_list[info_idx2].ed.type == Typeless) { 01485 type_idx = INTEGER_DEFAULT_TYPE; 01486 } 01487 01488 IL_IDX(list_idx1) = cast_typeless_constant(IL_IDX(list_idx1), 01489 type_idx, 01490 line, 01491 column); 01492 01493 arg_info_list[info_idx1].ed.type_idx = type_idx; 01494 arg_info_list[info_idx1].ed.type = TYP_TYPE(type_idx); 01495 arg_info_list[info_idx1].ed.linear_type = TYP_LINEAR(type_idx); 01496 } 01497 01498 if (IL_FLD(list_idx2) == CN_Tbl_Idx && 01499 (arg_info_list[info_idx2].ed.linear_type == Short_Typeless_Const || 01500 arg_info_list[info_idx2].ed.linear_type == Short_Char_Const)) { 01501 01502 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx2), 01503 &line, 01504 &column); 01505 01506 if (arg_info_list[info_idx2].ed.type == Character) { 01507 PRINTMSG(line, 161, Ansi, column); 01508 } 01509 01510 type_idx = arg_info_list[info_idx1].ed.type_idx; 01511 01512 if (arg_info_list[info_idx1].ed.type == Character || 01513 arg_info_list[info_idx1].ed.type == Typeless) { 01514 type_idx = INTEGER_DEFAULT_TYPE; 01515 } 01516 01517 IL_IDX(list_idx2) = cast_typeless_constant(IL_IDX(list_idx2), 01518 type_idx, 01519 line, 01520 column); 01521 01522 arg_info_list[info_idx2].ed.type_idx = type_idx; 01523 arg_info_list[info_idx2].ed.type = TYP_TYPE(type_idx); 01524 arg_info_list[info_idx2].ed.linear_type = TYP_LINEAR(type_idx); 01525 } 01526 01527 01528 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 01529 # if defined(GENERATE_WHIRL) 01530 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 01531 if (arg_info_list[info_idx1].ed.type == Integer) { 01532 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 01533 arg_info_list[info_idx1].ed.linear_type; 01534 } 01535 # endif 01536 01537 # ifdef _TARGET32 01538 if (arg_info_list[info_idx1].ed.linear_type == Integer_8 || 01539 arg_info_list[info_idx1].ed.linear_type == Typeless_8 || 01540 arg_info_list[info_idx1].ed.linear_type == Real_8) { 01541 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_8; 01542 # if defined(GENERATE_WHIRL) 01543 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 01544 # endif 01545 } 01546 # endif 01547 01548 # ifdef _TARGET_OS_MAX 01549 if (arg_info_list[info_idx1].ed.linear_type == Integer_1 || 01550 arg_info_list[info_idx1].ed.linear_type == Integer_2 || 01551 arg_info_list[info_idx1].ed.linear_type == Integer_4 || 01552 arg_info_list[info_idx1].ed.linear_type == Typeless_4 || 01553 arg_info_list[info_idx1].ed.linear_type == Real_4) { 01554 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_4; 01555 } 01556 # endif 01557 01558 01559 if (ATP_INTRIN_ENUM(*spec_idx) == Iand_Intrinsic || 01560 ATP_INTRIN_ENUM(*spec_idx) == Iiand_Intrinsic || 01561 ATP_INTRIN_ENUM(*spec_idx) == Jiand_Intrinsic || 01562 ATP_INTRIN_ENUM(*spec_idx) == Kiand_Intrinsic || 01563 ATP_INTRIN_ENUM(*spec_idx) == Ior_Intrinsic || 01564 ATP_INTRIN_ENUM(*spec_idx) == Iior_Intrinsic || 01565 ATP_INTRIN_ENUM(*spec_idx) == Jior_Intrinsic || 01566 ATP_INTRIN_ENUM(*spec_idx) == Kior_Intrinsic || 01567 ATP_INTRIN_ENUM(*spec_idx) == Ieor_Intrinsic || 01568 ATP_INTRIN_ENUM(*spec_idx) == Iieor_Intrinsic || 01569 ATP_INTRIN_ENUM(*spec_idx) == Jieor_Intrinsic || 01570 ATP_INTRIN_ENUM(*spec_idx) == Kieor_Intrinsic) { 01571 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 01572 arg_info_list[info_idx1].ed.type_idx; 01573 01574 if (arg_info_list[info_idx1].ed.type == Typeless || 01575 arg_info_list[info_idx2].ed.type == Typeless) { 01576 PRINTMSG(arg_info_list[info_idx1].line, 1076, Ansi, 01577 arg_info_list[info_idx1].col); 01578 01579 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 01580 } 01581 01582 # ifdef _TARGET32 01583 if (arg_info_list[info_idx1].ed.linear_type == Integer_8 || 01584 arg_info_list[info_idx1].ed.linear_type == Typeless_8) { 01585 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 01586 } 01587 # endif 01588 01589 if (arg_info_list[info_idx1].ed.linear_type != 01590 arg_info_list[info_idx2].ed.linear_type) { 01591 PRINTMSG(arg_info_list[info_idx2].line, 774, Error, 01592 arg_info_list[info_idx2].col); 01593 ok = FALSE; 01594 } 01595 } 01596 01597 01598 01599 switch (ATP_INTRIN_ENUM(*spec_idx)) { 01600 case Iand_Intrinsic: 01601 case Iiand_Intrinsic: 01602 case Jiand_Intrinsic: 01603 case Kiand_Intrinsic: 01604 opr = Band_Opr; 01605 break; 01606 01607 case Ior_Intrinsic: 01608 case Iior_Intrinsic: 01609 case Jior_Intrinsic: 01610 case Kior_Intrinsic: 01611 opr = Bor_Opr; 01612 break; 01613 01614 case Ieor_Intrinsic: 01615 case Iieor_Intrinsic: 01616 case Jieor_Intrinsic: 01617 case Kieor_Intrinsic: 01618 opr = Bneqv_Opr; 01619 break; 01620 01621 case And_Intrinsic: 01622 opr = Band_Opr; 01623 if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] != 01624 storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) { 01625 PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error, 01626 IR_COL_NUM(ir_idx)); 01627 ok = FALSE; 01628 } 01629 else if (arg_info_list[info_idx1].ed.type == Logical && 01630 arg_info_list[info_idx2].ed.type == Logical) { 01631 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 01632 opr = And_Opr; 01633 01634 } 01635 break; 01636 01637 case Or_Intrinsic: 01638 opr = Bor_Opr; 01639 if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] != 01640 storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) { 01641 PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error, 01642 IR_COL_NUM(ir_idx)); 01643 ok = FALSE; 01644 } 01645 else if (arg_info_list[info_idx1].ed.type == Logical && 01646 arg_info_list[info_idx2].ed.type == Logical) { 01647 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 01648 opr = Or_Opr; 01649 } 01650 break; 01651 01652 case Xor_Intrinsic: 01653 opr = Bneqv_Opr; 01654 if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] != 01655 storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) { 01656 PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error, 01657 IR_COL_NUM(ir_idx)); 01658 ok = FALSE; 01659 } 01660 else if (arg_info_list[info_idx1].ed.type == Logical && 01661 arg_info_list[info_idx2].ed.type == Logical) { 01662 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 01663 opr = Neqv_Opr; 01664 } 01665 break; 01666 01667 case Neqv_Intrinsic: 01668 opr = Bneqv_Opr; 01669 if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] != 01670 storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) { 01671 PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error, 01672 IR_COL_NUM(ir_idx)); 01673 ok = FALSE; 01674 } 01675 else if (arg_info_list[info_idx1].ed.type == Logical && 01676 arg_info_list[info_idx2].ed.type == Logical) { 01677 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 01678 opr = Neqv_Opr; 01679 } 01680 break; 01681 01682 case Eqv_Intrinsic: 01683 opr = Beqv_Opr; 01684 if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] != 01685 storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) { 01686 PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error, 01687 IR_COL_NUM(ir_idx)); 01688 ok = FALSE; 01689 } 01690 else if (arg_info_list[info_idx1].ed.type == Logical && 01691 arg_info_list[info_idx2].ed.type == Logical) { 01692 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 01693 opr = Eqv_Opr; 01694 } 01695 break; 01696 01697 default: 01698 PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, IR_COL_NUM(ir_idx), 01699 "iand_intrinsic"); 01700 break; 01701 } 01702 01703 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 01704 01705 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_8 || 01706 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Typeless_8) { 01707 typeless_idx = Typeless_8; 01708 # if defined(GENERATE_WHIRL) 01709 typeless_idx = Integer_8; 01710 # endif 01711 } 01712 else { 01713 typeless_idx = TYPELESS_DEFAULT_TYPE; 01714 # if defined(GENERATE_WHIRL) 01715 typeless_idx = INTEGER_DEFAULT_TYPE; 01716 if (arg_info_list[info_idx1].ed.type == Integer) { 01717 typeless_idx = arg_info_list[info_idx1].ed.linear_type; 01718 } 01719 # endif 01720 } 01721 01722 # ifdef _TARGET_OS_MAX 01723 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_1 || 01724 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_2 || 01725 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Typeless_4 || 01726 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_4) { 01727 typeless_idx = Typeless_4; 01728 } 01729 # endif 01730 01731 conform_check(0, 01732 ir_idx, 01733 res_exp_desc, 01734 spec_idx, 01735 FALSE); 01736 01737 01738 IR_TYPE_IDX(ir_idx) = type_idx; 01739 IR_RANK(ir_idx) = res_exp_desc->rank; 01740 01741 /* # if 0 */ 01742 01743 res_exp_desc->type_idx = type_idx; 01744 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 01745 01746 if (opr == And_Opr || 01747 opr == Or_Opr || 01748 opr == Eqv_Opr || 01749 opr == Neqv_Opr) { 01750 IR_OPR(ir_idx) = opr; 01751 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 01752 IR_OPND_R(ir_idx) = null_opnd; 01753 } 01754 else { 01755 01756 01757 line = IR_LINE_NUM(ir_idx); 01758 column = IR_COL_NUM(ir_idx); 01759 01760 not_idx = gen_ir(IL_FLD(list_idx1), IL_IDX(list_idx1), 01761 opr, typeless_idx, line, column, 01762 IL_FLD(list_idx2), IL_IDX(list_idx2)); 01763 01764 num=storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))]; 01765 01766 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 01767 01768 switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) { 01769 case Integer_1: 01770 num = BITSIZE_INT1_F90; 01771 break; 01772 01773 case Integer_2: 01774 num = BITSIZE_INT2_F90; 01775 break; 01776 01777 case Integer_4: 01778 case Typeless_4: 01779 num = BITSIZE_INT4_F90; 01780 break; 01781 01782 case Integer_8: 01783 case Typeless_8: 01784 num = BITSIZE_INT8_F90; 01785 break; 01786 } 01787 01788 cn_idx2 = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 01789 01790 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 01791 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, column, 01792 CN_Tbl_Idx, cn_idx2); 01793 01794 01795 NTR_IR_LIST_TBL(first_idx); 01796 IL_FLD(first_idx) = IR_Tbl_Idx; 01797 IL_IDX(first_idx) = not_idx; 01798 NTR_IR_LIST_TBL(second_idx); 01799 IL_FLD(second_idx) = IR_Tbl_Idx; 01800 IL_IDX(second_idx) = minus_idx; 01801 IL_NEXT_LIST_IDX(first_idx) = second_idx; 01802 01803 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 01804 Shiftl_Opr, typeless_idx, line, column, 01805 NO_Tbl_Idx, NULL_IDX); 01806 01807 NTR_IR_LIST_TBL(first_idx); 01808 IL_FLD(first_idx) = IR_Tbl_Idx; 01809 IL_IDX(first_idx) = shiftl_idx; 01810 NTR_IR_LIST_TBL(second_idx); 01811 IL_FLD(second_idx) = IR_Tbl_Idx; 01812 IL_IDX(second_idx) = minus_idx; 01813 IL_NEXT_LIST_IDX(first_idx) = second_idx; 01814 01815 shiftr_idx = gen_ir(IL_Tbl_Idx, first_idx, 01816 Shiftr_Opr, typeless_idx, line, column, 01817 NO_Tbl_Idx, NULL_IDX); 01818 01819 if (TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer) { 01820 IR_OPR(shiftr_idx) = Shifta_Opr; 01821 } 01822 01823 IR_OPR(ir_idx) = Cvrt_Opr; 01824 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 01825 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 01826 IR_IDX_L(ir_idx) = shiftr_idx; 01827 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 01828 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 01829 IR_FLD_R(ir_idx) = NO_Tbl_Idx; 01830 IR_IDX_R(ir_idx) = NULL_IDX; 01831 01832 if (ok && 01833 IL_FLD(list_idx1) == CN_Tbl_Idx && 01834 IL_FLD(list_idx2) == CN_Tbl_Idx) { 01835 COPY_OPND(opnd, (*result_opnd)); 01836 ok = fold_aggragate_expression(&opnd, res_exp_desc, FALSE); 01837 COPY_OPND((*result_opnd), opnd); 01838 } 01839 01840 } 01841 /* # endif */ 01842 #if 0 01843 res_exp_desc->foldable = FALSE; 01844 res_exp_desc->will_fold_later = FALSE; 01845 #endif 01846 01847 TRACE (Func_Exit, "iand_intrinsic", NULL); 01848 01849 } /* iand_intrinsic */ 01850 01851 01852 /******************************************************************************\ 01853 |* *| 01854 |* Description: *| 01855 |* Function MOD(A, P) intrinsic. *| 01856 |* *| 01857 |* Input parameters: *| 01858 |* NONE *| 01859 |* *| 01860 |* Output parameters: *| 01861 |* NONE *| 01862 |* *| 01863 |* Returns: *| 01864 |* NOTHING *| 01865 |* *| 01866 \******************************************************************************/ 01867 01868 void mod_intrinsic(opnd_type *result_opnd, 01869 expr_arg_type *res_exp_desc, 01870 int *spec_idx) 01871 { 01872 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 01873 int info_idx1; 01874 int info_idx2; 01875 int list_idx1; 01876 int list_idx2; 01877 int ir_idx; 01878 int type_idx; 01879 01880 01881 TRACE (Func_Entry, "mod_intrinsic", NULL); 01882 01883 ir_idx = OPND_IDX((*result_opnd)); 01884 01885 list_idx1 = IR_IDX_R(ir_idx); 01886 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 01887 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 01888 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 01889 01890 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 01891 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 01892 01893 conform_check(0, 01894 ir_idx, 01895 res_exp_desc, 01896 spec_idx, 01897 FALSE); 01898 01899 IR_TYPE_IDX(ir_idx) = type_idx; 01900 IR_RANK(ir_idx) = res_exp_desc->rank; 01901 res_exp_desc->type_idx = type_idx; 01902 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 01903 01904 if (arg_info_list[info_idx1].ed.linear_type != 01905 arg_info_list[info_idx2].ed.linear_type) { 01906 PRINTMSG(IR_LINE_NUM(ir_idx), 774, Error, 01907 IR_COL_NUM(ir_idx)); 01908 } 01909 01910 if (arg_info_list[info_idx1].ed.type == Integer && 01911 IL_FLD(list_idx1) == CN_Tbl_Idx && 01912 IL_FLD(list_idx2) == CN_Tbl_Idx && 01913 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 01914 arg_info_list[info_idx1].ed.type_idx, 01915 (char *)&CN_CONST(IL_IDX(list_idx2)), 01916 arg_info_list[info_idx2].ed.type_idx, 01917 folded_const, 01918 &type_idx, 01919 IR_LINE_NUM(ir_idx), 01920 IR_COL_NUM(ir_idx), 01921 2, 01922 Mod_Opr)) { 01923 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 01924 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 01925 FALSE, 01926 folded_const); 01927 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 01928 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 01929 res_exp_desc->constant = TRUE; 01930 res_exp_desc->foldable = TRUE; 01931 } 01932 else { 01933 IR_OPR(ir_idx) = Mod_Opr; 01934 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 01935 IR_OPND_R(ir_idx) = null_opnd; 01936 01937 if (arg_info_list[info_idx1].ed.type != Integer) { 01938 /* must reset foldable and will_fold_later because there is no */ 01939 /* folder for this intrinsic in constructors. */ 01940 01941 res_exp_desc->foldable = FALSE; 01942 res_exp_desc->will_fold_later = FALSE; 01943 } 01944 } 01945 01946 01947 TRACE (Func_Exit, "mod_intrinsic", NULL); 01948 01949 } /* mod_intrinsic */ 01950 01951 01952 /******************************************************************************\ 01953 |* *| 01954 |* Description: *| 01955 |* Subroutine FREE(P) intrinsic. *| 01956 |* Subroutine TIME(BUF) intrinsic. *| 01957 |* *| 01958 |* Input parameters: *| 01959 |* NONE *| 01960 |* *| 01961 |* Output parameters: *| 01962 |* NONE *| 01963 |* *| 01964 |* Returns: *| 01965 |* NOTHING *| 01966 |* *| 01967 \******************************************************************************/ 01968 void free_intrinsic(opnd_type *result_opnd, 01969 expr_arg_type *res_exp_desc, 01970 int *spec_idx) 01971 { 01972 int ir_idx; 01973 01974 01975 TRACE (Func_Entry, "free_intrinsic", NULL); 01976 01977 ir_idx = OPND_IDX((*result_opnd)); 01978 01979 conform_check(0, 01980 ir_idx, 01981 res_exp_desc, 01982 spec_idx, 01983 FALSE); 01984 01985 01986 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 01987 IR_RANK(ir_idx) = res_exp_desc->rank; 01988 01989 # if 0 01990 01991 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 01992 IR_OPR(ir_idx) = Free_Opr; 01993 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 01994 IR_OPND_R(ir_idx) = null_opnd; 01995 } 01996 01997 /* must reset foldable and will_fold_later because there is no */ 01998 /* folder for this intrinsic in constructors. */ 01999 02000 # endif 02001 02002 res_exp_desc->foldable = FALSE; 02003 res_exp_desc->will_fold_later = FALSE; 02004 02005 TRACE (Func_Exit, "free_intrinsic", NULL); 02006 02007 } /* free_intrinsic */ 02008 02009 02010 /******************************************************************************\ 02011 |* *| 02012 |* Description: *| 02013 |* Function MALLOC(P) intrinsic. *| 02014 |* *| 02015 |* Input parameters: *| 02016 |* NONE *| 02017 |* *| 02018 |* Output parameters: *| 02019 |* NONE *| 02020 |* *| 02021 |* Returns: *| 02022 |* NOTHING *| 02023 |* *| 02024 \******************************************************************************/ 02025 void malloc_intrinsic(opnd_type *result_opnd, 02026 expr_arg_type *res_exp_desc, 02027 int *spec_idx) 02028 { 02029 int ir_idx; 02030 02031 02032 TRACE (Func_Entry, "malloc_intrinsic", NULL); 02033 02034 ir_idx = OPND_IDX((*result_opnd)); 02035 02036 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ptr_8; 02037 02038 conform_check(0, 02039 ir_idx, 02040 res_exp_desc, 02041 spec_idx, 02042 FALSE); 02043 02044 02045 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02046 IR_RANK(ir_idx) = res_exp_desc->rank; 02047 02048 # if 0 02049 02050 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02051 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 02052 02053 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 02054 IR_OPR(ir_idx) = Malloc_Opr; 02055 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 02056 IR_OPND_R(ir_idx) = null_opnd; 02057 } 02058 02059 /* must reset foldable and will_fold_later because there is no */ 02060 /* folder for this intrinsic in constructors. */ 02061 02062 # endif 02063 02064 res_exp_desc->foldable = FALSE; 02065 res_exp_desc->will_fold_later = FALSE; 02066 02067 TRACE (Func_Exit, "malloc_intrinsic", NULL); 02068 02069 } /* malloc_intrinsic */ 02070 02071 02072 02073 /******************************************************************************\ 02074 |* *| 02075 |* Description: *| 02076 |* Function NULL(MOLD) intrinsic. *| 02077 |* *| 02078 |* Input parameters: *| 02079 |* NONE *| 02080 |* *| 02081 |* Output parameters: *| 02082 |* NONE *| 02083 |* *| 02084 |* Returns: *| 02085 |* NOTHING *| 02086 |* *| 02087 \******************************************************************************/ 02088 void null_intrinsic(opnd_type *result_opnd, 02089 expr_arg_type *res_exp_desc, 02090 int *spec_idx) 02091 { 02092 int info_idx1; 02093 int ir_idx; 02094 int line; 02095 int col; 02096 int list_idx1; 02097 int tmp_dv_idx; 02098 int attr_idx; 02099 opnd_type dv_opnd; 02100 02101 02102 TRACE (Func_Entry, "null_intrinsic", NULL); 02103 02104 ir_idx = OPND_IDX((*result_opnd)); 02105 list_idx1 = IR_IDX_R(ir_idx); 02106 02107 line = IR_LINE_NUM(ir_idx); 02108 col = IR_COL_NUM(ir_idx); 02109 02110 conform_check(0, 02111 ir_idx, 02112 res_exp_desc, 02113 spec_idx, 02114 FALSE); 02115 02116 if (list_idx1 == NULL_IDX || IL_IDX(list_idx1) == NULL_IDX) { 02117 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 02118 /* ATD_POINTER(ATP_RSLT_IDX(*spec_idx)) = TRUE; */ 02119 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02120 IR_RANK(ir_idx) = res_exp_desc->rank; 02121 02122 # if 0 02123 02124 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02125 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 02126 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 02127 res_exp_desc->pointer = TRUE; 02128 02129 IR_OPR(ir_idx) = Null_Intrinsic_Opr; 02130 IR_OPND_R(ir_idx) = null_opnd; 02131 IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx); 02132 IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx); 02133 IR_OPND_R(ir_idx) = null_opnd; 02134 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 02135 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 02136 02137 # endif 02138 02139 res_exp_desc->foldable = FALSE; 02140 res_exp_desc->will_fold_later = FALSE; 02141 } 02142 else { 02143 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 02144 02145 if (TYP_TYPE(arg_info_list[info_idx1].ed.type_idx) == Character) { 02146 COPY_OPND((res_exp_desc->char_len), 02147 (arg_info_list[info_idx1].ed.char_len)); 02148 } 02149 02150 attr_idx = find_base_attr(&IL_OPND(list_idx1), &line, &col); 02151 02152 if (IL_FLD(list_idx1) == CN_Tbl_Idx || !ATD_POINTER(attr_idx)) { 02153 PRINTMSG(arg_info_list[info_idx1].line, 1574, Error, 02154 arg_info_list[info_idx1].col); 02155 res_exp_desc->foldable = FALSE; 02156 res_exp_desc->will_fold_later = FALSE; 02157 } 02158 02159 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 02160 arg_info_list[info_idx1].ed.type_idx; 02161 02162 # if 0 02163 02164 ATD_POINTER(ATP_RSLT_IDX(*spec_idx)) = TRUE; 02165 02166 tmp_dv_idx = gen_compiler_tmp(line, col, Priv, TRUE); 02167 ATD_TYPE_IDX(tmp_dv_idx) = ATD_TYPE_IDX(attr_idx); 02168 ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 02169 AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE; 02170 ATD_ARRAY_IDX(tmp_dv_idx) = ATD_ARRAY_IDX(attr_idx); 02171 ATD_POINTER(tmp_dv_idx) = TRUE; 02172 ATD_IM_A_DOPE(tmp_dv_idx) = TRUE; 02173 02174 gen_opnd(&dv_opnd, tmp_dv_idx, AT_Tbl_Idx, line, col); 02175 gen_dv_whole_def_init(&dv_opnd, 02176 tmp_dv_idx, 02177 Before); 02178 02179 # endif 02180 02181 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02182 IR_RANK(ir_idx) = res_exp_desc->rank; 02183 02184 # if 0 02185 02186 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02187 res_exp_desc->type = 02188 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 02189 res_exp_desc->linear_type = 02190 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 02191 res_exp_desc->pointer = TRUE; 02192 res_exp_desc->tmp_reference = TRUE; 02193 02194 gen_opnd(&dv_opnd, 02195 gen_ir(AT_Tbl_Idx, 02196 tmp_dv_idx, 02197 Dv_Deref_Opr, 02198 res_exp_desc->type_idx, 02199 line, 02200 col, 02201 NO_Tbl_Idx, 02202 NULL_IDX), 02203 IR_Tbl_Idx, 02204 line, 02205 col); 02206 02207 if (res_exp_desc->rank > 0) { 02208 gen_whole_subscript(&dv_opnd, res_exp_desc); 02209 } 02210 02211 OPND_IDX((*result_opnd)) = OPND_IDX(dv_opnd); 02212 OPND_FLD((*result_opnd)) = OPND_FLD(dv_opnd); 02213 02214 # endif 02215 res_exp_desc->foldable = FALSE; 02216 res_exp_desc->will_fold_later = FALSE; 02217 } 02218 02219 TRACE (Func_Exit, "null_intrinsic", NULL); 02220 02221 } /* null_intrinsic */ 02222 02223 02224 02225 /******************************************************************************\ 02226 |* *| 02227 |* Description: *| 02228 |* Function ANINT(A, KIND) intrinsic. *| 02229 |* *| 02230 |* Input parameters: *| 02231 |* NONE *| 02232 |* *| 02233 |* Output parameters: *| 02234 |* NONE *| 02235 |* *| 02236 |* Returns: *| 02237 |* NOTHING *| 02238 |* *| 02239 \******************************************************************************/ 02240 02241 void anint_intrinsic(opnd_type *result_opnd, 02242 expr_arg_type *res_exp_desc, 02243 int *spec_idx) 02244 { 02245 int info_idx1; 02246 int info_idx2; 02247 int ir_idx; 02248 int list_idx1; 02249 int list_idx2; 02250 02251 02252 TRACE (Func_Entry, "anint_intrinsic", NULL); 02253 02254 ir_idx = OPND_IDX((*result_opnd)); 02255 list_idx1 = IR_IDX_R(ir_idx); 02256 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 02257 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 02258 02259 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 02260 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 02261 kind_to_linear_type(&((IL_OPND(list_idx2))), 02262 ATP_RSLT_IDX(*spec_idx), 02263 arg_info_list[info_idx2].ed.kind0seen, 02264 arg_info_list[info_idx2].ed.kind0E0seen, 02265 arg_info_list[info_idx2].ed.kind0D0seen, 02266 ! arg_info_list[info_idx2].ed.kindnotconst); 02267 } 02268 else { 02269 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 02270 arg_info_list[info_idx1].ed.type_idx; 02271 } 02272 02273 conform_check(0, 02274 ir_idx, 02275 res_exp_desc, 02276 spec_idx, 02277 FALSE); 02278 02279 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02280 IR_RANK(ir_idx) = res_exp_desc->rank; 02281 02282 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02283 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 02284 02285 IR_OPR(ir_idx) = Anint_Opr; 02286 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 02287 IR_OPND_R(ir_idx) = null_opnd; 02288 IR_LIST_CNT_L(ir_idx) = 1; 02289 IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)) = NULL_IDX; 02290 02291 /* must reset foldable and will_fold_later because there is no */ 02292 /* folder for this intrinsic in constructors. */ 02293 02294 res_exp_desc->foldable = FALSE; 02295 res_exp_desc->will_fold_later = FALSE; 02296 02297 TRACE (Func_Exit, "anint_intrinsic", NULL); 02298 02299 } /* anint_intrinsic */ 02300 02301 02302 /******************************************************************************\ 02303 |* *| 02304 |* Description: *| 02305 |* Function NINT(A, KIND) intrinsic. *| 02306 |* Function ININT(A) intrinsic. *| 02307 |* Function JNINT(A) intrinsic. *| 02308 |* Function KNINT(A) intrinsic. *| 02309 |* *| 02310 |* Input parameters: *| 02311 |* NONE *| 02312 |* *| 02313 |* Output parameters: *| 02314 |* NONE *| 02315 |* *| 02316 |* Returns: *| 02317 |* NOTHING *| 02318 |* *| 02319 \******************************************************************************/ 02320 02321 void nint_intrinsic(opnd_type *result_opnd, 02322 expr_arg_type *res_exp_desc, 02323 int *spec_idx) 02324 { 02325 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 02326 int info_idx1; 02327 int info_idx2; 02328 int ir_idx; 02329 int list_idx1; 02330 int list_idx2; 02331 int type_idx; 02332 02333 02334 TRACE (Func_Entry, "nint_intrinsic", NULL); 02335 02336 ir_idx = OPND_IDX((*result_opnd)); 02337 list_idx1 = IR_IDX_R(ir_idx); 02338 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 02339 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 02340 02341 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 02342 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 02343 kind_to_linear_type(&((IL_OPND(list_idx2))), 02344 ATP_RSLT_IDX(*spec_idx), 02345 arg_info_list[info_idx2].ed.kind0seen, 02346 arg_info_list[info_idx2].ed.kind0E0seen, 02347 arg_info_list[info_idx2].ed.kind0D0seen, 02348 ! arg_info_list[info_idx2].ed.kindnotconst); 02349 } 02350 else { 02351 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 02352 } 02353 02354 if (ATP_INTRIN_ENUM(*spec_idx) == Inint_Intrinsic) { 02355 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_2; 02356 } 02357 else if (ATP_INTRIN_ENUM(*spec_idx) == Jnint_Intrinsic) { 02358 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_4; 02359 } 02360 else if (ATP_INTRIN_ENUM(*spec_idx) == Knint_Intrinsic) { 02361 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 02362 } 02363 02364 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02365 02366 conform_check(0, 02367 ir_idx, 02368 res_exp_desc, 02369 spec_idx, 02370 FALSE); 02371 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02372 IR_RANK(ir_idx) = res_exp_desc->rank; 02373 02374 # if 0 02375 02376 res_exp_desc->type_idx = type_idx; 02377 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 02378 02379 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 02380 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 02381 arg_info_list[info_idx1].ed.type_idx, 02382 NULL, 02383 NULL_IDX, 02384 folded_const, 02385 &type_idx, 02386 IR_LINE_NUM(ir_idx), 02387 IR_COL_NUM(ir_idx), 02388 1, 02389 Nint_Opr)) { 02390 02391 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 02392 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 02393 FALSE, 02394 folded_const); 02395 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 02396 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 02397 res_exp_desc->constant = TRUE; 02398 res_exp_desc->foldable = TRUE; 02399 } 02400 else { 02401 IR_OPR(ir_idx) = Nint_Opr; 02402 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 02403 IR_OPND_R(ir_idx) = null_opnd; 02404 IR_LIST_CNT_L(ir_idx) = 1; 02405 IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)) = NULL_IDX; 02406 } 02407 02408 # endif 02409 res_exp_desc->foldable = FALSE; 02410 res_exp_desc->will_fold_later = FALSE; 02411 02412 02413 TRACE (Func_Exit, "nint_intrinsic", NULL); 02414 02415 } /* nint_intrinsic */ 02416 02417 02418 /******************************************************************************\ 02419 |* *| 02420 |* Description: *| 02421 |* Function SIGN(A, B) intrinsic. *| 02422 |* Function ISIGN(A, B) intrinsic. *| 02423 |* Function IISIGN(A, B) intrinsic. *| 02424 |* Function JISIGN(A, B) intrinsic. *| 02425 |* Function KISIGN(A, B) intrinsic. *| 02426 |* Function DSIGN(A, B) intrinsic. *| 02427 |* Function QSIGN(A, B) intrinsic. *| 02428 |* *| 02429 |* Input parameters: *| 02430 |* NONE *| 02431 |* *| 02432 |* Output parameters: *| 02433 |* NONE *| 02434 |* *| 02435 |* Returns: *| 02436 |* NOTHING *| 02437 |* *| 02438 \******************************************************************************/ 02439 02440 void sign_intrinsic(opnd_type *result_opnd, 02441 expr_arg_type *res_exp_desc, 02442 int *spec_idx) 02443 { 02444 int list_idx1; 02445 int list_idx2; 02446 int info_idx1; 02447 int info_idx2; 02448 int ir_idx; 02449 int type_idx; 02450 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 02451 02452 02453 TRACE (Func_Entry, "sign_intrinsic", NULL); 02454 02455 ir_idx = OPND_IDX((*result_opnd)); 02456 list_idx1 = IR_IDX_R(ir_idx); 02457 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 02458 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 02459 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 02460 02461 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 02462 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02463 02464 # if defined(GENERATE_WHIRL) 02465 if (arg_info_list[info_idx1].ed.linear_type == Real_16) { 02466 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 02467 } 02468 else { 02469 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 02470 } 02471 # endif 02472 02473 conform_check(0, 02474 ir_idx, 02475 res_exp_desc, 02476 spec_idx, 02477 FALSE); 02478 02479 IR_TYPE_IDX(ir_idx) = type_idx; 02480 IR_RANK(ir_idx) = res_exp_desc->rank; 02481 02482 res_exp_desc->type_idx = type_idx; 02483 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 02484 02485 if (arg_info_list[info_idx1].ed.linear_type != 02486 arg_info_list[info_idx2].ed.linear_type) { 02487 PRINTMSG(IR_LINE_NUM(ir_idx), 774, Error, 02488 IR_COL_NUM(ir_idx)); 02489 } 02490 02491 # if 0 02492 02493 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 02494 if (arg_info_list[info_idx1].ed.type == Integer && 02495 IL_FLD(list_idx1) == CN_Tbl_Idx && 02496 IL_FLD(list_idx2) == CN_Tbl_Idx && 02497 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 02498 arg_info_list[info_idx1].ed.type_idx, 02499 (char *)&CN_CONST(IL_IDX(list_idx2)), 02500 arg_info_list[info_idx2].ed.type_idx, 02501 folded_const, 02502 &type_idx, 02503 IR_LINE_NUM(ir_idx), 02504 IR_COL_NUM(ir_idx), 02505 2, 02506 Sign_Opr)) { 02507 02508 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 02509 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 02510 FALSE, 02511 folded_const); 02512 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 02513 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 02514 res_exp_desc->constant = TRUE; 02515 res_exp_desc->foldable = TRUE; 02516 } 02517 else { 02518 IR_OPR(ir_idx) = Sign_Opr; 02519 # if defined(GENERATE_WHIRL) 02520 if (on_off_flags.recognize_minus_zero && 02521 arg_info_list[info_idx1].ed.type == Real) { 02522 IR_OPR(ir_idx) = Ieee_Copy_Sign_Opr; 02523 } 02524 # endif 02525 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 02526 IR_OPND_R(ir_idx) = null_opnd; 02527 02528 if (arg_info_list[info_idx1].ed.type != Integer) { 02529 /* must reset foldable and will_fold_later because there is no */ 02530 /* folder for this intrinsic in constructors. */ 02531 02532 res_exp_desc->foldable = FALSE; 02533 res_exp_desc->will_fold_later = FALSE; 02534 } 02535 } 02536 } 02537 else { 02538 /* must reset foldable and will_fold_later because there is no */ 02539 /* folder for this intrinsic in constructors. */ 02540 02541 res_exp_desc->foldable = FALSE; 02542 res_exp_desc->will_fold_later = FALSE; 02543 } 02544 02545 # endif 02546 res_exp_desc->foldable = FALSE; 02547 res_exp_desc->will_fold_later = FALSE; 02548 02549 02550 TRACE (Func_Exit, "sign_intrinsic", NULL); 02551 02552 } /* sign_intrinsic */ 02553 02554 02555 /******************************************************************************\ 02556 |* *| 02557 |* Description: *| 02558 |* Function MODULO(A, P) intrinsic. *| 02559 |* *| 02560 |* Input parameters: *| 02561 |* NONE *| 02562 |* *| 02563 |* Output parameters: *| 02564 |* NONE *| 02565 |* *| 02566 |* Returns: *| 02567 |* NOTHING *| 02568 |* *| 02569 \******************************************************************************/ 02570 02571 void modulo_intrinsic(opnd_type *result_opnd, 02572 expr_arg_type *res_exp_desc, 02573 int *spec_idx) 02574 { 02575 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 02576 int ir_idx; 02577 int info_idx1; 02578 int info_idx2; 02579 int list_idx1; 02580 int list_idx2; 02581 int type_idx; 02582 02583 02584 TRACE (Func_Entry, "modulo_intrinsic", NULL); 02585 02586 ir_idx = OPND_IDX((*result_opnd)); 02587 list_idx1 = IR_IDX_R(ir_idx); 02588 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 02589 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 02590 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 02591 02592 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 02593 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02594 02595 conform_check(0, 02596 ir_idx, 02597 res_exp_desc, 02598 spec_idx, 02599 FALSE); 02600 02601 02602 IR_TYPE_IDX(ir_idx) = type_idx; 02603 IR_RANK(ir_idx) = res_exp_desc->rank; 02604 res_exp_desc->type_idx = type_idx; 02605 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 02606 02607 if (arg_info_list[info_idx1].ed.linear_type != 02608 arg_info_list[info_idx2].ed.linear_type) { 02609 PRINTMSG(IR_LINE_NUM(ir_idx), 774, Error, 02610 IR_COL_NUM(ir_idx)); 02611 } 02612 02613 # if 0 02614 02615 if (arg_info_list[info_idx1].ed.type == Integer && 02616 IL_FLD(list_idx1) == CN_Tbl_Idx && 02617 IL_FLD(list_idx2) == CN_Tbl_Idx && 02618 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 02619 arg_info_list[info_idx1].ed.type_idx, 02620 (char *)&CN_CONST(IL_IDX(list_idx2)), 02621 arg_info_list[info_idx2].ed.type_idx, 02622 folded_const, 02623 &type_idx, 02624 IR_LINE_NUM(ir_idx), 02625 IR_COL_NUM(ir_idx), 02626 2, 02627 Modulo_Opr)) { 02628 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 02629 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 02630 FALSE, 02631 folded_const); 02632 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 02633 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 02634 res_exp_desc->constant = TRUE; 02635 res_exp_desc->foldable = TRUE; 02636 } 02637 else { 02638 IR_OPR(ir_idx) = Modulo_Opr; 02639 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 02640 IR_OPND_R(ir_idx) = null_opnd; 02641 02642 if (arg_info_list[info_idx1].ed.type != Integer) { 02643 /* must reset foldable and will_fold_later because there is no */ 02644 /* folder for this intrinsic in constructors. */ 02645 02646 res_exp_desc->foldable = FALSE; 02647 res_exp_desc->will_fold_later = FALSE; 02648 } 02649 } 02650 02651 # endif 02652 res_exp_desc->foldable = FALSE; 02653 res_exp_desc->will_fold_later = FALSE; 02654 02655 TRACE (Func_Exit, "modulo_intrinsic", NULL); 02656 02657 } /* modulo_intrinsic */ 02658 02659 02660 /******************************************************************************\ 02661 |* *| 02662 |* Description: *| 02663 |* Function SHIFT(I, J) intrinsic. *| 02664 |* Function SHIFTL(I, J) intrinsic. *| 02665 |* Function LSHIFT(I, POSITIVE_SHIFT) intrinsic. *| 02666 |* Function SHIFTR(I, J) intrinsic. *| 02667 |* Function RSHIFT(I, NEGATIVE_SHIFT) intrinsic. *| 02668 |* Function SHIFTA(I, J) intrinsic. *| 02669 |* *| 02670 |* Input parameters: *| 02671 |* NONE *| 02672 |* *| 02673 |* Output parameters: *| 02674 |* NONE *| 02675 |* *| 02676 |* Returns: *| 02677 |* NOTHING *| 02678 |* *| 02679 \******************************************************************************/ 02680 02681 void shift_intrinsic(opnd_type *result_opnd, 02682 expr_arg_type *res_exp_desc, 02683 int *spec_idx) 02684 { 02685 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 02686 int list_idx1; 02687 int list_idx2; 02688 long num; 02689 int info_idx1; 02690 int info_idx2; 02691 int ir_idx; 02692 operator_type opr; 02693 int type_idx; 02694 int cn_idx; 02695 int line; 02696 int column; 02697 02698 02699 TRACE (Func_Entry, "shift_intrinsic", NULL); 02700 02701 ir_idx = OPND_IDX((*result_opnd)); 02702 list_idx1 = IR_IDX_R(ir_idx); 02703 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 02704 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 02705 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 02706 02707 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 02708 (arg_info_list[info_idx1].ed.linear_type == Short_Typeless_Const || 02709 arg_info_list[info_idx1].ed.linear_type == Short_Char_Const)) { 02710 02711 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx1), 02712 &line, 02713 &column); 02714 02715 if (arg_info_list[info_idx1].ed.type == Character) { 02716 PRINTMSG(line, 161, Ansi, column); 02717 } 02718 02719 type_idx = INTEGER_DEFAULT_TYPE; 02720 02721 IL_IDX(list_idx1) = cast_typeless_constant(IL_IDX(list_idx1), 02722 type_idx, 02723 line, 02724 column); 02725 02726 arg_info_list[info_idx1].ed.type_idx = type_idx; 02727 arg_info_list[info_idx1].ed.type = TYP_TYPE(type_idx); 02728 arg_info_list[info_idx1].ed.linear_type = TYP_LINEAR(type_idx); 02729 } 02730 02731 02732 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 02733 # if defined(GENERATE_WHIRL) 02734 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 02735 if (arg_info_list[info_idx1].ed.type == Integer) { 02736 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 02737 arg_info_list[info_idx1].ed.linear_type; 02738 } 02739 # endif 02740 02741 02742 # ifdef _TARGET32 02743 if (arg_info_list[info_idx1].ed.linear_type == Integer_8 || 02744 arg_info_list[info_idx1].ed.linear_type == Typeless_8 || 02745 arg_info_list[info_idx1].ed.linear_type == Real_8) { 02746 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_8; 02747 # if defined(GENERATE_WHIRL) 02748 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 02749 # endif 02750 } 02751 # endif 02752 02753 02754 # ifdef _TARGET_OS_MAX 02755 if (arg_info_list[info_idx1].ed.linear_type == Integer_1 || 02756 arg_info_list[info_idx1].ed.linear_type == Integer_2 || 02757 arg_info_list[info_idx1].ed.linear_type == Integer_4 || 02758 arg_info_list[info_idx1].ed.linear_type == Typeless_4 || 02759 arg_info_list[info_idx1].ed.linear_type == Real_4) { 02760 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_4; 02761 } 02762 # endif 02763 02764 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02765 02766 switch (ATP_INTRIN_ENUM(*spec_idx)) { 02767 case Shift_Intrinsic: 02768 opr = Shift_Opr; 02769 break; 02770 02771 case Shifta_Intrinsic: 02772 opr = Shifta_Opr; 02773 break; 02774 02775 case Lshift_Intrinsic: 02776 case Shiftl_Intrinsic: 02777 opr = Shiftl_Opr; 02778 break; 02779 02780 case Rshift_Intrinsic: 02781 case Shiftr_Intrinsic: 02782 opr = Shiftr_Opr; 02783 break; 02784 02785 default: 02786 PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, 02787 IR_COL_NUM(ir_idx), 02788 "shift_intrinsic"); 02789 break; 02790 } 02791 02792 conform_check(0, 02793 ir_idx, 02794 res_exp_desc, 02795 spec_idx, 02796 FALSE); 02797 02798 switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) { 02799 case Integer_1: 02800 case Typeless_1: 02801 num = BITSIZE_INT1_F90; 02802 break; 02803 02804 case Integer_2: 02805 case Typeless_2: 02806 num = BITSIZE_INT2_F90; 02807 break; 02808 02809 case Integer_4: 02810 case Typeless_4: 02811 case Real_4: 02812 num = BITSIZE_INT4_F90; 02813 break; 02814 02815 case Integer_8: 02816 case Typeless_8: 02817 case Real_8: 02818 num = BITSIZE_INT8_F90; 02819 break; 02820 02821 default: 02822 PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, 02823 IR_COL_NUM(ir_idx), 02824 "shift_intrinsic"); 02825 break; 02826 } 02827 02828 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { 02829 if (compare_cn_and_value(IL_IDX(list_idx2), num, Gt_Opr) || 02830 compare_cn_and_value(IL_IDX(list_idx2), 0, Lt_Opr)) { 02831 PRINTMSG(arg_info_list[info_idx2].line, 1062, Error, 02832 arg_info_list[info_idx2].col); 02833 } 02834 } 02835 02836 02837 IR_RANK(ir_idx) = res_exp_desc->rank; 02838 IR_TYPE_IDX(ir_idx) = type_idx; 02839 02840 # if 0 02841 02842 res_exp_desc->type_idx = type_idx; 02843 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 02844 02845 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 02846 IL_FLD(list_idx2) == CN_Tbl_Idx && 02847 arg_info_list[info_idx1].ed.type != Real) { 02848 02849 if (opr == Shifta_Opr) { 02850 if (CN_INT_TO_C(IL_IDX(list_idx2)) == 8 && 02851 (arg_info_list[info_idx1].ed.linear_type == Integer_1 || 02852 (arg_info_list[info_idx1].ed.type == Typeless && 02853 TYP_BIT_LEN(arg_info_list[info_idx1].ed.type_idx) == 8) || 02854 arg_info_list[info_idx1].ed.linear_type == Typeless_1)) { 02855 02856 cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, 7); 02857 IL_IDX(list_idx2) = cn_idx; 02858 } 02859 02860 else if (CN_INT_TO_C(IL_IDX(list_idx2)) == 16 && 02861 (arg_info_list[info_idx1].ed.linear_type == Integer_2 || 02862 (arg_info_list[info_idx1].ed.type == Typeless && 02863 TYP_BIT_LEN(arg_info_list[info_idx1].ed.type_idx) == 16) || 02864 arg_info_list[info_idx1].ed.linear_type == Typeless_2)) { 02865 02866 cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, 15); 02867 02868 IL_IDX(list_idx2) = cn_idx; 02869 } 02870 02871 else if (CN_INT_TO_C(IL_IDX(list_idx2)) == 32 && 02872 (arg_info_list[info_idx1].ed.linear_type == Integer_4 || 02873 (arg_info_list[info_idx1].ed.type == Typeless && 02874 TYP_BIT_LEN(arg_info_list[info_idx1].ed.type_idx) == 32) || 02875 arg_info_list[info_idx1].ed.linear_type == Typeless_4)) { 02876 02877 cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, 31); 02878 02879 IL_IDX(list_idx2) = cn_idx; 02880 } 02881 02882 else if (CN_INT_TO_C(IL_IDX(list_idx2)) == 64 && 02883 (arg_info_list[info_idx1].ed.linear_type == Integer_8 || 02884 (arg_info_list[info_idx1].ed.type == Typeless && 02885 TYP_BIT_LEN(arg_info_list[info_idx1].ed.type_idx) == 64) || 02886 arg_info_list[info_idx1].ed.linear_type == Typeless_8)) { 02887 02888 cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, 63); 02889 02890 IL_IDX(list_idx2) = cn_idx; 02891 } 02892 } 02893 02894 if (folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 02895 arg_info_list[info_idx1].ed.type_idx, 02896 (char *)&CN_CONST(IL_IDX(list_idx2)), 02897 arg_info_list[info_idx2].ed.type_idx, 02898 folded_const, 02899 &type_idx, 02900 IR_LINE_NUM(ir_idx), 02901 IR_COL_NUM(ir_idx), 02902 2, 02903 opr)) { 02904 02905 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 02906 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 02907 FALSE, 02908 folded_const); 02909 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 02910 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 02911 res_exp_desc->constant = TRUE; 02912 res_exp_desc->foldable = TRUE; 02913 } 02914 } 02915 else { 02916 IR_OPR(ir_idx) = opr; 02917 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 02918 IR_OPND_R(ir_idx) = null_opnd; 02919 02920 if (arg_info_list[info_idx1].ed.type == Real) { 02921 /* must reset foldable and will_fold_later because there is no */ 02922 /* folder for this intrinsic in constructors. */ 02923 02924 res_exp_desc->foldable = FALSE; 02925 res_exp_desc->will_fold_later = FALSE; 02926 } 02927 } 02928 02929 # endif 02930 res_exp_desc->foldable = FALSE; 02931 res_exp_desc->will_fold_later = FALSE; 02932 02933 TRACE (Func_Exit, "shift_intrinsic", NULL); 02934 02935 } /* shift_intrinsic */ 02936 02937 /******************************************************************************\ 02938 |* *| 02939 |* Description: *| 02940 |* Function NUM_IMAGES() intrinsic. *| 02941 |* Function REM_IMAGES() intrinsic. *| 02942 |* Function LOG2_IMAGES() intrinsic. *| 02943 |* Function THIS_IMAGE([array[,dim]]) intrinsic. *| 02944 |* Subroutine SYNC_IMAGES([image]) intrinsic. *| 02945 |* *| 02946 |* Input parameters: *| 02947 |* NONE *| 02948 |* *| 02949 |* Output parameters: *| 02950 |* NONE *| 02951 |* *| 02952 |* Returns: *| 02953 |* NOTHING *| 02954 |* *| 02955 \******************************************************************************/ 02956 02957 void num_images_intrinsic(opnd_type *result_opnd, 02958 expr_arg_type *res_exp_desc, 02959 int *spec_idx) 02960 { 02961 int line; 02962 int column; 02963 int ir_idx; 02964 int cn_idx; 02965 int plus_idx; 02966 int power_idx; 02967 int div_idx; 02968 int info_idx1; 02969 int int_idx; 02970 int mod_idx; 02971 int list_idx1; 02972 int list_idx2; 02973 opnd_type opnd; 02974 int opnd_line; 02975 int opnd_col; 02976 int l_log10_idx; 02977 int r_log10_idx; 02978 float point_five; 02979 float f_two; 02980 int sn_idx; 02981 int attr_idx; 02982 expr_arg_type loc_exp_desc; 02983 02984 02985 TRACE (Func_Entry, "num_images_intrinsic", NULL); 02986 02987 ir_idx = OPND_IDX((*result_opnd)); 02988 line = IR_LINE_NUM(ir_idx); 02989 column = IR_COL_NUM(ir_idx); 02990 02991 if (ATP_INTRIN_ENUM(*spec_idx) != Sync_Images_Intrinsic) { 02992 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 02993 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 02994 } 02995 else { 02996 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 02997 } 02998 02999 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 03000 03001 conform_check(0, 03002 ir_idx, 03003 res_exp_desc, 03004 spec_idx, 03005 FALSE); 03006 03007 IR_RANK(ir_idx) = res_exp_desc->rank; 03008 03009 03010 if (ATP_INTRIN_ENUM(*spec_idx) == Rem_Images_Intrinsic) { 03011 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 03012 #if 0 03013 point_five = 0.5; 03014 03015 /* JEFFL - Do we need to convert endian? - BRIANJ */ 03016 /* We could call arith to do 1/2 and then we would have it correct for sure. */ 03017 03018 /* JBL - this won't work when float is not the same as REAL_DEFAULT_TYPE - BHJ*/ 03019 03020 cn_idx = ntr_const_tbl(REAL_DEFAULT_TYPE, FALSE,(long_type *)&point_five); 03021 OPND_FLD(opnd) = IR_Tbl_Idx; 03022 OPND_IDX(opnd) = ir_idx; 03023 copy_subtree(&opnd, &opnd); 03024 plus_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 03025 Plus_Opr, REAL_DEFAULT_TYPE, line, column, 03026 CN_Tbl_Idx, cn_idx); 03027 03028 f_two = 2.0; 03029 cn_idx = ntr_const_tbl(REAL_DEFAULT_TYPE, FALSE, (long_type *)&f_two); 03030 03031 r_log10_idx = gen_ir(CN_Tbl_Idx, cn_idx, 03032 Log_10_Opr, REAL_DEFAULT_TYPE, line, column, 03033 NO_Tbl_Idx, NULL_IDX); 03034 03035 l_log10_idx = gen_ir(IR_Tbl_Idx, plus_idx, 03036 Log_10_Opr, REAL_DEFAULT_TYPE, line, column, 03037 NO_Tbl_Idx, NULL_IDX); 03038 03039 03040 div_idx = gen_ir(IR_Tbl_Idx, l_log10_idx, 03041 Div_Opr, REAL_DEFAULT_TYPE, line, column, 03042 IR_Tbl_Idx, r_log10_idx); 03043 03044 int_idx = gen_ir(IR_Tbl_Idx, div_idx, 03045 Int_Opr, INTEGER_DEFAULT_TYPE, line, column, 03046 NO_Tbl_Idx, NULL_IDX); 03047 03048 cn_idx = CN_INTEGER_TWO_IDX; 03049 03050 power_idx = gen_ir(CN_Tbl_Idx, cn_idx, 03051 Power_Opr, INTEGER_DEFAULT_TYPE, line, column, 03052 IR_Tbl_Idx, int_idx); 03053 03054 OPND_FLD(opnd) = IR_Tbl_Idx; 03055 OPND_IDX(opnd) = ir_idx; 03056 copy_subtree(&opnd, &opnd); 03057 mod_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 03058 Mod_Opr, INTEGER_DEFAULT_TYPE, line, column, 03059 IR_Tbl_Idx, power_idx); 03060 03061 IR_IDX_L(ir_idx) = mod_idx; 03062 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 03063 IR_OPND_R(ir_idx) = null_opnd; 03064 IR_OPR(ir_idx) = Int_Opr; 03065 #endif 03066 03067 } 03068 else if (ATP_INTRIN_ENUM(*spec_idx) == Log2_Images_Intrinsic) { 03069 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 03070 #if 0 03071 point_five = 0.5; 03072 cn_idx = ntr_const_tbl(REAL_DEFAULT_TYPE, FALSE,(long_type *)&point_five); 03073 03074 OPND_FLD(opnd) = IR_Tbl_Idx; 03075 OPND_IDX(opnd) = ir_idx; 03076 copy_subtree(&opnd, &opnd); 03077 plus_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 03078 Plus_Opr, REAL_DEFAULT_TYPE, line, column, 03079 CN_Tbl_Idx, cn_idx); 03080 03081 f_two = 2.0; 03082 cn_idx = ntr_const_tbl(REAL_DEFAULT_TYPE, FALSE, (long_type *)&f_two); 03083 03084 r_log10_idx = gen_ir(CN_Tbl_Idx, cn_idx, 03085 Log_10_Opr, REAL_DEFAULT_TYPE, line, column, 03086 NO_Tbl_Idx, NULL_IDX); 03087 03088 l_log10_idx = gen_ir(IR_Tbl_Idx, plus_idx, 03089 Log_10_Opr, REAL_DEFAULT_TYPE, line, column, 03090 NO_Tbl_Idx, NULL_IDX); 03091 03092 div_idx = gen_ir(IR_Tbl_Idx, l_log10_idx, 03093 Div_Opr, REAL_DEFAULT_TYPE, line, column, 03094 IR_Tbl_Idx, r_log10_idx); 03095 03096 IR_IDX_L(ir_idx) = div_idx; 03097 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 03098 IR_OPND_R(ir_idx) = null_opnd; 03099 IR_OPR(ir_idx) = Int_Opr; 03100 #endif 03101 } 03102 else if (ATP_INTRIN_ENUM(*spec_idx) == This_Image_Intrinsic) { 03103 03104 if (IR_LIST_CNT_R(ir_idx) > 0) { 03105 03106 list_idx1 = IR_IDX_R(ir_idx); 03107 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 03108 03109 if (IR_LIST_CNT_R(ir_idx) == 2) { 03110 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 03111 } 03112 03113 if (arg_info_list[info_idx1].ed.reference) { 03114 attr_idx = find_base_attr(&IL_OPND(list_idx1), 03115 &opnd_line, &opnd_col); 03116 03117 if (AT_DCL_ERR(attr_idx)) { 03118 goto EXIT; 03119 } 03120 03121 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 03122 ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX && 03123 IR_LIST_CNT_R(ir_idx) == 1 && 03124 BD_RANK(ATD_PE_ARRAY_IDX(attr_idx)) == 1) { 03125 03126 /* change to this_image3 with dim == 1 */ 03127 03128 sn_idx = ATI_FIRST_SPECIFIC_IDX(ATP_INTERFACE_IDX(*spec_idx)); 03129 03130 while (sn_idx) { 03131 if (ATP_NUM_DARGS(SN_ATTR_IDX(sn_idx)) == 2) { 03132 break; 03133 } 03134 sn_idx = SN_SIBLING_LINK(sn_idx); 03135 } 03136 03137 if (sn_idx != NULL_IDX) { 03138 IR_IDX_L(ir_idx) = SN_ATTR_IDX(sn_idx); 03139 *spec_idx = SN_ATTR_IDX(sn_idx); 03140 ATP_EXTERNAL_INTRIN((*spec_idx)) = TRUE; 03141 ATD_TYPE_IDX(ATP_RSLT_IDX((*spec_idx))) = 03142 INTEGER_DEFAULT_TYPE; 03143 03144 NTR_IR_LIST_TBL(list_idx2); 03145 IL_NEXT_LIST_IDX(list_idx1) = list_idx2; 03146 IL_ARG_DESC_VARIANT(list_idx2) = TRUE; 03147 IR_LIST_CNT_R(ir_idx) += 1; 03148 03149 IL_FLD(list_idx2) = CN_Tbl_Idx; 03150 IL_IDX(list_idx2) = CN_INTEGER_ONE_IDX; 03151 IL_LINE_NUM(list_idx2) = line; 03152 IL_COL_NUM(list_idx2) = column; 03153 03154 arg_info_list_base = arg_info_list_top; 03155 arg_info_list_top = arg_info_list_base + 1; 03156 03157 if (arg_info_list_top >= arg_info_list_size) { 03158 enlarge_info_list_table(); 03159 } 03160 03161 IL_ARG_DESC_IDX(list_idx2) = arg_info_list_top; 03162 arg_info_list[arg_info_list_top] = init_arg_info; 03163 arg_info_list[arg_info_list_top].ed.constant = TRUE; 03164 arg_info_list[arg_info_list_top].ed.foldable = TRUE; 03165 arg_info_list[arg_info_list_top].ed.type = Integer; 03166 arg_info_list[arg_info_list_top].ed.type_idx = 03167 CG_INTEGER_DEFAULT_TYPE; 03168 arg_info_list[arg_info_list_top].ed.linear_type = 03169 CG_INTEGER_DEFAULT_TYPE; 03170 arg_info_list[arg_info_list_top].line = line; 03171 arg_info_list[arg_info_list_top].col = column; 03172 } 03173 } 03174 } 03175 03176 if (! arg_info_list[info_idx1].ed.reference) { 03177 /* error, not a co-array */ 03178 find_opnd_line_and_column(&IL_OPND(list_idx1), 03179 &opnd_line, &opnd_col); 03180 PRINTMSG(opnd_line, 1575, Error, opnd_col); 03181 } 03182 else { 03183 attr_idx = find_base_attr(&IL_OPND(list_idx1), 03184 &opnd_line, &opnd_col); 03185 03186 if (AT_OBJ_CLASS(attr_idx) != Data_Obj || 03187 ATD_PE_ARRAY_IDX(attr_idx) == NULL_IDX) { 03188 /* error, not a co-array */ 03189 PRINTMSG(opnd_line, 1575, Error, opnd_col); 03190 } 03191 else { 03192 03193 if (ATD_ALLOCATABLE(attr_idx)) { 03194 attr_idx = ATD_VARIABLE_TMP_IDX(attr_idx); 03195 } 03196 #if 0 03197 COPY_OPND(opnd, IL_OPND(list_idx1)); 03198 generate_bounds_list(ATD_PE_ARRAY_IDX(attr_idx), 03199 &opnd, 03200 &loc_exp_desc); 03201 COPY_OPND(IL_OPND(list_idx1), opnd); 03202 #endif 03203 arg_info_list[info_idx1].ed = loc_exp_desc; 03204 03205 } 03206 } 03207 } 03208 } 03209 03210 03211 EXIT: 03212 03213 /* must reset foldable and will_fold_later because there is no */ 03214 /* folder for this intrinsic in constructors. */ 03215 03216 03217 res_exp_desc->foldable = FALSE; 03218 res_exp_desc->will_fold_later = FALSE; 03219 03220 TRACE (Func_Exit, "num_images_intrinsic", NULL); 03221 03222 } /* num_images_intrinsic */ 03223 03224 03225 /******************************************************************************\ 03226 |* *| 03227 |* Description: *| 03228 |* Function LEADZ(I) intrinsic. *| 03229 |* Function POPCNT(I) intrinsic. *| 03230 |* Function POPPAR(I) intrinsic. *| 03231 |* *| 03232 |* Input parameters: *| 03233 |* NONE *| 03234 |* *| 03235 |* Output parameters: *| 03236 |* NONE *| 03237 |* *| 03238 |* Returns: *| 03239 |* NOTHING *| 03240 |* *| 03241 \******************************************************************************/ 03242 03243 void leadz_intrinsic(opnd_type *result_opnd, 03244 expr_arg_type *res_exp_desc, 03245 int *spec_idx) 03246 { 03247 int ir_idx; 03248 int list_idx1; 03249 int info_idx1; 03250 03251 03252 TRACE (Func_Entry, "leadz_intrinsic", NULL); 03253 03254 ir_idx = OPND_IDX((*result_opnd)); 03255 list_idx1 = IR_IDX_R(ir_idx); 03256 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 03257 03258 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 03259 03260 if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] > 64) { 03261 PRINTMSG(arg_info_list[info_idx1].line, 774, Error, 03262 arg_info_list[info_idx1].col); 03263 } 03264 03265 conform_check(0, 03266 ir_idx, 03267 res_exp_desc, 03268 spec_idx, 03269 FALSE); 03270 03271 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 03272 IR_RANK(ir_idx) = res_exp_desc->rank; 03273 03274 # if 0 03275 03276 if (ATP_INTRIN_ENUM(*spec_idx) == Popcnt_Intrinsic) { 03277 IR_OPR(ir_idx) = Popcnt_Opr; 03278 } 03279 else if (ATP_INTRIN_ENUM(*spec_idx) == Poppar_Intrinsic) { 03280 IR_OPR(ir_idx) = Poppar_Opr; 03281 } 03282 else { 03283 IR_OPR(ir_idx) = Leadz_Opr; 03284 } 03285 03286 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 03287 IR_OPND_R(ir_idx) = null_opnd; 03288 03289 /* must reset foldable and will_fold_later because there is no */ 03290 /* folder for this intrinsic in constructors. */ 03291 03292 # endif 03293 03294 res_exp_desc->foldable = FALSE; 03295 res_exp_desc->will_fold_later = FALSE; 03296 03297 TRACE (Func_Exit, "leadz_intrinsic", NULL); 03298 03299 } /* leadz_intrinsic */ 03300 03301 03302 /******************************************************************************\ 03303 |* *| 03304 |* Description: *| 03305 |* Function NOT(I) intrinsic. *| 03306 |* Function INOT(I) intrinsic. *| 03307 |* Function JNOT(I) intrinsic. *| 03308 |* Function KNOT(I) intrinsic. *| 03309 |* Function COMPL(I) intrinsic. *| 03310 |* *| 03311 |* Input parameters: *| 03312 |* NONE *| 03313 |* *| 03314 |* Output parameters: *| 03315 |* NONE *| 03316 |* *| 03317 |* Returns: *| 03318 |* NOTHING *| 03319 |* *| 03320 \******************************************************************************/ 03321 03322 void not_intrinsic(opnd_type *result_opnd, 03323 expr_arg_type *res_exp_desc, 03324 int *spec_idx) 03325 { 03326 opnd_type opnd; 03327 int info_idx1; 03328 int ir_idx; 03329 int list_idx1; 03330 long num; 03331 operator_type opr; 03332 int first_idx; 03333 int cn_idx; 03334 int cn_idx2; 03335 int typeless_idx; 03336 int second_idx; 03337 int minus_idx; 03338 int type_idx; 03339 int not_idx; 03340 int shiftl_idx; 03341 int shiftr_idx; 03342 int line; 03343 int column; 03344 03345 03346 TRACE (Func_Entry, "not_intrinsic", NULL); 03347 03348 ir_idx = OPND_IDX((*result_opnd)); 03349 list_idx1 = IR_IDX_R(ir_idx); 03350 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 03351 03352 if (arg_info_list[info_idx1].ed.type == Logical) { 03353 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 03354 opr = Not_Opr; 03355 } 03356 else { 03357 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 03358 (arg_info_list[info_idx1].ed.linear_type == 03359 Short_Typeless_Const || 03360 arg_info_list[info_idx1].ed.linear_type == 03361 Short_Char_Const)) { 03362 03363 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx1), 03364 &line, 03365 &column); 03366 03367 if (arg_info_list[info_idx1].ed.type == Character) { 03368 PRINTMSG(line, 161, Ansi, column); 03369 } 03370 03371 type_idx = INTEGER_DEFAULT_TYPE; 03372 03373 IL_IDX(list_idx1) = cast_typeless_constant(IL_IDX(list_idx1), 03374 type_idx, 03375 line, 03376 column); 03377 03378 arg_info_list[info_idx1].ed.type_idx = type_idx; 03379 arg_info_list[info_idx1].ed.type = TYP_TYPE(type_idx); 03380 arg_info_list[info_idx1].ed.linear_type = TYP_LINEAR(type_idx); 03381 } 03382 03383 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 03384 arg_info_list[info_idx1].ed.type_idx; 03385 03386 if (ATP_INTRIN_ENUM(*spec_idx) == Compl_Intrinsic) { 03387 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 03388 # if defined(GENERATE_WHIRL) 03389 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 03390 if (arg_info_list[info_idx1].ed.type == Integer) { 03391 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 03392 arg_info_list[info_idx1].ed.linear_type; 03393 } 03394 # endif 03395 03396 03397 # ifdef _TARGET32 03398 if ((arg_info_list[info_idx1].ed.linear_type == Integer_8) || 03399 (arg_info_list[info_idx1].ed.linear_type == Typeless_8) || 03400 (arg_info_list[info_idx1].ed.linear_type == Real_8)) { 03401 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_8; 03402 # if defined(GENERATE_WHIRL) 03403 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 03404 # endif 03405 } 03406 # endif 03407 03408 # ifdef _TARGET_OS_MAX 03409 if (arg_info_list[info_idx1].ed.linear_type == Integer_1 || 03410 arg_info_list[info_idx1].ed.linear_type == Integer_2 || 03411 arg_info_list[info_idx1].ed.linear_type == Integer_4 || 03412 arg_info_list[info_idx1].ed.linear_type == Typeless_4 || 03413 arg_info_list[info_idx1].ed.linear_type == Real_4) { 03414 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_4; 03415 } 03416 # endif 03417 } 03418 opr = Bnot_Opr; 03419 } 03420 03421 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_8 || 03422 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Typeless_8) { 03423 typeless_idx = Typeless_8; 03424 } 03425 else { 03426 typeless_idx = TYPELESS_DEFAULT_TYPE; 03427 } 03428 03429 # ifdef _TARGET_OS_MAX 03430 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_1 || 03431 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_2 || 03432 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Typeless_4 || 03433 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_4) { 03434 typeless_idx = Typeless_4; 03435 } 03436 # endif 03437 03438 conform_check(0, 03439 ir_idx, 03440 res_exp_desc, 03441 spec_idx, 03442 FALSE); 03443 03444 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 03445 IR_RANK(ir_idx) = res_exp_desc->rank; 03446 03447 # if 0 03448 03449 res_exp_desc->type_idx = IR_TYPE_IDX(ir_idx); 03450 res_exp_desc->linear_type = TYP_LINEAR(IR_TYPE_IDX(ir_idx)); 03451 03452 if (opr == Not_Opr) { 03453 IR_OPR(ir_idx) = opr; 03454 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 03455 IR_OPND_R(ir_idx) = null_opnd; 03456 } 03457 else { 03458 03459 line = IR_LINE_NUM(ir_idx); 03460 column = IR_COL_NUM(ir_idx); 03461 03462 not_idx = gen_ir(IL_FLD(list_idx1), IL_IDX(list_idx1), 03463 opr, typeless_idx, line, column, 03464 NO_Tbl_Idx, NULL_IDX); 03465 num = storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX( 03466 ATP_RSLT_IDX(*spec_idx)))]; 03467 03468 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 03469 03470 switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) { 03471 case Integer_1: 03472 num = BITSIZE_INT1_F90; 03473 break; 03474 03475 case Integer_2: 03476 num = BITSIZE_INT2_F90; 03477 break; 03478 03479 case Integer_4: 03480 case Typeless_4: 03481 num = BITSIZE_INT4_F90; 03482 break; 03483 03484 case Integer_8: 03485 case Typeless_8: 03486 num = BITSIZE_INT8_F90; 03487 break; 03488 } 03489 03490 cn_idx2 = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 03491 03492 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 03493 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, column, 03494 CN_Tbl_Idx, cn_idx2); 03495 03496 NTR_IR_LIST_TBL(first_idx); 03497 IL_FLD(first_idx) = IR_Tbl_Idx; 03498 IL_IDX(first_idx) = not_idx; 03499 NTR_IR_LIST_TBL(second_idx); 03500 IL_FLD(second_idx) = IR_Tbl_Idx; 03501 IL_IDX(second_idx) = minus_idx; 03502 IL_NEXT_LIST_IDX(first_idx) = second_idx; 03503 03504 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 03505 Shiftl_Opr, typeless_idx, line, column, 03506 NO_Tbl_Idx, NULL_IDX); 03507 03508 NTR_IR_LIST_TBL(first_idx); 03509 IL_FLD(first_idx) = IR_Tbl_Idx; 03510 IL_IDX(first_idx) = shiftl_idx; 03511 NTR_IR_LIST_TBL(second_idx); 03512 IL_FLD(second_idx) = IR_Tbl_Idx; 03513 IL_IDX(second_idx) = minus_idx; 03514 IL_NEXT_LIST_IDX(first_idx) = second_idx; 03515 03516 shiftr_idx = gen_ir(IL_Tbl_Idx, first_idx, 03517 Shiftr_Opr, typeless_idx, line, column, 03518 NO_Tbl_Idx, NULL_IDX); 03519 03520 if (TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer) { 03521 IR_OPR(shiftr_idx) = Shifta_Opr; 03522 } 03523 03524 IR_OPR(ir_idx) = Cvrt_Opr; 03525 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 03526 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 03527 IR_IDX_L(ir_idx) = shiftr_idx; 03528 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 03529 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 03530 IR_OPND_R(ir_idx) = null_opnd; 03531 03532 if (IL_FLD(list_idx1) == CN_Tbl_Idx) { 03533 COPY_OPND(opnd, (*result_opnd)); 03534 fold_aggragate_expression(&opnd, res_exp_desc, FALSE); 03535 COPY_OPND((*result_opnd), opnd); 03536 } 03537 } 03538 03539 # endif 03540 res_exp_desc->foldable = FALSE; 03541 res_exp_desc->will_fold_later = FALSE; 03542 03543 TRACE (Func_Exit, "not_intrinsic", NULL); 03544 03545 } /* not_intrinsic */ 03546 03547 03548 /******************************************************************************\ 03549 |* *| 03550 |* Description: *| 03551 |* Function AINT(A,KIND) intrinsic. *| 03552 |* *| 03553 |* Input parameters: *| 03554 |* NONE *| 03555 |* *| 03556 |* Output parameters: *| 03557 |* NONE *| 03558 |* *| 03559 |* Returns: *| 03560 |* NOTHING *| 03561 |* *| 03562 \******************************************************************************/ 03563 03564 void aint_intrinsic(opnd_type *result_opnd, 03565 expr_arg_type *res_exp_desc, 03566 int *spec_idx) 03567 { 03568 int info_idx1; 03569 int info_idx2; 03570 int list_idx1; 03571 int list_idx2; 03572 int ir_idx; 03573 03574 03575 TRACE (Func_Entry, "aint_intrinsic", NULL); 03576 03577 ir_idx = OPND_IDX((*result_opnd)); 03578 list_idx1 = IR_IDX_R(ir_idx); 03579 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 03580 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 03581 03582 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 03583 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 03584 kind_to_linear_type(&((IL_OPND(list_idx2))), 03585 ATP_RSLT_IDX(*spec_idx), 03586 arg_info_list[info_idx2].ed.kind0seen, 03587 arg_info_list[info_idx2].ed.kind0E0seen, 03588 arg_info_list[info_idx2].ed.kind0D0seen, 03589 ! arg_info_list[info_idx2].ed.kindnotconst); 03590 } 03591 else { 03592 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 03593 arg_info_list[info_idx1].ed.type_idx; 03594 } 03595 03596 conform_check(0, 03597 ir_idx, 03598 res_exp_desc, 03599 spec_idx, 03600 FALSE); 03601 03602 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 03603 IR_RANK(ir_idx) = res_exp_desc->rank; 03604 03605 # if 0 03606 03607 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 03608 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 03609 03610 IR_OPR(ir_idx) = Aint_Opr; 03611 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 03612 IR_OPND_R(ir_idx) = null_opnd; 03613 IR_LIST_CNT_L(ir_idx) = 1; 03614 IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)) = NULL_IDX; 03615 03616 /* must reset foldable and will_fold_later because there is no */ 03617 /* folder for this intrinsic in constructors. */ 03618 03619 res_exp_desc->foldable = FALSE; 03620 res_exp_desc->will_fold_later = FALSE; 03621 03622 # endif 03623 res_exp_desc->foldable = FALSE; 03624 res_exp_desc->will_fold_later = FALSE; 03625 03626 TRACE (Func_Exit, "aint_intrinsic", NULL); 03627 03628 } /* aint_intrinsic */ 03629 03630 03631 /******************************************************************************\ 03632 |* *| 03633 |* Description: *| 03634 |* Function ILEN(I) intrinsic. *| 03635 |* JBL - you must add folding of this intrinsic in fold_drive.c *| 03636 |* *| 03637 |* Input parameters: *| 03638 |* NONE *| 03639 |* *| 03640 |* Output parameters: *| 03641 |* NONE *| 03642 |* *| 03643 |* Returns: *| 03644 |* NOTHING *| 03645 |* *| 03646 \******************************************************************************/ 03647 03648 void ilen_intrinsic(opnd_type *result_opnd, 03649 expr_arg_type *res_exp_desc, 03650 int *spec_idx) 03651 { 03652 int info_idx1; 03653 int ir_idx; 03654 int list_idx1; 03655 03656 03657 TRACE (Func_Entry, "ilen_intrinsic", NULL); 03658 03659 ir_idx = OPND_IDX((*result_opnd)); 03660 list_idx1 = IR_IDX_R(ir_idx); 03661 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 03662 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 03663 03664 conform_check(0, 03665 ir_idx, 03666 res_exp_desc, 03667 spec_idx, 03668 FALSE); 03669 03670 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 03671 IR_RANK(ir_idx) = res_exp_desc->rank; 03672 03673 # if 0 03674 03675 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 03676 res_exp_desc->linear_type = 03677 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 03678 03679 res_exp_desc->foldable = FALSE; 03680 res_exp_desc->will_fold_later = FALSE; 03681 03682 /* set this flag so this opr is pulled off io lists */ 03683 io_item_must_flatten = TRUE; 03684 03685 # endif 03686 res_exp_desc->foldable = FALSE; 03687 res_exp_desc->will_fold_later = FALSE; 03688 03689 TRACE (Func_Exit, "ilen_intrinsic", NULL); 03690 03691 } /* ilen_intrinsic */ 03692 03693 03694 /******************************************************************************\ 03695 |* *| 03696 |* Description: *| 03697 |* Function DIM(X,Y) intrinsic. *| 03698 |* Function DDIM(X,Y) intrinsic. *| 03699 |* Function QDIM(X,Y) intrinsic. *| 03700 |* *| 03701 |* Input parameters: *| 03702 |* NONE *| 03703 |* *| 03704 |* Output parameters: *| 03705 |* NONE *| 03706 |* *| 03707 |* Returns: *| 03708 |* NOTHING *| 03709 |* *| 03710 \******************************************************************************/ 03711 03712 void dim_intrinsic(opnd_type *result_opnd, 03713 expr_arg_type *res_exp_desc, 03714 int *spec_idx) 03715 { 03716 int info_idx1; 03717 int info_idx2; 03718 int arg1; 03719 int arg2; 03720 int arg3; 03721 int ir_idx; 03722 int gt_idx; 03723 int type_idx; 03724 int zero_idx; 03725 int minus_idx; 03726 int select_idx; 03727 int list_idx1; 03728 int list_idx2; 03729 int line; 03730 int column; 03731 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 03732 03733 03734 TRACE (Func_Entry, "dim_intrinsic", NULL); 03735 03736 ir_idx = OPND_IDX((*result_opnd)); 03737 list_idx1 = IR_IDX_R(ir_idx); 03738 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 03739 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 03740 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 03741 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 03742 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 03743 03744 conform_check(0, 03745 ir_idx, 03746 res_exp_desc, 03747 spec_idx, 03748 FALSE); 03749 03750 IR_TYPE_IDX(ir_idx) = type_idx; 03751 IR_RANK(ir_idx) = res_exp_desc->rank; 03752 res_exp_desc->type_idx = type_idx; 03753 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 03754 03755 if (arg_info_list[info_idx1].ed.linear_type != 03756 arg_info_list[info_idx2].ed.linear_type) { 03757 PRINTMSG(IR_LINE_NUM(ir_idx), 774, Error, 03758 IR_COL_NUM(ir_idx)); 03759 } 03760 03761 # if 0 03762 03763 if (arg_info_list[info_idx1].ed.type == Integer && 03764 IL_FLD(list_idx1) == CN_Tbl_Idx && 03765 IL_FLD(list_idx2) == CN_Tbl_Idx && 03766 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 03767 arg_info_list[info_idx1].ed.type_idx, 03768 (char *)&CN_CONST(IL_IDX(list_idx2)), 03769 arg_info_list[info_idx2].ed.type_idx, 03770 folded_const, 03771 &type_idx, 03772 IR_LINE_NUM(ir_idx), 03773 IR_COL_NUM(ir_idx), 03774 2, 03775 Dim_Opr)) { 03776 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 03777 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 03778 FALSE, 03779 folded_const); 03780 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 03781 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 03782 res_exp_desc->constant = TRUE; 03783 res_exp_desc->foldable = TRUE; 03784 } 03785 else { 03786 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 03787 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx1), 03788 &line, 03789 &column); 03790 03791 gt_idx = gen_ir(IL_FLD(list_idx1), IL_IDX(list_idx1), 03792 Gt_Opr, LOGICAL_DEFAULT_TYPE, line, column, 03793 IL_FLD(list_idx2), IL_IDX(list_idx2)); 03794 03795 minus_idx = gen_ir(IL_FLD(list_idx1), IL_IDX(list_idx1), 03796 Minus_Opr, arg_info_list[info_idx1].ed.type_idx, 03797 line, column, 03798 IL_FLD(list_idx2), IL_IDX(list_idx2)); 03799 03800 zero_idx = (TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx) == 03801 CG_INTEGER_DEFAULT_TYPE) ? CN_INTEGER_ZERO_IDX : 03802 C_INT_TO_CN(arg_info_list[info_idx1].ed.type_idx, 0); 03803 03804 NTR_IR_LIST_TBL(arg1); 03805 IL_ARG_DESC_VARIANT(arg1) = TRUE; 03806 NTR_IR_LIST_TBL(arg2); 03807 IL_ARG_DESC_VARIANT(arg2) = TRUE; 03808 NTR_IR_LIST_TBL(arg3); 03809 IL_ARG_DESC_VARIANT(arg3) = TRUE; 03810 03811 /* link list together */ 03812 IL_NEXT_LIST_IDX(arg1) = arg2; 03813 IL_NEXT_LIST_IDX(arg2) = arg3; 03814 03815 IL_IDX(arg1) = minus_idx; 03816 IL_FLD(arg1) = IR_Tbl_Idx; 03817 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 03818 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 03819 IL_IDX(arg2) = zero_idx; 03820 IL_FLD(arg2) = CN_Tbl_Idx; 03821 IL_LINE_NUM(arg2) = IR_LINE_NUM(ir_idx); 03822 IL_COL_NUM(arg2) = IR_COL_NUM(ir_idx); 03823 IL_IDX(arg3) = gt_idx; 03824 IL_FLD(arg3) = IR_Tbl_Idx; 03825 IL_LINE_NUM(arg3) = IR_LINE_NUM(ir_idx); 03826 IL_COL_NUM(arg3) = IR_COL_NUM(ir_idx); 03827 03828 select_idx = gen_ir(IL_Tbl_Idx, arg1, 03829 Cvmgt_Opr, 03830 arg_info_list[info_idx1].ed.type_idx, 03831 IR_LINE_NUM(ir_idx), 03832 IR_COL_NUM(ir_idx), 03833 NO_Tbl_Idx, NULL_IDX); 03834 03835 /* set this flag so this opr is pulled off io lists */ 03836 io_item_must_flatten = TRUE; 03837 03838 IR_LIST_CNT_L(select_idx) = 3; 03839 03840 IR_OPR(ir_idx) = Cvrt_Opr; 03841 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 03842 IR_IDX_L(ir_idx) = select_idx; 03843 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 03844 IR_OPND_R(ir_idx) = null_opnd; 03845 } 03846 03847 if (arg_info_list[info_idx1].ed.type != Integer) { 03848 /* must reset foldable and will_fold_later because there is no */ 03849 /* folder for this intrinsic in constructors. */ 03850 03851 res_exp_desc->foldable = FALSE; 03852 res_exp_desc->will_fold_later = FALSE; 03853 } 03854 } 03855 03856 # endif 03857 res_exp_desc->foldable = FALSE; 03858 res_exp_desc->will_fold_later = FALSE; 03859 03860 TRACE (Func_Exit, "dim_intrinsic", NULL); 03861 03862 } /* dim_intrinsic */ 03863 03864 03865 /******************************************************************************\ 03866 |* *| 03867 |* Description: *| 03868 |* Function MAX(A1, A2, ... A63) intrinsic. *| 03869 |* Function MIN(A1, A2, ... A63) intrinsic. *| 03870 |* *| 03871 |* Input parameters: *| 03872 |* NONE *| 03873 |* *| 03874 |* Output parameters: *| 03875 |* NONE *| 03876 |* *| 03877 |* Returns: *| 03878 |* NOTHING *| 03879 |* *| 03880 \******************************************************************************/ 03881 03882 void max_intrinsic(opnd_type *result_opnd, 03883 expr_arg_type *res_exp_desc, 03884 int *spec_idx) 03885 { 03886 int col = 0; 03887 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 03888 boolean fold_it; 03889 boolean casting_needed= FALSE; 03890 int info_idx1; 03891 int largest_linear_type; 03892 int ir_idx; 03893 int line = 0; 03894 int n_idx; 03895 operator_type opr; 03896 opnd_type opnd; 03897 int t_idx; 03898 int tmp_idx; 03899 int type_idx; 03900 03901 03902 TRACE (Func_Entry, "max_intrinsic", NULL); 03903 03904 ir_idx = OPND_IDX((*result_opnd)); 03905 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 03906 03907 conform_check(3, 03908 ir_idx, 03909 res_exp_desc, 03910 spec_idx, 03911 FALSE); 03912 03913 03914 t_idx = IR_IDX_R(ir_idx); 03915 n_idx = IL_NEXT_LIST_IDX(t_idx); 03916 03917 largest_linear_type = arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.linear_type; 03918 03919 fold_it = (IL_FLD(t_idx) == CN_Tbl_Idx); 03920 03921 while ((n_idx != NULL_IDX) && (IL_IDX(n_idx) != NULL_IDX)) { 03922 if (arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.type != 03923 arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.type) { 03924 PRINTMSG(IR_LINE_NUM(ir_idx), 774, Error, 03925 IR_COL_NUM(ir_idx)); 03926 fold_it = FALSE; 03927 break; 03928 } 03929 03930 if ((opt_flags.set_fastint_option || 03931 opt_flags.set_allfastint_option) && 03932 (arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.type == Integer)) { 03933 if (opt_flags.set_allfastint_option || 03934 (TYP_DESC(arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.type_idx) == 03935 Default_Typed)) { 03936 casting_needed = TRUE; 03937 } 03938 03939 if (opt_flags.set_allfastint_option || 03940 (TYP_DESC(arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.type_idx) == 03941 Default_Typed)) { 03942 casting_needed = TRUE; 03943 } 03944 } 03945 03946 if (arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.linear_type != 03947 arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.linear_type) { 03948 PRINTMSG(arg_info_list[IL_ARG_DESC_IDX(n_idx)].line, 1323, Ansi, 03949 arg_info_list[IL_ARG_DESC_IDX(n_idx)].col); 03950 03951 casting_needed = TRUE; 03952 if (largest_linear_type < 03953 arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.linear_type) { 03954 largest_linear_type = 03955 arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.linear_type; 03956 } 03957 } 03958 03959 fold_it = fold_it && (IL_FLD(n_idx) == CN_Tbl_Idx); 03960 03961 t_idx = n_idx; 03962 n_idx = IL_NEXT_LIST_IDX(n_idx); 03963 } 03964 03965 03966 if (casting_needed) { 03967 t_idx = IR_IDX_R(ir_idx); 03968 03969 while ((t_idx != NULL_IDX) && (IL_IDX(t_idx) != NULL_IDX)) { 03970 COPY_OPND(opnd, IL_OPND(t_idx)); 03971 cast_to_type_idx(&opnd, 03972 &arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed, 03973 largest_linear_type); 03974 COPY_OPND(IL_OPND(t_idx), opnd); 03975 03976 t_idx = IL_NEXT_LIST_IDX(t_idx); 03977 } 03978 } 03979 03980 if ((ATP_INTRIN_ENUM(*spec_idx) == Amax0_Intrinsic) || 03981 (ATP_INTRIN_ENUM(*spec_idx) == Amin0_Intrinsic)) { 03982 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = REAL_DEFAULT_TYPE; 03983 } 03984 else if ((ATP_INTRIN_ENUM(*spec_idx) == Max1_Intrinsic) || 03985 (ATP_INTRIN_ENUM(*spec_idx) == Min1_Intrinsic)) { 03986 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 03987 } 03988 else { 03989 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = largest_linear_type; 03990 } 03991 03992 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 03993 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 03994 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 03995 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 03996 IR_RANK(ir_idx) = res_exp_desc->rank; 03997 type_idx = res_exp_desc->type_idx; 03998 03999 if (ATP_INTRIN_ENUM(*spec_idx) == Max_Intrinsic || 04000 ATP_INTRIN_ENUM(*spec_idx) == Amax0_Intrinsic || 04001 ATP_INTRIN_ENUM(*spec_idx) == Amax1_Intrinsic || 04002 ATP_INTRIN_ENUM(*spec_idx) == Dmax1_Intrinsic || 04003 ATP_INTRIN_ENUM(*spec_idx) == Max0_Intrinsic || 04004 ATP_INTRIN_ENUM(*spec_idx) == Max1_Intrinsic) { 04005 IR_OPR(ir_idx) = Lt_Opr; 04006 opr = Max_Opr; 04007 } 04008 else { 04009 IR_OPR(ir_idx) = Gt_Opr; 04010 opr = Min_Opr; 04011 } 04012 04013 04014 if (fold_it && 04015 res_exp_desc->type == Integer && 04016 arg_info_list[info_idx1].ed.type == Integer) { 04017 t_idx = IR_IDX_R(ir_idx); 04018 n_idx = IL_NEXT_LIST_IDX(t_idx); 04019 04020 while ((n_idx != NULL_IDX) && (IL_IDX(n_idx) != NULL_IDX)) { 04021 fold_it = folder_driver((char *)&CN_CONST(IL_IDX(t_idx)), 04022 arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.type_idx, 04023 (char *)&CN_CONST(IL_IDX(n_idx)), 04024 arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.type_idx, 04025 folded_const, 04026 &type_idx, 04027 line, 04028 col, 04029 2, 04030 IR_OPR(ir_idx)); 04031 04032 if (THIS_IS_TRUE(folded_const, type_idx)) { 04033 t_idx = n_idx; 04034 } 04035 04036 04037 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 04038 OPND_IDX((*result_opnd)) = ntr_const_tbl(res_exp_desc->type_idx, 04039 FALSE, 04040 &CN_CONST(IL_IDX(t_idx))); 04041 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 04042 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 04043 res_exp_desc->constant = TRUE; 04044 res_exp_desc->foldable = TRUE; 04045 04046 n_idx = IL_NEXT_LIST_IDX(n_idx); 04047 } 04048 } 04049 else { 04050 tmp_idx = gen_ir(IR_FLD_R(ir_idx), IR_IDX_R(ir_idx), 04051 opr, IR_TYPE_IDX(ir_idx), IR_LINE_NUM(ir_idx), 04052 IR_COL_NUM(ir_idx), 04053 NO_Tbl_Idx, NULL_IDX); 04054 04055 IR_OPR(ir_idx) = Cvrt_Opr; 04056 IR_IDX_L(ir_idx) = tmp_idx; 04057 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 04058 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 04059 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 04060 IR_OPND_R(ir_idx) = null_opnd; 04061 04062 if (res_exp_desc->type != Integer) { 04063 /* must reset foldable and will_fold_later because there is no */ 04064 /* folder for this intrinsic in constructors. */ 04065 04066 res_exp_desc->foldable = FALSE; 04067 res_exp_desc->will_fold_later = FALSE; 04068 } 04069 } 04070 04071 04072 res_exp_desc->foldable = FALSE; 04073 res_exp_desc->will_fold_later = FALSE; 04074 04075 TRACE (Func_Exit, "max_intrinsic", NULL); 04076 04077 } /* max_intrinsic */ 04078 04079 04080 04081 /******************************************************************************\ 04082 |* *| 04083 |* Description: *| 04084 |* Function RANGET(I) intrinsic. *| 04085 |* Function RANSET(I) intrinsic. *| 04086 |* *| 04087 |* Input parameters: *| 04088 |* NONE *| 04089 |* *| 04090 |* Output parameters: *| 04091 |* NONE *| 04092 |* *| 04093 |* Returns: *| 04094 |* NOTHING *| 04095 |* *| 04096 \******************************************************************************/ 04097 04098 void ranget_intrinsic(opnd_type *result_opnd, 04099 expr_arg_type *res_exp_desc, 04100 int *spec_idx) 04101 { 04102 int info_idx1; 04103 int ir_idx; 04104 int list_idx1; 04105 int tmp_attr; 04106 int unused1 = NULL_IDX; 04107 int unused2 = NULL_IDX; 04108 opnd_type old_opnd; 04109 opnd_type base_opnd; 04110 04111 04112 TRACE (Func_Entry, "ranget_intrinsic", NULL); 04113 04114 ir_idx = OPND_IDX((*result_opnd)); 04115 list_idx1 = IR_IDX_R(ir_idx); 04116 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 04117 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 04118 04119 # if defined(GENERATE_WHIRL) 04120 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 04121 # endif 04122 04123 conform_check(0, 04124 ir_idx, 04125 res_exp_desc, 04126 spec_idx, 04127 FALSE); 04128 04129 04130 if (IL_IDX(list_idx1) == NULL_IDX) { /* argument not present */ 04131 /* insert one */ 04132 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04133 IR_RANK(ir_idx) = res_exp_desc->rank; 04134 04135 tmp_attr = gen_compiler_tmp(IR_LINE_NUM(ir_idx), 04136 IR_COL_NUM(ir_idx), 04137 Priv, TRUE); 04138 ATD_STOR_BLK_IDX(tmp_attr) = SCP_SB_STACK_IDX(curr_scp_idx); 04139 ATD_TYPE_IDX(tmp_attr) = INTEGER_DEFAULT_TYPE; 04140 # if defined(GENERATE_WHIRL) 04141 ATD_TYPE_IDX(tmp_attr) = Integer_8; 04142 # endif 04143 AT_SEMANTICS_DONE(tmp_attr) = TRUE; 04144 04145 IL_FLD(list_idx1) = AT_Tbl_Idx; 04146 IL_IDX(list_idx1) = tmp_attr; 04147 IL_LINE_NUM(list_idx1) = IR_LINE_NUM(ir_idx); 04148 IL_COL_NUM(list_idx1) = IR_COL_NUM(ir_idx); 04149 } 04150 else { 04151 COPY_OPND(old_opnd, IL_OPND(list_idx1)); 04152 04153 if (! arg_info_list[info_idx1].ed.reference && 04154 ! arg_info_list[info_idx1].ed.tmp_reference) { 04155 04156 tmp_attr = create_tmp_asg(&old_opnd, 04157 (expr_arg_type *)&(arg_info_list[info_idx1].ed), 04158 &base_opnd, 04159 Intent_In, 04160 TRUE, 04161 FALSE); 04162 04163 COPY_OPND(old_opnd, base_opnd); 04164 } 04165 04166 if (arg_info_list[info_idx1].ed.rank > 0) { 04167 make_base_subtree(&old_opnd, &base_opnd, &unused1, &unused2); 04168 COPY_OPND(IL_OPND(list_idx1), base_opnd); 04169 } 04170 else { 04171 COPY_OPND(IL_OPND(list_idx1), old_opnd); 04172 } 04173 } 04174 04175 # if defined(GENERATE_WHIRL) 04176 COPY_OPND(old_opnd, IL_OPND(list_idx1)); 04177 cast_to_type_idx(&old_opnd, &arg_info_list[info_idx1].ed, Integer_8); 04178 COPY_OPND(IL_OPND(list_idx1), old_opnd); 04179 # else 04180 COPY_OPND(old_opnd, IL_OPND(list_idx1)); 04181 cast_to_cg_default(&old_opnd, &(arg_info_list[info_idx1].ed)); 04182 COPY_OPND(IL_OPND(list_idx1), old_opnd); 04183 # endif 04184 04185 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04186 IR_RANK(ir_idx) = res_exp_desc->rank; 04187 if (ATP_INTRIN_ENUM(*spec_idx) == Ranget_Intrinsic) { 04188 /* IR_OPR(ir_idx) = Ranget_Opr; */ 04189 } 04190 else { 04191 /* IR_OPR(ir_idx) = Ranset_Opr; */ 04192 } 04193 #if 0 04194 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04195 IR_OPND_R(ir_idx) = null_opnd; 04196 #endif 04197 04198 /* must reset foldable and will_fold_later because there is no */ 04199 /* folder for this intrinsic in constructors. */ 04200 04201 res_exp_desc->foldable = FALSE; 04202 res_exp_desc->will_fold_later = FALSE; 04203 04204 04205 TRACE (Func_Exit, "ranget_intrinsic", NULL); 04206 04207 } /* ranget_intrinsic */ 04208 04209 04210 /******************************************************************************\ 04211 |* *| 04212 |* Description: *| 04213 |* Function RANF() intrinsic. *| 04214 |* *| 04215 |* Input parameters: *| 04216 |* NONE *| 04217 |* *| 04218 |* Output parameters: *| 04219 |* NONE *| 04220 |* *| 04221 |* Returns: *| 04222 |* NOTHING *| 04223 |* *| 04224 \******************************************************************************/ 04225 04226 void ranf_intrinsic(opnd_type *result_opnd, 04227 expr_arg_type *res_exp_desc, 04228 int *spec_idx) 04229 { 04230 int ir_idx; 04231 04232 04233 TRACE (Func_Entry, "ranf_intrinsic", NULL); 04234 04235 ir_idx = OPND_IDX((*result_opnd)); 04236 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_8; 04237 04238 conform_check(0, 04239 ir_idx, 04240 res_exp_desc, 04241 spec_idx, 04242 FALSE); 04243 04244 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04245 IR_RANK(ir_idx) = res_exp_desc->rank; 04246 04247 # if 0 04248 04249 IR_OPR(ir_idx) = Ranf_Opr; 04250 04251 IR_OPND_L(ir_idx) = null_opnd; 04252 IR_OPND_R(ir_idx) = null_opnd; 04253 04254 /* must reset foldable and will_fold_later because there is no */ 04255 /* folder for this intrinsic in constructors. */ 04256 04257 # endif 04258 04259 res_exp_desc->foldable = FALSE; 04260 res_exp_desc->will_fold_later = FALSE; 04261 /* tree_has_ranf = TRUE; */ 04262 04263 04264 TRACE (Func_Exit, "ranf_intrinsic", NULL); 04265 04266 } /* ranf_intrinsic */ 04267 04268 04269 /******************************************************************************\ 04270 |* *| 04271 |* Description: *| 04272 |* Function REAL(A, KIND) intrinsic. *| 04273 |* Function FLOATI(A) intrinsic. *| 04274 |* Function FLOATJ(A) intrinsic. *| 04275 |* Function FLOATK(A) intrinsic. *| 04276 |* Function QFLOAT(A) intrinsic. *| 04277 |* Function QFLOATI(A) intrinsic. *| 04278 |* Function QFLOATJ(A) intrinsic. *| 04279 |* Function QFLOATK(A) intrinsic. *| 04280 |* Function QREAL(A) intrinsic. *| 04281 |* Function QEXT(A) intrinsic. *| 04282 |* Function SNGL(A) intrinsic. *| 04283 |* Function SNGLQ(A) intrinsic. *| 04284 |* Function DBLE(A) intrinsic. *| 04285 |* Function DBLEQ(A) intrinsic. *| 04286 |* Function DFLOAT(A) intrinsic. *| 04287 |* Function DFLOATI(A) intrinsic. *| 04288 |* Function DFLOATJ(A) intrinsic. *| 04289 |* Function DFLOATK(A) intrinsic. *| 04290 |* Function DREAL(A) intrinsic. *| 04291 |* *| 04292 |* Input parameters: *| 04293 |* NONE *| 04294 |* *| 04295 |* Output parameters: *| 04296 |* NONE *| 04297 |* *| 04298 |* Returns: *| 04299 |* NOTHING *| 04300 |* *| 04301 \******************************************************************************/ 04302 04303 void real_intrinsic(opnd_type *result_opnd, 04304 expr_arg_type *res_exp_desc, 04305 int *spec_idx) 04306 { 04307 int list_idx1; 04308 int list_idx2; 04309 int ir_idx; 04310 int info_idx1; 04311 int info_idx2; 04312 04313 04314 TRACE (Func_Entry, "real_intrinsic", NULL); 04315 04316 ir_idx = OPND_IDX((*result_opnd)); 04317 list_idx1 = IR_IDX_R(ir_idx); 04318 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 04319 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 04320 04321 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 04322 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 04323 kind_to_linear_type(&((IL_OPND(list_idx2))), 04324 ATP_RSLT_IDX(*spec_idx), 04325 arg_info_list[info_idx2].ed.kind0seen, 04326 arg_info_list[info_idx2].ed.kind0E0seen, 04327 arg_info_list[info_idx2].ed.kind0D0seen, 04328 ! arg_info_list[info_idx2].ed.kindnotconst); 04329 } 04330 else { 04331 switch (arg_info_list[info_idx1].ed.type) { 04332 case Integer: 04333 case Typeless: 04334 case Real: 04335 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = REAL_DEFAULT_TYPE; 04336 break; 04337 04338 case Complex: 04339 switch (arg_info_list[info_idx1].ed.linear_type) { 04340 case Complex_4: 04341 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_4; 04342 break; 04343 case Complex_8: 04344 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_8; 04345 break; 04346 case Complex_16: 04347 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_16; 04348 break; 04349 } 04350 break; 04351 } 04352 } 04353 04354 if (ATP_INTRIN_ENUM(*spec_idx) == Dfloat_Intrinsic || 04355 ATP_INTRIN_ENUM(*spec_idx) == Dreal_Intrinsic || 04356 ATP_INTRIN_ENUM(*spec_idx) == Dble_Intrinsic || 04357 ATP_INTRIN_ENUM(*spec_idx) == Dbleq_Intrinsic || 04358 ATP_INTRIN_ENUM(*spec_idx) == Dfloati_Intrinsic || 04359 ATP_INTRIN_ENUM(*spec_idx) == Dfloatj_Intrinsic || 04360 ATP_INTRIN_ENUM(*spec_idx) == Dfloatk_Intrinsic) { 04361 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = DOUBLE_DEFAULT_TYPE; 04362 } 04363 04364 if (ATP_INTRIN_ENUM(*spec_idx) == Qfloat_Intrinsic || 04365 ATP_INTRIN_ENUM(*spec_idx) == Qext_Intrinsic || 04366 ATP_INTRIN_ENUM(*spec_idx) == Qreal_Intrinsic || 04367 ATP_INTRIN_ENUM(*spec_idx) == Qfloati_Intrinsic || 04368 ATP_INTRIN_ENUM(*spec_idx) == Qfloatj_Intrinsic || 04369 ATP_INTRIN_ENUM(*spec_idx) == Qfloatk_Intrinsic) { 04370 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_16; 04371 } 04372 04373 conform_check(0, 04374 ir_idx, 04375 res_exp_desc, 04376 spec_idx, 04377 FALSE); 04378 04379 04380 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04381 IR_RANK(ir_idx) = res_exp_desc->rank; 04382 04383 # if 0 04384 04385 IR_OPR(ir_idx) = Real_Opr; 04386 04387 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04388 IR_OPND_R(ir_idx) = null_opnd; 04389 IR_LIST_CNT_L(ir_idx) = 1; 04390 IL_NEXT_LIST_IDX(list_idx1) = NULL_IDX; 04391 04392 /* must reset foldable and will_fold_later because there is no */ 04393 /* folder for this intrinsic in constructors. */ 04394 04395 # endif 04396 04397 res_exp_desc->foldable = FALSE; 04398 res_exp_desc->will_fold_later = FALSE; 04399 04400 TRACE (Func_Exit, "real_intrinsic", NULL); 04401 04402 } /* real_intrinsic */ 04403 04404 04405 /******************************************************************************\ 04406 |* *| 04407 |* Description: *| 04408 |* Function MASK(I) intrinsic. *| 04409 |* *| 04410 |* Input parameters: *| 04411 |* NONE *| 04412 |* *| 04413 |* Output parameters: *| 04414 |* NONE *| 04415 |* *| 04416 |* Returns: *| 04417 |* NOTHING *| 04418 |* *| 04419 \******************************************************************************/ 04420 04421 void mask_intrinsic(opnd_type *result_opnd, 04422 expr_arg_type *res_exp_desc, 04423 int *spec_idx) 04424 { 04425 int info_idx1; 04426 int ir_idx; 04427 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 04428 int list_idx1; 04429 int type_idx; 04430 04431 04432 TRACE (Func_Entry, "mask_intrinsic", NULL); 04433 04434 ir_idx = OPND_IDX((*result_opnd)); 04435 04436 04437 list_idx1 = IR_IDX_R(ir_idx); 04438 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 04439 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 04440 # if defined(GENERATE_WHIRL) 04441 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 04442 if (arg_info_list[info_idx1].ed.type == Integer) { 04443 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 04444 arg_info_list[info_idx1].ed.linear_type; 04445 } 04446 # endif 04447 04448 IR_RANK(ir_idx) = res_exp_desc->rank; 04449 04450 # ifdef _TARGET32 04451 if (arg_info_list[info_idx1].ed.linear_type == Integer_8) { 04452 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_8; 04453 # if defined(GENERATE_WHIRL) 04454 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 04455 # endif 04456 } 04457 # endif 04458 04459 # ifdef _TARGET_OS_MAX 04460 if (arg_info_list[info_idx1].ed.linear_type == Integer_1 || 04461 arg_info_list[info_idx1].ed.linear_type == Integer_2 || 04462 arg_info_list[info_idx1].ed.linear_type == Integer_4) { 04463 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_4; 04464 } 04465 # endif 04466 04467 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04468 04469 04470 conform_check(0, 04471 ir_idx, 04472 res_exp_desc, 04473 spec_idx, 04474 FALSE); 04475 04476 04477 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04478 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 04479 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 04480 arg_info_list[info_idx1].ed.type_idx, 04481 NULL, 04482 NULL_IDX, 04483 folded_const, 04484 &type_idx, 04485 IR_LINE_NUM(ir_idx), 04486 IR_COL_NUM(ir_idx), 04487 1, 04488 Mask_Opr)) { 04489 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 04490 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 04491 FALSE, 04492 folded_const); 04493 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 04494 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 04495 res_exp_desc->constant = TRUE; 04496 res_exp_desc->foldable = TRUE; 04497 } 04498 else { 04499 IR_OPR(ir_idx) = Mask_Opr; 04500 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04501 IR_OPND_R(ir_idx) = null_opnd; 04502 } 04503 04504 TRACE (Func_Exit, "mask_intrinsic", NULL); 04505 04506 } /* mask_intrinsic */ 04507 04508 04509 /******************************************************************************\ 04510 |* *| 04511 |* Description: *| 04512 |* Function CONJG(Z) intrinsic. *| 04513 |* *| 04514 |* Input parameters: *| 04515 |* NONE *| 04516 |* *| 04517 |* Output parameters: *| 04518 |* NONE *| 04519 |* *| 04520 |* Returns: *| 04521 |* NOTHING *| 04522 |* *| 04523 \******************************************************************************/ 04524 04525 void conjg_intrinsic(opnd_type *result_opnd, 04526 expr_arg_type *res_exp_desc, 04527 int *spec_idx) 04528 { 04529 int ir_idx; 04530 int list_idx1; 04531 int info_idx1; 04532 04533 04534 TRACE (Func_Entry, "conjg_intrinsic", NULL); 04535 04536 ir_idx = OPND_IDX((*result_opnd)); 04537 list_idx1 = IR_IDX_R(ir_idx); 04538 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 04539 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 04540 04541 conform_check(0, 04542 ir_idx, 04543 res_exp_desc, 04544 spec_idx, 04545 FALSE); 04546 04547 04548 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04549 IR_RANK(ir_idx) = res_exp_desc->rank; 04550 04551 /* # if 0 */ 04552 04553 IR_OPR(ir_idx) = Conjg_Opr; 04554 04555 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04556 IR_OPND_R(ir_idx) = null_opnd; 04557 04558 /* must reset foldable and will_fold_later because there is no */ 04559 /* folder for this intrinsic in constructors. */ 04560 04561 /* # endif */ 04562 04563 res_exp_desc->foldable = FALSE; 04564 res_exp_desc->will_fold_later = FALSE; 04565 04566 TRACE (Func_Exit, "conjg_intrinsic", NULL); 04567 04568 } /* conjg_intrinsic */ 04569 04570 04571 /******************************************************************************\ 04572 |* *| 04573 |* Description: *| 04574 |* Function DPROD(X, Y) intrinsic. *| 04575 |* *| 04576 |* Input parameters: *| 04577 |* NONE *| 04578 |* *| 04579 |* Output parameters: *| 04580 |* NONE *| 04581 |* *| 04582 |* Returns: *| 04583 |* NOTHING *| 04584 |* *| 04585 \******************************************************************************/ 04586 04587 void dprod_intrinsic(opnd_type *result_opnd, 04588 expr_arg_type *res_exp_desc, 04589 int *spec_idx) 04590 { 04591 int ir_idx; 04592 int list_idx1; 04593 int list_idx2; 04594 int info_idx1; 04595 int info_idx2; 04596 opnd_type opnd; 04597 04598 04599 TRACE (Func_Entry, "dprod_intrinsic", NULL); 04600 04601 ir_idx = OPND_IDX((*result_opnd)); 04602 list_idx1 = IR_IDX_R(ir_idx); 04603 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 04604 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 04605 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 04606 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = DOUBLE_DEFAULT_TYPE; 04607 04608 if (ATP_INTRIN_ENUM(*spec_idx) == Qprod_Intrinsic) { 04609 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_16; 04610 } 04611 04612 if ((TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx) != REAL_DEFAULT_TYPE) || 04613 (TYP_LINEAR(arg_info_list[info_idx2].ed.type_idx) != REAL_DEFAULT_TYPE)) { 04614 PRINTMSG(IR_LINE_NUM(ir_idx), 361, Error, 04615 IR_COL_NUM(ir_idx)); 04616 } 04617 04618 conform_check(0, 04619 ir_idx, 04620 res_exp_desc, 04621 spec_idx, 04622 FALSE); 04623 04624 04625 COPY_OPND(opnd, IL_OPND(list_idx1)); 04626 cast_to_type_idx(&opnd, 04627 &arg_info_list[info_idx1].ed, 04628 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 04629 04630 COPY_OPND(IL_OPND(list_idx1), opnd); 04631 04632 COPY_OPND(opnd, IL_OPND(list_idx2)); 04633 cast_to_type_idx(&opnd, 04634 &arg_info_list[info_idx2].ed, 04635 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 04636 COPY_OPND(IL_OPND(list_idx2), opnd); 04637 04638 04639 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04640 IR_RANK(ir_idx) = res_exp_desc->rank; 04641 04642 # if 0 04643 04644 IR_OPR(ir_idx) = Dprod_Opr; 04645 04646 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04647 IR_OPND_R(ir_idx) = null_opnd; 04648 04649 /* must reset foldable and will_fold_later because there is no */ 04650 /* folder for this intrinsic in constructors. */ 04651 04652 # endif 04653 04654 res_exp_desc->foldable = FALSE; 04655 res_exp_desc->will_fold_later = FALSE; 04656 04657 TRACE (Func_Exit, "dprod_intrinsic", NULL); 04658 04659 } /* dprod_intrinsic */ 04660 04661 04662 /******************************************************************************\ 04663 |* *| 04664 |* Description: *| 04665 |* Function LENGTH(I) intrinsic. *| 04666 |* *| 04667 |* Input parameters: *| 04668 |* NONE *| 04669 |* *| 04670 |* Output parameters: *| 04671 |* NONE *| 04672 |* *| 04673 |* Returns: *| 04674 |* NOTHING *| 04675 |* *| 04676 \******************************************************************************/ 04677 04678 void length_intrinsic(opnd_type *result_opnd, 04679 expr_arg_type *res_exp_desc, 04680 int *spec_idx) 04681 { 04682 int ir_idx; 04683 04684 # if defined(GENERATE_WHIRL) 04685 opnd_type opnd; 04686 # endif 04687 04688 04689 TRACE (Func_Entry, "length_intrinsic", NULL); 04690 04691 ir_idx = OPND_IDX((*result_opnd)); 04692 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 04693 04694 conform_check(0, 04695 ir_idx, 04696 res_exp_desc, 04697 spec_idx, 04698 FALSE); 04699 04700 # if defined(GENERATE_WHIRL) 04701 04702 04703 #if 0 04704 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 04705 final_arg_work(&opnd, IR_IDX_L(ir_idx), IR_LIST_CNT_R(ir_idx), NULL); 04706 COPY_OPND(IR_OPND_R(ir_idx), opnd); 04707 #endif 04708 04709 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04710 IR_RANK(ir_idx) = res_exp_desc->rank; 04711 #if 0 04712 IR_OPR(ir_idx) = Length_Opr; 04713 04714 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04715 IR_OPND_R(ir_idx) = null_opnd; 04716 #endif 04717 # else 04718 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04719 IR_RANK(ir_idx) = res_exp_desc->rank; 04720 #if 0 04721 IR_OPR(ir_idx) = Length_Opr; 04722 04723 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04724 IR_OPND_R(ir_idx) = null_opnd; 04725 #endif 04726 # endif 04727 04728 /* must reset foldable and will_fold_later because there is no */ 04729 /* folder for this intrinsic in constructors. */ 04730 04731 res_exp_desc->foldable = FALSE; 04732 res_exp_desc->will_fold_later = FALSE; 04733 04734 TRACE (Func_Exit, "length_intrinsic", NULL); 04735 04736 } /* length_intrinsic */ 04737 04738 04739 /******************************************************************************\ 04740 |* *| 04741 |* Description: *| 04742 |* Function GETPOS(I) intrinsic. *| 04743 |* *| 04744 |* Input parameters: *| 04745 |* NONE *| 04746 |* *| 04747 |* Output parameters: *| 04748 |* NONE *| 04749 |* *| 04750 |* Returns: *| 04751 |* NOTHING *| 04752 |* *| 04753 \******************************************************************************/ 04754 04755 void getpos_intrinsic(opnd_type *result_opnd, 04756 expr_arg_type *res_exp_desc, 04757 int *spec_idx) 04758 { 04759 int ir_idx; 04760 04761 04762 TRACE (Func_Entry, "getpos_intrinsic", NULL); 04763 04764 ir_idx = OPND_IDX((*result_opnd)); 04765 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 04766 04767 conform_check(0, 04768 ir_idx, 04769 res_exp_desc, 04770 spec_idx, 04771 FALSE); 04772 04773 04774 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04775 IR_RANK(ir_idx) = res_exp_desc->rank; 04776 04777 # if 0 04778 04779 IR_OPR(ir_idx) = Getpos_Opr; 04780 04781 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04782 IR_OPND_R(ir_idx) = null_opnd; 04783 04784 /* must reset foldable and will_fold_later because there is no */ 04785 /* folder for this intrinsic in constructors. */ 04786 04787 # endif 04788 04789 res_exp_desc->foldable = FALSE; 04790 res_exp_desc->will_fold_later = FALSE; 04791 04792 TRACE (Func_Exit, "getpos_intrinsic", NULL); 04793 04794 } /* getpos_intrinsic */ 04795 04796 04797 /******************************************************************************\ 04798 |* *| 04799 |* Description: *| 04800 |* Function UNIT(I) intrinsic. *| 04801 |* *| 04802 |* Input parameters: *| 04803 |* NONE *| 04804 |* *| 04805 |* Output parameters: *| 04806 |* NONE *| 04807 |* *| 04808 |* Returns: *| 04809 |* NOTHING *| 04810 |* *| 04811 \******************************************************************************/ 04812 04813 void unit_intrinsic(opnd_type *result_opnd, 04814 expr_arg_type *res_exp_desc, 04815 int *spec_idx) 04816 { 04817 int ir_idx; 04818 04819 # if defined(GENERATE_WHIRL) 04820 opnd_type opnd; 04821 # endif 04822 04823 04824 TRACE (Func_Entry, "unit_intrinsic", NULL); 04825 04826 ir_idx = OPND_IDX((*result_opnd)); 04827 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = REAL_DEFAULT_TYPE; 04828 04829 conform_check(0, 04830 ir_idx, 04831 res_exp_desc, 04832 spec_idx, 04833 FALSE); 04834 04835 # if defined(GENERATE_WHIRL) 04836 COPY_OPND(opnd, IR_OPND_R(ir_idx)); 04837 final_arg_work(&opnd, IR_IDX_L(ir_idx), IR_LIST_CNT_R(ir_idx), NULL); 04838 COPY_OPND(IR_OPND_R(ir_idx), opnd); 04839 04840 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04841 IR_RANK(ir_idx) = res_exp_desc->rank; 04842 #if 0 04843 IR_OPR(ir_idx) = Unit_Opr; 04844 04845 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04846 IR_OPND_R(ir_idx) = null_opnd; 04847 #endif 04848 # else 04849 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04850 IR_RANK(ir_idx) = res_exp_desc->rank; 04851 #if 0 04852 IR_OPR(ir_idx) = Unit_Opr; 04853 04854 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04855 IR_OPND_R(ir_idx) = null_opnd; 04856 #endif 04857 # endif 04858 04859 /* must reset foldable and will_fold_later because there is no */ 04860 /* folder for this intrinsic in constructors. */ 04861 04862 res_exp_desc->foldable = FALSE; 04863 res_exp_desc->will_fold_later = FALSE; 04864 04865 TRACE (Func_Exit, "unit_intrinsic", NULL); 04866 04867 } /* unit_intrinsic */ 04868 04869 04870 /******************************************************************************\ 04871 |* *| 04872 |* Description: *| 04873 |* Function CMPLX(X, Y, KIND) intrinsic. *| 04874 |* *| 04875 |* Input parameters: *| 04876 |* NONE *| 04877 |* *| 04878 |* Output parameters: *| 04879 |* NONE *| 04880 |* *| 04881 |* Returns: *| 04882 |* NOTHING *| 04883 |* *| 04884 \******************************************************************************/ 04885 04886 void cmplx_intrinsic(opnd_type *result_opnd, 04887 expr_arg_type *res_exp_desc, 04888 int *spec_idx) 04889 { 04890 int column; 04891 int line; 04892 int list_idx1; 04893 int list_idx2; 04894 int list_idx3; 04895 int info_idx1; 04896 int info_idx2; 04897 int info_idx3; 04898 int ir_idx; 04899 int list_idx; 04900 operator_type opr; 04901 int type_idx; 04902 opnd_type opnd; 04903 04904 04905 TRACE (Func_Entry, "cmplx_intrinsic", NULL); 04906 04907 ir_idx = OPND_IDX((*result_opnd)); 04908 list_idx1 = IR_IDX_R(ir_idx); 04909 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 04910 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 04911 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 04912 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 04913 opr = Cmplx_Opr; 04914 04915 if ((list_idx3 != NULL_IDX) && (IL_IDX(list_idx3) != NULL_IDX)) { 04916 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 04917 kind_to_linear_type(&((IL_OPND(list_idx3))), 04918 ATP_RSLT_IDX(*spec_idx), 04919 arg_info_list[info_idx3].ed.kind0seen, 04920 arg_info_list[info_idx3].ed.kind0E0seen, 04921 arg_info_list[info_idx3].ed.kind0D0seen, 04922 ! arg_info_list[info_idx3].ed.kindnotconst); 04923 } 04924 else { 04925 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = COMPLEX_DEFAULT_TYPE; 04926 } 04927 04928 switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) { 04929 case Complex_4: 04930 type_idx = Real_4; 04931 break; 04932 04933 case Complex_8: 04934 type_idx = Real_8; 04935 break; 04936 04937 case Complex_16: 04938 type_idx = Real_16; 04939 break; 04940 } 04941 04942 if ((ATP_INTRIN_ENUM(*spec_idx) == Dcmplx_Intrinsic) && 04943 (on_off_flags.enable_double_precision)) { 04944 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = DOUBLE_COMPLEX_DEFAULT_TYPE; 04945 } 04946 04947 if (ATP_INTRIN_ENUM(*spec_idx) == Qcmplx_Intrinsic) { 04948 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Complex_16; 04949 } 04950 04951 conform_check(2, 04952 ir_idx, 04953 res_exp_desc, 04954 spec_idx, 04955 FALSE); 04956 04957 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 04958 IR_RANK(ir_idx) = res_exp_desc->rank; 04959 04960 04961 if (arg_info_list[info_idx1].ed.type == Integer) { 04962 COPY_OPND(opnd, IL_OPND(list_idx1)); 04963 cast_to_type_idx(&opnd, &arg_info_list[info_idx1].ed, type_idx); 04964 COPY_OPND(IL_OPND(list_idx1), opnd); 04965 } 04966 04967 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 04968 if (arg_info_list[info_idx2].ed.type == Integer) { 04969 COPY_OPND(opnd, IL_OPND(list_idx2)); 04970 cast_to_type_idx(&opnd, &arg_info_list[info_idx2].ed, type_idx); 04971 COPY_OPND(IL_OPND(list_idx2), opnd); 04972 } 04973 04974 if (arg_info_list[info_idx1].ed.type == Complex) { 04975 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx2), 04976 &line, 04977 &column); 04978 PRINTMSG(line, 738, Error, column); 04979 } 04980 } 04981 else { /* Y is not present */ 04982 04983 if (arg_info_list[info_idx1].ed.type == Complex) { /* X is complex */ 04984 opr = Cvrt_Opr; 04985 } 04986 else { /* X is not Complex */ 04987 IL_FLD(list_idx2) = CN_Tbl_Idx; 04988 IL_IDX(list_idx2) = cvrt_str_to_cn("0.0", 04989 REAL_DEFAULT_TYPE); 04990 IL_LINE_NUM(list_idx2) = IR_LINE_NUM(ir_idx); 04991 IL_COL_NUM(list_idx2) = IR_COL_NUM(ir_idx); 04992 } 04993 } 04994 04995 IR_OPR(ir_idx) = opr; 04996 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 04997 IR_OPND_R(ir_idx) = null_opnd; 04998 04999 if (opr == Cvrt_Opr) { 05000 IR_LIST_CNT_L(ir_idx) = 1; 05001 list_idx = IR_IDX_L(ir_idx); 05002 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 05003 } 05004 else { 05005 IR_LIST_CNT_L(ir_idx) = 2; 05006 list_idx = IR_IDX_L(ir_idx); 05007 list_idx = IL_NEXT_LIST_IDX(list_idx); 05008 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 05009 } 05010 05011 05012 /* must reset foldable and will_fold_later because there is no */ 05013 /* folder for this intrinsic in constructors. */ 05014 05015 res_exp_desc->foldable = FALSE; 05016 res_exp_desc->will_fold_later = FALSE; 05017 05018 TRACE (Func_Exit, "cmplx_intrinsic", NULL); 05019 05020 } /* cmplx_intrinsic */ 05021 05022 05023 /******************************************************************************\ 05024 |* *| 05025 |* Description: *| 05026 |* Function LEN(STRING) intrinsic. *| 05027 |* *| 05028 |* Input parameters: *| 05029 |* NONE *| 05030 |* *| 05031 |* Output parameters: *| 05032 |* NONE *| 05033 |* *| 05034 |* Returns: *| 05035 |* NOTHING *| 05036 |* *| 05037 \******************************************************************************/ 05038 05039 void len_intrinsic(opnd_type *result_opnd, 05040 expr_arg_type *res_exp_desc, 05041 int *spec_idx) 05042 { 05043 int unused_idx; 05044 int ir_idx; 05045 int line; 05046 int col; 05047 int keep; 05048 05049 TRACE (Func_Entry, "len_intrinsic", NULL); 05050 05051 ir_idx = OPND_IDX((*result_opnd)); 05052 keep = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) ; 05053 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 05054 05055 conform_check(0, 05056 ir_idx, 05057 res_exp_desc, 05058 spec_idx, 05059 TRUE); 05060 05061 05062 if (cmd_line_flags.runtime_substring && 05063 IR_OPR(IL_IDX(IR_IDX_R(ir_idx))) == Substring_Opr) { 05064 /* gen_runtime_substring(IL_IDX(IR_IDX_R(ir_idx))); */ 05065 } 05066 05067 /* res_exp_desc->rank = 0; */ 05068 05069 /* IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); */ 05070 IR_TYPE_IDX(ir_idx) = keep; 05071 /* IR_RANK(ir_idx) = res_exp_desc->rank; */ 05072 05073 #if 0 /* April */ 05074 05075 IR_OPR(ir_idx) = Clen_Opr; 05076 05077 unused_idx = find_base_attr(&IL_OPND(IR_IDX_R(ir_idx)), &line, &col); 05078 05079 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(IR_IDX_R(ir_idx))); 05080 IR_OPND_R(ir_idx) = null_opnd; 05081 05082 fold_clen_opr(result_opnd, res_exp_desc); 05083 05084 # endif 05085 05086 /* cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); */ 05087 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05088 res_exp_desc->linear_type = 05089 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 05090 05091 /* must reset will_fold_later because there is no */ 05092 /* folder for this intrinsic in constructors. */ 05093 05094 05095 res_exp_desc->will_fold_later = FALSE; 05096 res_exp_desc->foldable = FALSE; 05097 05098 05099 TRACE (Func_Exit, "len_intrinsic", NULL); 05100 05101 } /* len_intrinsic */ 05102 05103 05104 /******************************************************************************\ 05105 |* *| 05106 |* Description: *| 05107 |* Function ICHAR(C) intrinsic or IACHAR(C) intrinsic. *| 05108 |* *| 05109 |* Input parameters: *| 05110 |* NONE *| 05111 |* *| 05112 |* Output parameters: *| 05113 |* NONE *| 05114 |* *| 05115 |* Returns: *| 05116 |* NOTHING *| 05117 |* *| 05118 \******************************************************************************/ 05119 05120 void ichar_intrinsic(opnd_type *result_opnd, 05121 expr_arg_type *res_exp_desc, 05122 int *spec_idx) 05123 { 05124 int ir_idx; 05125 int info_idx1; 05126 int list_idx1; 05127 long_type cnst[MAX_WORDS_FOR_NUMERIC]; 05128 int type_idx; 05129 05130 05131 TRACE (Func_Entry, "ichar_intrinsic", NULL); 05132 05133 ir_idx = OPND_IDX((*result_opnd)); 05134 list_idx1 = IR_IDX_R(ir_idx); 05135 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 05136 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 05137 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05138 05139 conform_check(0, 05140 ir_idx, 05141 res_exp_desc, 05142 spec_idx, 05143 FALSE); 05144 05145 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05146 IR_RANK(ir_idx) = res_exp_desc->rank; 05147 05148 res_exp_desc->type_idx = type_idx; 05149 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 05150 05151 if ((OPND_FLD(arg_info_list[info_idx1].ed.char_len) == CN_Tbl_Idx) && 05152 (CN_INT_TO_C(OPND_IDX(arg_info_list[info_idx1].ed.char_len)) != 1)) { 05153 PRINTMSG(IR_LINE_NUM(ir_idx), 327, Ansi, 05154 IR_COL_NUM(ir_idx)); 05155 } 05156 05157 05158 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 05159 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 05160 arg_info_list[info_idx1].ed.type_idx, 05161 NULL, 05162 NULL_IDX, 05163 cnst, 05164 &type_idx, 05165 IR_LINE_NUM(ir_idx), 05166 IR_COL_NUM(ir_idx), 05167 1, 05168 Ichar_Opr)) { 05169 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 05170 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 05171 FALSE, 05172 cnst); 05173 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 05174 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 05175 res_exp_desc->constant = TRUE; 05176 res_exp_desc->foldable = TRUE; 05177 } 05178 else { 05179 IR_OPR(ir_idx) = Ichar_Opr; 05180 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 05181 IR_OPND_R(ir_idx) = null_opnd; 05182 } 05183 05184 TRACE (Func_Exit, "ichar_intrinsic", NULL); 05185 05186 } /* ichar_intrinsic */ 05187 05188 05189 /******************************************************************************\ 05190 |* *| 05191 |* Description: *| 05192 |* Function CHAR(I, KIND) intrinsic or ACHAR(I) intrinsic. *| 05193 |* *| 05194 |* Input parameters: *| 05195 |* NONE *| 05196 |* *| 05197 |* Output parameters: *| 05198 |* NONE *| 05199 |* *| 05200 |* Returns: *| 05201 |* NOTHING *| 05202 |* *| 05203 \******************************************************************************/ 05204 05205 void char_intrinsic(opnd_type *result_opnd, 05206 expr_arg_type *res_exp_desc, 05207 int *spec_idx) 05208 { 05209 int list_idx1; 05210 int list_idx2; 05211 long_type cnst[MAX_WORDS_FOR_NUMERIC]; 05212 int ir_idx; 05213 int info_idx1; 05214 int info_idx2; 05215 int type_idx; 05216 05217 05218 TRACE (Func_Entry, "char_intrinsic", NULL); 05219 05220 ir_idx = OPND_IDX((*result_opnd)); 05221 list_idx1 = IR_IDX_R(ir_idx); 05222 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 05223 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 05224 05225 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 05226 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 05227 kind_to_linear_type(&((IL_OPND(list_idx2))), 05228 ATP_RSLT_IDX(*spec_idx), 05229 arg_info_list[info_idx2].ed.kind0seen, 05230 arg_info_list[info_idx2].ed.kind0E0seen, 05231 arg_info_list[info_idx2].ed.kind0D0seen, 05232 ! arg_info_list[info_idx2].ed.kindnotconst); 05233 } 05234 else { 05235 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Character_1; 05236 } 05237 05238 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05239 05240 conform_check(0, 05241 ir_idx, 05242 res_exp_desc, 05243 spec_idx, 05244 FALSE); 05245 05246 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05247 IR_RANK(ir_idx) = res_exp_desc->rank; 05248 05249 res_exp_desc->char_len.fld = CN_Tbl_Idx; 05250 res_exp_desc->char_len.idx = CN_INTEGER_ONE_IDX; 05251 res_exp_desc->type_idx = type_idx; 05252 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 05253 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 05254 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 05255 arg_info_list[info_idx1].ed.type_idx, 05256 NULL, 05257 NULL_IDX, 05258 cnst, 05259 &type_idx, 05260 IR_LINE_NUM(ir_idx), 05261 IR_COL_NUM(ir_idx), 05262 1, 05263 Char_Opr)) { 05264 if (compare_cn_and_value(IL_IDX(list_idx1), 255, Gt_Opr) || 05265 compare_cn_and_value(IL_IDX(list_idx1), 0, Lt_Opr)) { 05266 PRINTMSG(arg_info_list[info_idx1].line, 999, Error, 05267 arg_info_list[info_idx1].col); 05268 } 05269 05270 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 05271 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 05272 FALSE, 05273 cnst); 05274 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 05275 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 05276 res_exp_desc->constant = TRUE; 05277 res_exp_desc->foldable = TRUE; 05278 } 05279 else { 05280 IR_OPR(ir_idx) = Char_Opr; 05281 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 05282 IR_OPND_R(ir_idx) = null_opnd; 05283 05284 IR_LIST_CNT_L(ir_idx) = 1; 05285 IL_NEXT_LIST_IDX(list_idx1) = NULL_IDX; 05286 05287 /* set this flag so this opr is pulled off io lists */ 05288 io_item_must_flatten = TRUE; 05289 } 05290 05291 05292 TRACE (Func_Exit, "char_intrinsic", NULL); 05293 05294 } /* char_intrinsic */ 05295 05296 05297 /******************************************************************************\ 05298 |* *| 05299 |* Description: *| 05300 |* Function INDEX(STRING, SUBSTRING, BACK) intrinsic. *| 05301 |* Function SCAN(STRING, SET, BACK) intrinsic. *| 05302 |* Function VERIFY(STRING, SET, BACK) intrinsic. *| 05303 |* *| 05304 |* Input parameters: *| 05305 |* NONE *| 05306 |* *| 05307 |* Output parameters: *| 05308 |* NONE *| 05309 |* *| 05310 |* Returns: *| 05311 |* NOTHING *| 05312 |* *| 05313 \******************************************************************************/ 05314 05315 void index_intrinsic(opnd_type *result_opnd, 05316 expr_arg_type *res_exp_desc, 05317 int *spec_idx) 05318 { 05319 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 05320 int cn_idx; 05321 long_type cnst[MAX_WORDS_FOR_NUMERIC]; 05322 int ir_idx; 05323 int info_idx1; 05324 int info_idx2; 05325 int info_idx3; 05326 int list_idx1; 05327 int list_idx2; 05328 int list_idx3; 05329 int type_idx; 05330 operator_type opr; 05331 opnd_type opnd; 05332 05333 05334 TRACE (Func_Entry, "index_intrinsic", NULL); 05335 05336 ir_idx = OPND_IDX((*result_opnd)); 05337 list_idx1 = IR_IDX_R(ir_idx); 05338 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 05339 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 05340 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 05341 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 05342 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 05343 05344 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05345 05346 conform_check(3, 05347 ir_idx, 05348 res_exp_desc, 05349 spec_idx, 05350 FALSE); 05351 05352 IR_TYPE_IDX(ir_idx) = type_idx; 05353 IR_RANK(ir_idx) = res_exp_desc->rank; 05354 05355 05356 res_exp_desc->type_idx = type_idx; 05357 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 05358 05359 if (IL_IDX(list_idx3) == NULL_IDX) { /* if BACK is not present */ 05360 cn_idx = set_up_logical_constant(cnst, 05361 CG_LOGICAL_DEFAULT_TYPE, 05362 FALSE_VALUE, 05363 TRUE); 05364 05365 IL_FLD(list_idx3) = CN_Tbl_Idx; 05366 IL_IDX(list_idx3) = cn_idx; 05367 IL_LINE_NUM(list_idx3) = IR_LINE_NUM(ir_idx); 05368 IL_COL_NUM(list_idx3) = IR_COL_NUM(ir_idx); 05369 05370 arg_info_list_base = arg_info_list_top; 05371 arg_info_list_top = arg_info_list_base + 1; 05372 05373 if (arg_info_list_top >= arg_info_list_size) { 05374 enlarge_info_list_table(); 05375 } 05376 05377 IL_ARG_DESC_IDX(list_idx3) = arg_info_list_top; 05378 arg_info_list[arg_info_list_top] = init_arg_info; 05379 arg_info_list[arg_info_list_top].ed.type_idx = CG_LOGICAL_DEFAULT_TYPE; 05380 arg_info_list[arg_info_list_top].ed.type = Logical; 05381 arg_info_list[arg_info_list_top].ed.linear_type= CG_LOGICAL_DEFAULT_TYPE; 05382 arg_info_list[arg_info_list_top].line = IR_LINE_NUM(ir_idx); 05383 arg_info_list[arg_info_list_top].col = IR_COL_NUM(ir_idx); 05384 } 05385 05386 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 05387 05388 if (ATP_INTRIN_ENUM(*spec_idx) == Index_Intrinsic) { 05389 opr = Index_Opr; 05390 } 05391 else if (ATP_INTRIN_ENUM(*spec_idx) == Verify_Intrinsic) { 05392 opr = Verify_Opr; 05393 } 05394 else { 05395 opr = Scan_Opr; 05396 # ifdef _TARGET_OS_MAX 05397 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 05398 # endif 05399 } 05400 05401 if ((list_idx3 != NULL_IDX) && (IL_IDX(list_idx3) != NULL_IDX)) { 05402 COPY_OPND(opnd, IL_OPND(list_idx3)); 05403 cast_to_cg_default(&opnd, &(arg_info_list[info_idx3].ed)); 05404 COPY_OPND(IL_OPND(list_idx3), opnd); 05405 } 05406 05407 # if 0 /*fzhao*/ 05408 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 05409 IL_FLD(list_idx2) == CN_Tbl_Idx && 05410 IL_FLD(list_idx3) == CN_Tbl_Idx && 05411 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 05412 arg_info_list[info_idx1].ed.type_idx, 05413 (char *)&CN_CONST(IL_IDX(list_idx2)), 05414 arg_info_list[info_idx2].ed.type_idx, 05415 folded_const, 05416 &type_idx, 05417 IR_LINE_NUM(ir_idx), 05418 IR_COL_NUM(ir_idx), 05419 3, 05420 opr, 05421 (char *)&CN_CONST(IL_IDX(list_idx3)), 05422 (long)arg_info_list[info_idx3].ed.type_idx)) { 05423 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 05424 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 05425 FALSE, 05426 folded_const); 05427 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 05428 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 05429 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 05430 res_exp_desc->constant = TRUE; 05431 res_exp_desc->foldable = TRUE; 05432 } 05433 else { 05434 #endif 05435 05436 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 05437 IR_OPR(ir_idx) = opr; 05438 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 05439 IR_OPND_R(ir_idx) = null_opnd; 05440 } 05441 05442 /* } */ 05443 05444 05445 TRACE (Func_Exit, "index_intrinsic", NULL); 05446 05447 } /* index_intrinsic */ 05448 05449 05450 /******************************************************************************\ 05451 |* *| 05452 |* Description: *| 05453 |* Function LGE(STRING_A, STRING_B) intrinsic. *| 05454 |* Function LGT(STRING_A, STRING_B) intrinsic. *| 05455 |* Function LLE(STRING_A, STRING_B) intrinsic. *| 05456 |* Function LLT(STRING_A, STRING_B) intrinsic. *| 05457 |* *| 05458 |* Input parameters: *| 05459 |* NONE *| 05460 |* *| 05461 |* Output parameters: *| 05462 |* NONE *| 05463 |* *| 05464 |* Returns: *| 05465 |* NOTHING *| 05466 |* *| 05467 \******************************************************************************/ 05468 05469 void lge_intrinsic(opnd_type *result_opnd, 05470 expr_arg_type *res_exp_desc, 05471 int *spec_idx) 05472 { 05473 int ir_idx; 05474 int list_idx1; 05475 int list_idx2; 05476 int info_idx1; 05477 int info_idx2; 05478 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 05479 int type_idx; 05480 05481 05482 TRACE (Func_Entry, "lge_intrinsic", NULL); 05483 05484 ir_idx = OPND_IDX((*result_opnd)); 05485 list_idx1 = IR_IDX_R(ir_idx); 05486 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 05487 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 05488 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 05489 05490 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 05491 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05492 05493 conform_check(0, 05494 ir_idx, 05495 res_exp_desc, 05496 spec_idx, 05497 FALSE); 05498 05499 IR_TYPE_IDX(ir_idx) = type_idx; 05500 IR_RANK(ir_idx) = res_exp_desc->rank; 05501 05502 /* # if 0 */ 05503 05504 res_exp_desc->type_idx = type_idx; 05505 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 05506 05507 if (ATP_INTRIN_ENUM(*spec_idx) == Lge_Intrinsic) { 05508 IR_OPR(ir_idx) = Ge_Opr; 05509 } 05510 else if (ATP_INTRIN_ENUM(*spec_idx) == Llt_Intrinsic) { 05511 IR_OPR(ir_idx) = Lt_Opr; 05512 } 05513 else if (ATP_INTRIN_ENUM(*spec_idx) == Lle_Intrinsic) { 05514 IR_OPR(ir_idx) = Le_Opr; 05515 } 05516 else { 05517 IR_OPR(ir_idx) = Gt_Opr; 05518 } 05519 05520 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 05521 IL_FLD(list_idx2) == CN_Tbl_Idx && 05522 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 05523 arg_info_list[info_idx1].ed.type_idx, 05524 (char *)&CN_CONST(IL_IDX(list_idx2)), 05525 arg_info_list[info_idx2].ed.type_idx, 05526 folded_const, 05527 &type_idx, 05528 IR_LINE_NUM(ir_idx), 05529 IR_COL_NUM(ir_idx), 05530 2, 05531 IR_OPR(ir_idx))) { 05532 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 05533 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 05534 FALSE, 05535 folded_const); 05536 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 05537 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 05538 res_exp_desc->constant = TRUE; 05539 res_exp_desc->foldable = TRUE; 05540 } 05541 else { 05542 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 05543 IR_OPND_R(ir_idx) = null_opnd; 05544 } 05545 05546 /* # endif */ 05547 #if 0 05548 res_exp_desc->foldable = FALSE; 05549 res_exp_desc->will_fold_later = FALSE; 05550 # endif 05551 05552 TRACE (Func_Exit, "lge_intrinsic", NULL); 05553 05554 } /* lge_intrinsic */ 05555 05556 05557 /******************************************************************************\ 05558 |* *| 05559 |* Description: *| 05560 |* Function LOC(I) intrinsic. *| 05561 |* Function CLOC(C) intrinsic. *| 05562 |* Function C_LOC(X) intrinsic. *| 05563 |* *| 05564 |* Input parameters: *| 05565 |* NONE *| 05566 |* *| 05567 |* Output parameters: *| 05568 |* NONE *| 05569 |* *| 05570 |* Returns: *| 05571 |* NOTHING *| 05572 |* *| 05573 \******************************************************************************/ 05574 05575 void loc_intrinsic(opnd_type *result_opnd, 05576 expr_arg_type *res_exp_desc, 05577 int *spec_idx) 05578 { 05579 opnd_type base_opnd; 05580 int ir_idx; 05581 int attr_idx; 05582 int info_idx1; 05583 int list_idx1; 05584 opnd_type old_opnd; 05585 int unused1 = NULL_IDX; 05586 int unused2 = NULL_IDX; 05587 05588 05589 TRACE (Func_Entry, "loc_intrinsic", NULL); 05590 05591 ir_idx = OPND_IDX((*result_opnd)); 05592 list_idx1 = IR_IDX_R(ir_idx); 05593 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 05594 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ptr_8; 05595 05596 if (ATP_INTRIN_ENUM(*spec_idx) == Cloc_Intrinsic) { 05597 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ch_Ptr_8; 05598 } 05599 05600 if (ATP_INTRIN_ENUM(*spec_idx) == C_Loc_Intrinsic && 05601 arg_info_list[info_idx1].ed.type == Character) { 05602 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ch_Ptr_8; 05603 } 05604 05605 if ((strcmp(AT_OBJ_NAME_PTR(*spec_idx), "LOC@") == 0) && 05606 arg_info_list[info_idx1].ed.type == Character) { 05607 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ch_Ptr_8; 05608 } 05609 05610 conform_check(0, 05611 ir_idx, 05612 res_exp_desc, 05613 spec_idx, 05614 TRUE); 05615 05616 res_exp_desc->rank = 0; 05617 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05618 IR_RANK(ir_idx) = res_exp_desc->rank; 05619 05620 # ifdef _TARGET32 05621 if (arg_info_list[info_idx1].ed.linear_type == Integer_8 || 05622 arg_info_list[info_idx1].ed.linear_type == Real_8 || 05623 arg_info_list[info_idx1].ed.linear_type == Logical_8) { 05624 05625 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 05626 TYP_TYPE(TYP_WORK_IDX) = CRI_Ptr; 05627 TYP_LINEAR(TYP_WORK_IDX) = CRI_Ptr_8; 05628 TYP_PTR_INCREMENT(TYP_WORK_IDX) = 64; 05629 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = ntr_type_tbl(); 05630 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05631 } 05632 # endif 05633 05634 # ifdef _TARGET_OS_MAX 05635 if (arg_info_list[info_idx1].ed.linear_type == Integer_4 || 05636 arg_info_list[info_idx1].ed.linear_type == Real_4 || 05637 arg_info_list[info_idx1].ed.linear_type == Logical_4) { 05638 05639 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 05640 TYP_TYPE(TYP_WORK_IDX) = CRI_Ptr; 05641 TYP_LINEAR(TYP_WORK_IDX) = CRI_Ptr_8; 05642 TYP_PTR_INCREMENT(TYP_WORK_IDX) = 32; 05643 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = ntr_type_tbl(); 05644 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05645 } 05646 # endif 05647 05648 05649 res_exp_desc->type_idx = IR_TYPE_IDX(ir_idx); 05650 res_exp_desc->type = TYP_TYPE(IR_TYPE_IDX(ir_idx)); 05651 res_exp_desc->linear_type = TYP_LINEAR(IR_TYPE_IDX(ir_idx)); 05652 05653 if (IL_FLD(list_idx1) == AT_Tbl_Idx || 05654 (IL_FLD(list_idx1) == IR_Tbl_Idx && 05655 (IR_OPR(IL_IDX(list_idx1)) == Whole_Subscript_Opr || 05656 IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr || 05657 IR_OPR(IL_IDX(list_idx1)) == Struct_Opr || 05658 IR_OPR(IL_IDX(list_idx1)) == Dv_Deref_Opr || 05659 IR_OPR(IL_IDX(list_idx1)) == Subscript_Opr || 05660 IR_OPR(IL_IDX(list_idx1)) == Substring_Opr || 05661 IR_OPR(IL_IDX(list_idx1)) == Section_Subscript_Opr))) { 05662 attr_idx = find_base_attr(&IL_OPND(list_idx1), &unused1, &unused2); 05663 05664 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) { 05665 PRINTMSG(arg_info_list[info_idx1].line, 779, Error, 05666 arg_info_list[info_idx1].col); 05667 goto EXIT; 05668 } 05669 05670 if ((AT_OBJ_CLASS(attr_idx) == Data_Obj) && ATD_AUXILIARY(attr_idx)) { 05671 PRINTMSG(arg_info_list[info_idx1].line, 990, Error, 05672 arg_info_list[info_idx1].col); 05673 goto EXIT; 05674 } 05675 } 05676 else { 05677 PRINTMSG(arg_info_list[info_idx1].line, 779, Error, 05678 arg_info_list[info_idx1].col); 05679 goto EXIT; 05680 } 05681 05682 # if 0 05683 05684 IR_OPR(ir_idx) = Loc_Opr; 05685 05686 COPY_OPND(old_opnd, IL_OPND(IR_IDX_R(ir_idx))); 05687 05688 unused1 = 0; 05689 unused2 = 0; 05690 05691 make_base_subtree(&old_opnd, &base_opnd, &unused1, &unused2); 05692 05693 COPY_OPND(IR_OPND_L(ir_idx), base_opnd); 05694 05695 IR_OPND_R(ir_idx) = null_opnd; 05696 05697 # endif 05698 05699 EXIT: 05700 05701 /* must reset foldable and will_fold_later because there is no */ 05702 /* folder for this intrinsic in constructors. */ 05703 05704 05705 res_exp_desc->foldable = FALSE; 05706 res_exp_desc->will_fold_later = FALSE; 05707 05708 TRACE (Func_Exit, "loc_intrinsic", NULL); 05709 05710 } /* loc_intrinsic */ 05711 05712 05713 /******************************************************************************\ 05714 |* *| 05715 |* Description: *| 05716 |* Function FCD(I, J) intrinsic. *| 05717 |* *| 05718 |* Input parameters: *| 05719 |* NONE *| 05720 |* *| 05721 |* Output parameters: *| 05722 |* NONE *| 05723 |* *| 05724 |* Returns: *| 05725 |* NOTHING *| 05726 |* *| 05727 \******************************************************************************/ 05728 05729 void fcd_intrinsic(opnd_type *result_opnd, 05730 expr_arg_type *res_exp_desc, 05731 int *spec_idx) 05732 { 05733 int ir_idx; 05734 05735 05736 TRACE (Func_Entry, "fcd_intrinsic", NULL); 05737 05738 ir_idx = OPND_IDX((*result_opnd)); 05739 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ch_Ptr_8; 05740 05741 conform_check(0, 05742 ir_idx, 05743 res_exp_desc, 05744 spec_idx, 05745 FALSE); 05746 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05747 IR_RANK(ir_idx) = res_exp_desc->rank; 05748 05749 # if 0 05750 05751 IR_OPR(ir_idx) = Fcd_Opr; 05752 05753 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 05754 IR_OPND_R(ir_idx) = null_opnd; 05755 05756 # endif 05757 05758 /* must reset foldable and will_fold_later because there is no */ 05759 /* folder for this intrinsic in constructors. */ 05760 05761 res_exp_desc->foldable = FALSE; 05762 res_exp_desc->will_fold_later = FALSE; 05763 05764 05765 TRACE (Func_Exit, "fcd_intrinsic", NULL); 05766 05767 } /* fcd_intrinsic */ 05768 05769 05770 05771 05772 /******************************************************************************\ 05773 |* *| 05774 |* Description: *| 05775 |* Function FETCH_AND_ADD(I, J) intrinsic. *| 05776 |* Function FETCH_AND_AND(I, J) intrinsic. *| 05777 |* Function FETCH_AND_NAND(I, J) intrinsic. *| 05778 |* Function FETCH_AND_OR(I, J) intrinsic. *| 05779 |* Function FETCH_AND_SUB(I, J) intrinsic. *| 05780 |* Function FETCH_AND_XOR(I, J) intrinsic. *| 05781 |* Function ADD_AND_FETCH(I, J) intrinsic. *| 05782 |* Function AND_AND_FETCH(I, J) intrinsic. *| 05783 |* Function NAND_AND_FETCH(I, J) intrinsic. *| 05784 |* Function OR_AND_FETCH(I, J) intrinsic. *| 05785 |* Function SUB_AND_FETCH(I, J) intrinsic. *| 05786 |* Function XOR_AND_FETCH(I, J) intrinsic. *| 05787 |* Function LOCK_TEST_AND_SET(I, J) intrinsic. *| 05788 |* *| 05789 |* Input parameters: *| 05790 |* NONE *| 05791 |* *| 05792 |* Output parameters: *| 05793 |* NONE *| 05794 |* *| 05795 |* Returns: *| 05796 |* NOTHING *| 05797 |* *| 05798 \******************************************************************************/ 05799 void fetch_and_add_intrinsic(opnd_type *result_opnd, 05800 expr_arg_type *res_exp_desc, 05801 int *spec_idx) 05802 { 05803 int ir_idx; 05804 int list_idx1; 05805 int info_idx1; 05806 05807 05808 TRACE (Func_Entry, "fetch_and_add_intrinsic", NULL); 05809 05810 ir_idx = OPND_IDX((*result_opnd)); 05811 05812 list_idx1 = IR_IDX_R(ir_idx); 05813 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 05814 05815 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 05816 05817 conform_check(0, 05818 ir_idx, 05819 res_exp_desc, 05820 spec_idx, 05821 FALSE); 05822 05823 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05824 IR_RANK(ir_idx) = res_exp_desc->rank; 05825 05826 # if 0 05827 io_item_must_flatten = TRUE; 05828 05829 if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_Add_Intrinsic) { 05830 IR_OPR(ir_idx) = Fetch_And_Add_Opr; 05831 } 05832 else if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_And_Intrinsic) { 05833 IR_OPR(ir_idx) = Fetch_And_And_Opr; 05834 } 05835 else if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_Nand_Intrinsic) { 05836 IR_OPR(ir_idx) = Fetch_And_Nand_Opr; 05837 } 05838 else if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_Or_Intrinsic) { 05839 IR_OPR(ir_idx) = Fetch_And_Or_Opr; 05840 } 05841 else if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_Xor_Intrinsic) { 05842 IR_OPR(ir_idx) = Fetch_And_Xor_Opr; 05843 } 05844 else if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_Sub_Intrinsic) { 05845 IR_OPR(ir_idx) = Fetch_And_Sub_Opr; 05846 } 05847 else if (ATP_INTRIN_ENUM(*spec_idx) == Add_And_Fetch_Intrinsic) { 05848 IR_OPR(ir_idx) = Add_And_Fetch_Opr; 05849 } 05850 else if (ATP_INTRIN_ENUM(*spec_idx) == And_And_Fetch_Intrinsic) { 05851 IR_OPR(ir_idx) = And_And_Fetch_Opr; 05852 } 05853 else if (ATP_INTRIN_ENUM(*spec_idx) == Nand_And_Fetch_Intrinsic) { 05854 IR_OPR(ir_idx) = Nand_And_Fetch_Opr; 05855 } 05856 else if (ATP_INTRIN_ENUM(*spec_idx) == Or_And_Fetch_Intrinsic) { 05857 IR_OPR(ir_idx) = Or_And_Fetch_Opr; 05858 } 05859 else if (ATP_INTRIN_ENUM(*spec_idx) == Sub_And_Fetch_Intrinsic) { 05860 IR_OPR(ir_idx) = Sub_And_Fetch_Opr; 05861 } 05862 else if (ATP_INTRIN_ENUM(*spec_idx) == Xor_And_Fetch_Intrinsic) { 05863 IR_OPR(ir_idx) = Xor_And_Fetch_Opr; 05864 } 05865 else if (ATP_INTRIN_ENUM(*spec_idx) == Lock_Test_And_Set_Intrinsic) { 05866 IR_OPR(ir_idx) = Lock_Test_And_Set_Opr; 05867 } 05868 05869 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 05870 IR_OPND_R(ir_idx) = null_opnd; 05871 05872 /* must reset foldable and will_fold_later because there is no */ 05873 /* folder for this intrinsic in constructors. */ 05874 # endif 05875 05876 res_exp_desc->foldable = FALSE; 05877 res_exp_desc->will_fold_later = FALSE; 05878 05879 TRACE (Func_Exit, "fetch_and_add_intrinsic", NULL); 05880 05881 } /* fetch_and_add_intrinsic */ 05882 05883 05884 05885 /******************************************************************************\ 05886 |* *| 05887 |* Description: *| 05888 |* Function NUMARG() intrinsic. *| 05889 |* *| 05890 |* Input parameters: *| 05891 |* NONE *| 05892 |* *| 05893 |* Output parameters: *| 05894 |* NONE *| 05895 |* *| 05896 |* Returns: *| 05897 |* NOTHING *| 05898 |* *| 05899 \******************************************************************************/ 05900 05901 void numarg_intrinsic(opnd_type *result_opnd, 05902 expr_arg_type *res_exp_desc, 05903 int *spec_idx) 05904 { 05905 int ir_idx; 05906 05907 05908 TRACE (Func_Entry, "numarg_intrinsic", NULL); 05909 05910 ir_idx = OPND_IDX((*result_opnd)); 05911 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 05912 05913 conform_check(0, 05914 ir_idx, 05915 res_exp_desc, 05916 spec_idx, 05917 FALSE); 05918 05919 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05920 IR_RANK(ir_idx) = res_exp_desc->rank; 05921 05922 # if 0 05923 05924 IR_OPR(ir_idx) = Numarg_Opr; 05925 05926 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 05927 IR_OPND_R(ir_idx) = null_opnd; 05928 05929 # endif 05930 05931 /* must reset foldable and will_fold_later because there is no */ 05932 /* folder for this intrinsic in constructors. */ 05933 05934 res_exp_desc->foldable = FALSE; 05935 res_exp_desc->will_fold_later = FALSE; 05936 05937 TRACE (Func_Exit, "numarg_intrinsic", NULL); 05938 05939 } /* numarg_intrinsic */ 05940 05941 05942 05943 /******************************************************************************\ 05944 |* *| 05945 |* Description: *| 05946 |* Function READ@SM() intrinsic. *| 05947 |* *| 05948 |* Input parameters: *| 05949 |* NONE *| 05950 |* *| 05951 |* Output parameters: *| 05952 |* NONE *| 05953 |* *| 05954 |* Returns: *| 05955 |* NOTHING *| 05956 |* *| 05957 \******************************************************************************/ 05958 05959 void readsm_intrinsic(opnd_type *result_opnd, 05960 expr_arg_type *res_exp_desc, 05961 int *spec_idx) 05962 { 05963 int ir_idx; 05964 05965 TRACE (Func_Entry, "readsm_intrinsic", NULL); 05966 05967 ir_idx = OPND_IDX((*result_opnd)); 05968 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 05969 05970 conform_check(0, 05971 ir_idx, 05972 res_exp_desc, 05973 spec_idx, 05974 FALSE); 05975 05976 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 05977 IR_RANK(ir_idx) = res_exp_desc->rank; 05978 05979 # if 0 05980 05981 IR_OPR(ir_idx) = Readsm_Opr; 05982 05983 IR_OPND_L(ir_idx) = null_opnd; 05984 IR_OPND_R(ir_idx) = null_opnd; 05985 05986 # endif 05987 05988 /* must reset foldable and will_fold_later because there is no */ 05989 /* folder for this intrinsic in constructors. */ 05990 05991 res_exp_desc->foldable = FALSE; 05992 res_exp_desc->will_fold_later = FALSE; 05993 05994 05995 TRACE (Func_Exit, "readsm_intrinsic", NULL); 05996 05997 } /* readsm_intrinsic */ 05998 05999 06000 06001 /******************************************************************************\ 06002 |* *| 06003 |* Description: *| 06004 |* Subroutine MEMORY_BARRIER() intrinsic. *| 06005 |* *| 06006 |* Input parameters: *| 06007 |* NONE *| 06008 |* *| 06009 |* Output parameters: *| 06010 |* NONE *| 06011 |* *| 06012 |* Returns: *| 06013 |* NOTHING *| 06014 |* *| 06015 \******************************************************************************/ 06016 06017 void memory_barrier_intrinsic(opnd_type *result_opnd, 06018 expr_arg_type *res_exp_desc, 06019 int *spec_idx) 06020 { 06021 int ir_idx; 06022 06023 06024 TRACE (Func_Entry, "memory_barrier_intrinsic", NULL); 06025 06026 ir_idx = OPND_IDX((*result_opnd)); 06027 06028 conform_check(0, 06029 ir_idx, 06030 res_exp_desc, 06031 spec_idx, 06032 FALSE); 06033 06034 IR_RANK(ir_idx) = res_exp_desc->rank; 06035 IR_OPR(ir_idx) = Memory_Barrier_Opr; 06036 06037 # if 0 06038 06039 IR_OPND_L(ir_idx) = null_opnd; 06040 IR_OPND_R(ir_idx) = null_opnd; 06041 06042 /* must reset foldable and will_fold_later because there is no */ 06043 /* folder for this intrinsic in constructors. */ 06044 06045 #endif 06046 06047 res_exp_desc->foldable = FALSE; 06048 res_exp_desc->will_fold_later = FALSE; 06049 06050 TRACE (Func_Exit, "memory_barrier_intrinsic", NULL); 06051 06052 } /* memory_barrier_intrinsic */ 06053 06054 06055 06056 /******************************************************************************\ 06057 |* *| 06058 |* Description: *| 06059 |* Subroutine REMOTE_WRITE_BARRIER() intrinsic. *| 06060 |* *| 06061 |* Input parameters: *| 06062 |* NONE *| 06063 |* *| 06064 |* Output parameters: *| 06065 |* NONE *| 06066 |* *| 06067 |* Returns: *| 06068 |* NOTHING *| 06069 |* *| 06070 \******************************************************************************/ 06071 06072 void remote_write_barrier_intrinsic(opnd_type *result_opnd, 06073 expr_arg_type *res_exp_desc, 06074 int *spec_idx) 06075 { 06076 int ir_idx; 06077 06078 06079 TRACE (Func_Entry, "remote_write_barrier_intrinsic", NULL); 06080 06081 ir_idx = OPND_IDX((*result_opnd)); 06082 06083 conform_check(0, 06084 ir_idx, 06085 res_exp_desc, 06086 spec_idx, 06087 FALSE); 06088 06089 IR_RANK(ir_idx) = res_exp_desc->rank; 06090 06091 # if 0 06092 06093 IR_OPR(ir_idx) = Remote_Write_Barrier_Opr; 06094 06095 IR_OPND_L(ir_idx) = null_opnd; 06096 IR_OPND_R(ir_idx) = null_opnd; 06097 06098 /* must reset foldable and will_fold_later because there is no */ 06099 /* folder for this intrinsic in constructors. */ 06100 06101 # endif 06102 06103 res_exp_desc->foldable = FALSE; 06104 res_exp_desc->will_fold_later = FALSE; 06105 06106 06107 TRACE (Func_Exit, "remote_write_barrier_intrinsic", NULL); 06108 06109 } /* remote_write_barrier_intrinsic */ 06110 06111 /******************************************************************************\ 06112 |* *| 06113 |* Description: *| 06114 |* Subroutine WRITE_MEMORY_BARRIER() intrinsic. *| 06115 |* *| 06116 |* Input parameters: *| 06117 |* NONE *| 06118 |* *| 06119 |* Output parameters: *| 06120 |* NONE *| 06121 |* *| 06122 |* Returns: *| 06123 |* NOTHING *| 06124 |* *| 06125 \******************************************************************************/ 06126 06127 void write_memory_barrier_intrinsic(opnd_type *result_opnd, 06128 expr_arg_type *res_exp_desc, 06129 int *spec_idx) 06130 { 06131 int ir_idx; 06132 06133 06134 TRACE (Func_Entry, "write_memory_barrier_intrinsic", NULL); 06135 06136 ir_idx = OPND_IDX((*result_opnd)); 06137 06138 conform_check(0, 06139 ir_idx, 06140 res_exp_desc, 06141 spec_idx, 06142 FALSE); 06143 06144 IR_RANK(ir_idx) = res_exp_desc->rank; 06145 06146 # if 0 06147 06148 IR_OPR(ir_idx) = Write_Memory_Barrier_Opr; 06149 06150 IR_OPND_L(ir_idx) = null_opnd; 06151 IR_OPND_R(ir_idx) = null_opnd; 06152 06153 /* must reset foldable and will_fold_later because there is no */ 06154 /* folder for this intrinsic in constructors. */ 06155 06156 # endif 06157 06158 res_exp_desc->foldable = FALSE; 06159 res_exp_desc->will_fold_later = FALSE; 06160 06161 TRACE (Func_Exit, "write_memory_barrier_intrinsic", NULL); 06162 06163 } /* write_memory_barrier_intrinsic */ 06164 06165 /******************************************************************************\ 06166 |* *| 06167 |* Description: *| 06168 |* Subroutine SYNCHRONIZE() intrinsic. *| 06169 |* *| 06170 |* Input parameters: *| 06171 |* NONE *| 06172 |* *| 06173 |* Output parameters: *| 06174 |* NONE *| 06175 |* *| 06176 |* Returns: *| 06177 |* NOTHING *| 06178 |* *| 06179 \******************************************************************************/ 06180 void synchronize_intrinsic(opnd_type *result_opnd, 06181 expr_arg_type *res_exp_desc, 06182 int *spec_idx) 06183 { 06184 int ir_idx; 06185 06186 06187 TRACE (Func_Entry, "synchronize_intrinsic", NULL); 06188 06189 ir_idx = OPND_IDX((*result_opnd)); 06190 06191 conform_check(0, 06192 ir_idx, 06193 res_exp_desc, 06194 spec_idx, 06195 FALSE); 06196 06197 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 06198 IR_RANK(ir_idx) = res_exp_desc->rank; 06199 06200 # if 0 06201 06202 IR_OPR(ir_idx) = Synchronize_Opr; 06203 06204 IR_OPND_L(ir_idx) = null_opnd; 06205 IR_OPND_R(ir_idx) = null_opnd; 06206 06207 io_item_must_flatten = TRUE; 06208 06209 /* must reset foldable and will_fold_later because there is no */ 06210 /* folder for this intrinsic in constructors. */ 06211 06212 # endif 06213 06214 res_exp_desc->foldable = FALSE; 06215 res_exp_desc->will_fold_later = FALSE; 06216 06217 TRACE (Func_Exit, "synchronize_intrinsic", NULL); 06218 06219 } /* synchronize_intrinsic */ 06220 06221 06222 06223 06224 /******************************************************************************\ 06225 |* *| 06226 |* Description: *| 06227 |* Function RTC() intrinsic. *| 06228 |* Function IRTC() intrinsic. *| 06229 |* *| 06230 |* Input parameters: *| 06231 |* NONE *| 06232 |* *| 06233 |* Output parameters: *| 06234 |* NONE *| 06235 |* *| 06236 |* Returns: *| 06237 |* NOTHING *| 06238 |* *| 06239 \******************************************************************************/ 06240 06241 void rtc_intrinsic(opnd_type *result_opnd, 06242 expr_arg_type *res_exp_desc, 06243 int *spec_idx) 06244 { 06245 int ir_idx; 06246 06247 06248 TRACE (Func_Entry, "rtc_intrinsic", NULL); 06249 06250 ir_idx = OPND_IDX((*result_opnd)); 06251 if (ATP_INTRIN_ENUM(*spec_idx) == Irtc_Intrinsic) { 06252 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 06253 } 06254 else { 06255 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_8; 06256 } 06257 06258 conform_check(0, 06259 ir_idx, 06260 res_exp_desc, 06261 spec_idx, 06262 FALSE); 06263 06264 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 06265 IR_RANK(ir_idx) = res_exp_desc->rank; 06266 06267 # if 0 06268 06269 IR_OPR(ir_idx) = Rtc_Opr; 06270 06271 IR_OPND_L(ir_idx) = null_opnd; 06272 IR_OPND_R(ir_idx) = null_opnd; 06273 06274 # endif 06275 06276 /* must reset foldable and will_fold_later because there is no */ 06277 /* folder for this intrinsic in constructors. */ 06278 06279 res_exp_desc->foldable = FALSE; 06280 res_exp_desc->will_fold_later = FALSE; 06281 06282 TRACE (Func_Exit, "rtc_intrinsic", NULL); 06283 06284 } /* rtc_intrinsic */ 06285 06286 06287 /******************************************************************************\ 06288 |* *| 06289 |* Description: *| 06290 |* Function MY_PE() intrinsic (MPP Only). *| 06291 |* *| 06292 |* Input parameters: *| 06293 |* NONE *| 06294 |* *| 06295 |* Output parameters: *| 06296 |* NONE *| 06297 |* *| 06298 |* Returns: *| 06299 |* NOTHING *| 06300 |* *| 06301 \******************************************************************************/ 06302 06303 void my_pe_intrinsic(opnd_type *result_opnd, 06304 expr_arg_type *res_exp_desc, 06305 int *spec_idx) 06306 { 06307 int ir_idx; 06308 06309 06310 TRACE (Func_Entry, "my_pe_intrinsic", NULL); 06311 06312 ir_idx = OPND_IDX((*result_opnd)); 06313 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 06314 06315 conform_check(0, 06316 ir_idx, 06317 res_exp_desc, 06318 spec_idx, 06319 FALSE); 06320 06321 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 06322 IR_RANK(ir_idx) = res_exp_desc->rank; 06323 06324 # if 0 06325 06326 IR_OPR(ir_idx) = My_Pe_Opr; 06327 06328 IR_OPND_L(ir_idx) = null_opnd; 06329 IR_OPND_R(ir_idx) = null_opnd; 06330 06331 # endif 06332 06333 /* must reset foldable and will_fold_later because there is no */ 06334 /* folder for this intrinsic in constructors. */ 06335 06336 res_exp_desc->foldable = FALSE; 06337 res_exp_desc->will_fold_later = FALSE; 06338 06339 /* Set this flag so this opr is pulled off io lists. This is */ 06340 /* needed because pdgcs feels compelled to treat fei_new_my_pe */ 06341 /* as a data object which it can take the address of. Problem */ 06342 /* is, this is not a data object. */ 06343 06344 /* io_item_must_flatten = TRUE; */ 06345 06346 TRACE (Func_Exit, "my_pe_intrinsic", NULL); 06347 06348 } /* my_pe_intrinsic */ 06349 06350 06351 /******************************************************************************\ 06352 |* *| 06353 |* Description: *| 06354 |* Function CVMGP(I, J, K) intrinsic. *| 06355 |* Function CVMGM(I, J, K) intrinsic. *| 06356 |* Function CVMGZ(I, J, K) intrinsic. *| 06357 |* Function CVMGN(I, J, K) intrinsic. *| 06358 |* Function CVMGT(I, J, K) intrinsic. *| 06359 |* *| 06360 |* Input parameters: *| 06361 |* NONE *| 06362 |* *| 06363 |* Output parameters: *| 06364 |* NONE *| 06365 |* *| 06366 |* Returns: *| 06367 |* NOTHING *| 06368 |* *| 06369 \******************************************************************************/ 06370 void cvmgp_intrinsic(opnd_type *result_opnd, 06371 expr_arg_type *res_exp_desc, 06372 int *spec_idx) 06373 { 06374 int column; 06375 int info_idx1; 06376 int info_idx2; 06377 int info_idx3; 06378 int ir_idx; 06379 int line; 06380 int list_idx1; 06381 int list_idx2; 06382 int list_idx3; 06383 int new_idx; 06384 operator_type opr1; 06385 int type_idx; 06386 06387 06388 TRACE (Func_Entry, "cvmgp_intrinsic", NULL); 06389 06390 ir_idx = OPND_IDX((*result_opnd)); 06391 list_idx1 = IR_IDX_R(ir_idx); 06392 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 06393 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 06394 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 06395 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 06396 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 06397 06398 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 06399 (arg_info_list[info_idx1].ed.linear_type == Short_Typeless_Const || 06400 arg_info_list[info_idx1].ed.linear_type == Short_Char_Const)) { 06401 06402 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx1), 06403 &line, 06404 &column); 06405 06406 type_idx = arg_info_list[info_idx2].ed.type_idx; 06407 06408 if (arg_info_list[info_idx2].ed.type == Character || 06409 arg_info_list[info_idx2].ed.type == Typeless) { 06410 type_idx = INTEGER_DEFAULT_TYPE; 06411 } 06412 06413 IL_IDX(list_idx1) = cast_typeless_constant(IL_IDX(list_idx1), 06414 type_idx, 06415 line, 06416 column); 06417 06418 arg_info_list[info_idx1].ed.type_idx = type_idx; 06419 arg_info_list[info_idx1].ed.type = TYP_TYPE(type_idx); 06420 arg_info_list[info_idx1].ed.linear_type = TYP_LINEAR(type_idx); 06421 } 06422 06423 06424 if (IL_FLD(list_idx2) == CN_Tbl_Idx && 06425 (arg_info_list[info_idx2].ed.linear_type == Short_Typeless_Const || 06426 arg_info_list[info_idx2].ed.linear_type == Short_Char_Const)) { 06427 06428 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx2), 06429 &line, 06430 &column); 06431 06432 type_idx = arg_info_list[info_idx1].ed.type_idx; 06433 06434 if (arg_info_list[info_idx1].ed.type == Character || 06435 arg_info_list[info_idx1].ed.type == Typeless) { 06436 type_idx = INTEGER_DEFAULT_TYPE; 06437 } 06438 06439 IL_IDX(list_idx2) = cast_typeless_constant(IL_IDX(list_idx2), 06440 type_idx, 06441 line, 06442 column); 06443 06444 arg_info_list[info_idx2].ed.type_idx = type_idx; 06445 arg_info_list[info_idx2].ed.type = TYP_TYPE(type_idx); 06446 arg_info_list[info_idx2].ed.linear_type = TYP_LINEAR(type_idx); 06447 } 06448 06449 if (IL_FLD(list_idx3) == CN_Tbl_Idx && 06450 (arg_info_list[info_idx3].ed.linear_type == Short_Typeless_Const || 06451 arg_info_list[info_idx3].ed.linear_type == Short_Char_Const)) { 06452 06453 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx3), 06454 &line, 06455 &column); 06456 06457 type_idx = INTEGER_DEFAULT_TYPE; 06458 06459 IL_IDX(list_idx3) = cast_typeless_constant(IL_IDX(list_idx3), 06460 type_idx, 06461 line, 06462 column); 06463 06464 arg_info_list[info_idx3].ed.type_idx = type_idx; 06465 arg_info_list[info_idx3].ed.type = TYP_TYPE(type_idx); 06466 arg_info_list[info_idx3].ed.linear_type = TYP_LINEAR(type_idx); 06467 } 06468 06469 06470 06471 if (arg_info_list[info_idx1].ed.type == Logical) { 06472 type_idx = LOGICAL_DEFAULT_TYPE; 06473 # if defined(GENERATE_WHIRL) 06474 if (arg_info_list[info_idx1].ed.type == Logical) { 06475 type_idx = arg_info_list[info_idx1].ed.linear_type; 06476 } 06477 # endif 06478 } 06479 else { 06480 type_idx = TYPELESS_DEFAULT_TYPE; 06481 # if defined(GENERATE_WHIRL) 06482 type_idx = INTEGER_DEFAULT_TYPE; 06483 if (arg_info_list[info_idx1].ed.type == Integer) { 06484 type_idx = arg_info_list[info_idx1].ed.linear_type; 06485 } 06486 # endif 06487 06488 06489 # ifdef _TARGET32 06490 if ((arg_info_list[info_idx1].ed.linear_type == Integer_8) || 06491 (arg_info_list[info_idx1].ed.linear_type == Typeless_8) || 06492 (arg_info_list[info_idx1].ed.linear_type == Real_8) || 06493 (arg_info_list[info_idx2].ed.linear_type == Integer_8) || 06494 (arg_info_list[info_idx2].ed.linear_type == Typeless_8) || 06495 (arg_info_list[info_idx2].ed.linear_type == Real_8)) { 06496 type_idx = Typeless_8; 06497 # if defined(GENERATE_WHIRL) 06498 type_idx = Integer_8; 06499 # endif 06500 } 06501 06502 if (arg_info_list[info_idx1].ed.type == Real && 06503 arg_info_list[info_idx2].ed.type == Real) { 06504 # if defined(GENERATE_WHIRL) 06505 type_idx = arg_info_list[info_idx1].ed.linear_type; 06506 # endif 06507 } 06508 06509 # endif 06510 } 06511 06512 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 06513 06514 conform_check(0, 06515 ir_idx, 06516 res_exp_desc, 06517 spec_idx, 06518 FALSE); 06519 06520 06521 switch (ATP_INTRIN_ENUM(*spec_idx)) { 06522 case Cvmgp_Intrinsic: 06523 opr1 = Ge_Opr; 06524 break; 06525 06526 case Cvmgm_Intrinsic: 06527 opr1 = Lt_Opr; 06528 break; 06529 06530 case Cvmgz_Intrinsic: 06531 opr1 = Eq_Opr; 06532 break; 06533 06534 case Cvmgn_Intrinsic: 06535 opr1 = Ne_Opr; 06536 break; 06537 } 06538 06539 # if 0 06540 06541 if (ATP_INTRIN_ENUM(*spec_idx) != Cvmgt_Intrinsic) { 06542 06543 new_idx = gen_ir(IL_FLD(list_idx3), IL_IDX(list_idx3), 06544 opr1, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 06545 IR_COL_NUM(ir_idx), 06546 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 06547 06548 IL_FLD(list_idx3) = IR_Tbl_Idx; 06549 IL_IDX(list_idx3) = new_idx; 06550 } 06551 06552 # endif 06553 06554 IR_TYPE_IDX(ir_idx) = type_idx; 06555 IR_RANK(ir_idx) = res_exp_desc->rank; 06556 06557 /* IR_OPR(ir_idx) = Cvmgt_Opr; */ 06558 06559 /* set this flag so this opr is pulled off io lists */ 06560 /* io_item_must_flatten = TRUE; */ 06561 06562 if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] != 06563 storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) { 06564 PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error, 06565 IR_COL_NUM(ir_idx)); 06566 } 06567 06568 /* COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); */ 06569 /* IR_OPND_R(ir_idx) = null_opnd; */ 06570 06571 res_exp_desc->foldable = FALSE; 06572 res_exp_desc->will_fold_later = FALSE; 06573 06574 TRACE (Func_Exit, "cvmgp_intrinsic", NULL); 06575 06576 } /* cvmgp_intrinsic */ 06577 06578 06579 06580 /******************************************************************************\ 06581 |* *| 06582 |* Description: *| 06583 |* Function COMPARE_AND_SWAP(I, J, K) intrinsic. *| 06584 |* *| 06585 |* Input parameters: *| 06586 |* NONE *| 06587 |* *| 06588 |* Output parameters: *| 06589 |* NONE *| 06590 |* *| 06591 |* Returns: *| 06592 |* NOTHING *| 06593 |* *| 06594 \******************************************************************************/ 06595 void compare_and_swap_intrinsic(opnd_type *result_opnd, 06596 expr_arg_type *res_exp_desc, 06597 int *spec_idx) 06598 { 06599 int ir_idx; 06600 06601 06602 TRACE (Func_Entry, "compare_and_swap_intrinsic", NULL); 06603 06604 ir_idx = OPND_IDX((*result_opnd)); 06605 06606 conform_check(0, ir_idx, 06607 res_exp_desc, 06608 spec_idx, 06609 FALSE); 06610 06611 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 06612 IR_RANK(ir_idx) = res_exp_desc->rank; 06613 06614 # if 0 06615 06616 IR_OPR(ir_idx) = Compare_And_Swap_Opr; 06617 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 06618 IR_OPND_R(ir_idx) = null_opnd; 06619 06620 io_item_must_flatten = TRUE; 06621 06622 # endif 06623 06624 /* must reset foldable and will_fold_later because there is no */ 06625 /* folder for this intrinsic in constructors. */ 06626 06627 res_exp_desc->foldable = FALSE; 06628 res_exp_desc->will_fold_later = FALSE; 06629 06630 TRACE (Func_Exit, "compare_and_swap_intrinsic", NULL); 06631 06632 } /* compare_and_swap_intrinsic */ 06633 06634 06635 /******************************************************************************\ 06636 |* *| 06637 |* Description: *| 06638 |* Function CSMG(I, J, K) intrinsic. *| 06639 |* *| 06640 |* Input parameters: *| 06641 |* NONE *| 06642 |* *| 06643 |* Output parameters: *| 06644 |* NONE *| 06645 |* *| 06646 |* Returns: *| 06647 |* NOTHING *| 06648 |* *| 06649 \******************************************************************************/ 06650 06651 void csmg_intrinsic(opnd_type *result_opnd, 06652 expr_arg_type *res_exp_desc, 06653 int *spec_idx) 06654 { 06655 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 06656 int info_idx1; 06657 int info_idx2; 06658 int info_idx3; 06659 int ir_idx; 06660 int line; 06661 int column; 06662 int list_idx1; 06663 int list_idx2; 06664 int list_idx3; 06665 int type_idx; 06666 06667 06668 TRACE (Func_Entry, "csmg_intrinsic", NULL); 06669 06670 ir_idx = OPND_IDX((*result_opnd)); 06671 06672 list_idx1 = IR_IDX_R(ir_idx); 06673 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 06674 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 06675 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 06676 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 06677 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 06678 06679 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 06680 (arg_info_list[info_idx1].ed.linear_type == Short_Typeless_Const || 06681 arg_info_list[info_idx1].ed.linear_type == Short_Char_Const)) { 06682 06683 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx1), 06684 &line, 06685 &column); 06686 06687 type_idx = arg_info_list[info_idx2].ed.type_idx; 06688 06689 if (arg_info_list[info_idx2].ed.type == Character || 06690 arg_info_list[info_idx2].ed.type == Typeless) { 06691 type_idx = INTEGER_DEFAULT_TYPE; 06692 } 06693 06694 IL_IDX(list_idx1) = cast_typeless_constant(IL_IDX(list_idx1), 06695 type_idx, 06696 line, 06697 column); 06698 06699 arg_info_list[info_idx1].ed.type_idx = type_idx; 06700 arg_info_list[info_idx1].ed.type = TYP_TYPE(type_idx); 06701 arg_info_list[info_idx1].ed.linear_type = TYP_LINEAR(type_idx); 06702 } 06703 06704 if (IL_FLD(list_idx2) == CN_Tbl_Idx && 06705 (arg_info_list[info_idx2].ed.linear_type == Short_Typeless_Const || 06706 arg_info_list[info_idx2].ed.linear_type == Short_Char_Const)) { 06707 06708 find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx2), 06709 &line, 06710 &column); 06711 06712 type_idx = arg_info_list[info_idx1].ed.type_idx; 06713 06714 if (arg_info_list[info_idx1].ed.type == Character || 06715 arg_info_list[info_idx1].ed.type == Typeless) { 06716 type_idx = INTEGER_DEFAULT_TYPE; 06717 } 06718 06719 IL_IDX(list_idx2) = cast_typeless_constant(IL_IDX(list_idx2), 06720 type_idx, 06721 line, 06722 column); 06723 06724 arg_info_list[info_idx2].ed.type_idx = type_idx; 06725 arg_info_list[info_idx2].ed.type = TYP_TYPE(type_idx); 06726 arg_info_list[info_idx2].ed.linear_type = TYP_LINEAR(type_idx); 06727 } 06728 06729 06730 06731 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 06732 # if defined(GENERATE_WHIRL) 06733 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 06734 if (arg_info_list[info_idx1].ed.type == Integer) { 06735 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 06736 arg_info_list[info_idx1].ed.linear_type; 06737 } 06738 # endif 06739 06740 06741 # ifdef _TARGET32 06742 if ((arg_info_list[info_idx1].ed.linear_type == Integer_8) || 06743 (arg_info_list[info_idx1].ed.linear_type == Typeless_8) || 06744 (arg_info_list[info_idx1].ed.linear_type == Real_8) || 06745 (arg_info_list[info_idx2].ed.linear_type == Integer_8) || 06746 (arg_info_list[info_idx2].ed.linear_type == Typeless_8) || 06747 (arg_info_list[info_idx2].ed.linear_type == Real_8) || 06748 (arg_info_list[info_idx3].ed.linear_type == Integer_8) || 06749 (arg_info_list[info_idx3].ed.linear_type == Typeless_8) || 06750 (arg_info_list[info_idx3].ed.linear_type == Real_8)) { 06751 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_8; 06752 # if defined(GENERATE_WHIRL) 06753 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 06754 # endif 06755 } 06756 # endif 06757 06758 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 06759 06760 conform_check(0, 06761 ir_idx, 06762 res_exp_desc, 06763 spec_idx, 06764 FALSE); 06765 06766 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 06767 IR_RANK(ir_idx) = res_exp_desc->rank; 06768 06769 # if 0 06770 06771 res_exp_desc->type_idx = type_idx; 06772 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 06773 06774 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 06775 IL_FLD(list_idx2) == CN_Tbl_Idx && 06776 IL_FLD(list_idx3) == CN_Tbl_Idx && 06777 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 06778 arg_info_list[info_idx1].ed.type_idx, 06779 (char *)&CN_CONST(IL_IDX(list_idx2)), 06780 arg_info_list[info_idx2].ed.type_idx, 06781 folded_const, 06782 &type_idx, 06783 IR_LINE_NUM(ir_idx), 06784 IR_COL_NUM(ir_idx), 06785 3, 06786 Csmg_Opr, 06787 (char *)&CN_CONST(IL_IDX(list_idx3)), 06788 (long)arg_info_list[info_idx3].ed.type_idx)) { 06789 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 06790 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 06791 FALSE, 06792 folded_const); 06793 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 06794 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 06795 res_exp_desc->constant = TRUE; 06796 res_exp_desc->foldable = TRUE; 06797 } 06798 else { 06799 IR_OPR(ir_idx) = Csmg_Opr; 06800 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 06801 IR_OPND_R(ir_idx) = null_opnd; 06802 } 06803 # endif 06804 06805 res_exp_desc->foldable = FALSE; 06806 res_exp_desc->will_fold_later = FALSE; 06807 06808 TRACE (Func_Exit, "csmg_intrinsic", NULL); 06809 06810 } /* csmg_intrinsic */ 06811 06812 06813 /******************************************************************************\ 06814 |* *| 06815 |* Description: *| 06816 |* Function MERGE(TSOURCE, FSOURCE, MASK) intrinsic. *| 06817 |* *| 06818 |* Input parameters: *| 06819 |* NONE *| 06820 |* *| 06821 |* Output parameters: *| 06822 |* NONE *| 06823 |* *| 06824 |* Returns: *| 06825 |* NOTHING *| 06826 |* *| 06827 \******************************************************************************/ 06828 void mergee_intrinsic(opnd_type *result_opnd, 06829 expr_arg_type *res_exp_desc, 06830 int *spec_idx) 06831 { 06832 int list_idx1; 06833 int list_idx2; 06834 int info_idx1; 06835 int info_idx2; 06836 int ir_idx; 06837 int type_idx; 06838 int type_idx2; 06839 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 06840 06841 06842 TRACE (Func_Entry, "mergee_intrinsic", NULL); 06843 06844 ir_idx = OPND_IDX((*result_opnd)); 06845 list_idx1 = IR_IDX_R(ir_idx); 06846 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 06847 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 06848 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 06849 type_idx = arg_info_list[info_idx1].ed.type_idx; 06850 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 06851 06852 if (arg_info_list[info_idx1].ed.linear_type != 06853 arg_info_list[info_idx2].ed.linear_type) { 06854 06855 if (arg_info_list[info_idx1].ed.type == Character && 06856 arg_info_list[info_idx2].ed.type == Character) { 06857 /* intentionally blank */ 06858 } 06859 else { 06860 PRINTMSG(arg_info_list[info_idx2].line, 774, Error, 06861 arg_info_list[info_idx2].col); 06862 } 06863 } 06864 06865 type_idx2 = CG_LOGICAL_DEFAULT_TYPE; 06866 06867 06868 if (arg_info_list[info_idx1].ed.type == Character && 06869 arg_info_list[info_idx2].ed.type == Character && 06870 arg_info_list[info_idx2].ed.char_len.fld == CN_Tbl_Idx && 06871 arg_info_list[info_idx1].ed.char_len.fld == CN_Tbl_Idx && 06872 folder_driver( 06873 (char *)&CN_CONST(arg_info_list[info_idx2].ed.char_len.idx), 06874 arg_info_list[info_idx2].ed.type_idx, 06875 (char *)&CN_CONST(arg_info_list[info_idx1].ed.char_len.idx), 06876 arg_info_list[info_idx1].ed.type_idx, 06877 folded_const, 06878 &type_idx2, 06879 IR_LINE_NUM(ir_idx), 06880 IR_COL_NUM(ir_idx), 06881 2, 06882 Ne_Opr)) { 06883 06884 if (THIS_IS_TRUE(folded_const, type_idx2)) { 06885 PRINTMSG(arg_info_list[info_idx2].line, 774, Error, 06886 arg_info_list[info_idx2].col); 06887 } 06888 } 06889 06890 conform_check(0, 06891 ir_idx, 06892 res_exp_desc, 06893 spec_idx, 06894 FALSE); 06895 06896 06897 IR_TYPE_IDX(ir_idx) = type_idx; 06898 IR_RANK(ir_idx) = res_exp_desc->rank; 06899 06900 # if 0 06901 06902 if (TYP_TYPE(type_idx) == Character) { 06903 COPY_OPND((res_exp_desc->char_len), 06904 (arg_info_list[info_idx1].ed.char_len)); 06905 } 06906 06907 IR_OPR(ir_idx) = Cvmgt_Opr; 06908 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 06909 IR_OPND_R(ir_idx) = null_opnd; 06910 06911 /* set this flag so this opr is pulled off io lists */ 06912 io_item_must_flatten = TRUE; 06913 06914 # endif 06915 06916 res_exp_desc->foldable = FALSE; 06917 res_exp_desc->will_fold_later = FALSE; 06918 06919 06920 06921 TRACE (Func_Exit, "mergee_intrinsic", NULL); 06922 06923 } /* mergee_intrinsic */ 06924 06925 06926 /******************************************************************************\ 06927 |* *| 06928 |* Description: *| 06929 |* Function ADJUSTL(STRING) intrinsic. *| 06930 |* Function ADJUSTR(STRING) intrinsic. *| 06931 |* *| 06932 |* Input parameters: *| 06933 |* NONE *| 06934 |* *| 06935 |* Output parameters: *| 06936 |* NONE *| 06937 |* *| 06938 |* Returns: *| 06939 |* NOTHING *| 06940 |* *| 06941 \******************************************************************************/ 06942 06943 void adjustl_intrinsic(opnd_type *result_opnd, 06944 expr_arg_type *res_exp_desc, 06945 int *spec_idx) 06946 { 06947 expr_arg_type exp_desc; 06948 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 06949 int info_idx1; 06950 int ir_idx; 06951 opnd_type l_opnd; 06952 int list_idx1; 06953 int new_idx; 06954 boolean ok; 06955 operator_type opr; 06956 opnd_type opnd; 06957 opnd_type opnd2; 06958 int unused; 06959 int type_idx; 06960 06961 06962 TRACE (Func_Entry, "adjustl_intrinsic", NULL); 06963 06964 ir_idx = OPND_IDX((*result_opnd)); 06965 list_idx1 = IR_IDX_R(ir_idx); 06966 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 06967 type_idx = arg_info_list[info_idx1].ed.type_idx; 06968 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 06969 06970 conform_check(0, 06971 ir_idx, 06972 res_exp_desc, 06973 spec_idx, 06974 FALSE); 06975 06976 06977 COPY_OPND(res_exp_desc->char_len, arg_info_list[info_idx1].ed.char_len); 06978 res_exp_desc->type_idx = type_idx; 06979 # if 0 06980 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 06981 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 06982 if (ATP_INTRIN_ENUM(*spec_idx) == Adjustl_Intrinsic) { 06983 opr = Adjustl_Opr; 06984 } 06985 else { 06986 opr = Adjustr_Opr; 06987 } 06988 06989 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 06990 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 06991 arg_info_list[info_idx1].ed.type_idx, 06992 NULL, 06993 NULL_IDX, 06994 folded_const, 06995 &type_idx, 06996 IR_LINE_NUM(ir_idx), 06997 IR_COL_NUM(ir_idx), 06998 1, 06999 opr)) { 07000 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 07001 OPND_IDX((*result_opnd)) = folded_const[0]; 07002 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 07003 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 07004 IR_TYPE_IDX(ir_idx) = type_idx; 07005 res_exp_desc->constant = TRUE; 07006 res_exp_desc->foldable = TRUE; 07007 } 07008 else { 07009 io_item_must_flatten = TRUE; 07010 COPY_OPND(opnd2, IR_OPND_R(ir_idx)); 07011 ok = final_arg_work(&opnd2, 07012 IR_IDX_L(ir_idx), 07013 IR_LIST_CNT_R(ir_idx), 07014 NULL); 07015 COPY_OPND(IR_OPND_R(ir_idx), opnd2); 07016 07017 new_idx = gen_ir(IR_FLD_R(ir_idx), IR_IDX_R(ir_idx), 07018 opr, res_exp_desc->type_idx, 07019 IR_LINE_NUM(ir_idx), IR_COL_NUM(ir_idx), 07020 NO_Tbl_Idx, NULL_IDX); 07021 07022 OPND_FLD(opnd) = IR_Tbl_Idx; 07023 OPND_IDX(opnd) = new_idx; 07024 07025 if (IL_FLD(list_idx1) == IR_Tbl_Idx && 07026 IR_OPR(IL_IDX(list_idx1)) == Aloc_Opr) { 07027 COPY_OPND(IL_OPND(list_idx1), IR_OPND_L(IL_IDX(list_idx1))); 07028 } 07029 07030 if (IL_FLD(list_idx1) == AT_Tbl_Idx && 07031 AT_OBJ_CLASS(IL_IDX(list_idx1)) == Data_Obj && 07032 ATD_ARRAY_IDX(IL_IDX(list_idx1)) != NULL_IDX) { 07033 COPY_OPND(opnd2, IL_OPND(list_idx1)); 07034 ok = gen_whole_subscript(&opnd2, &exp_desc); 07035 COPY_OPND(IL_OPND(list_idx1), opnd2); 07036 } 07037 07038 unused = create_tmp_asg(&opnd, 07039 res_exp_desc, 07040 &l_opnd, 07041 Intent_In, 07042 TRUE, 07043 FALSE); 07044 07045 COPY_OPND((*result_opnd), l_opnd); 07046 07047 /* must reset foldable and will_fold_later because there is no */ 07048 /* folder for this intrinsic in constructors. */ 07049 07050 res_exp_desc->foldable = FALSE; 07051 res_exp_desc->will_fold_later = FALSE; 07052 } 07053 # endif 07054 07055 res_exp_desc->foldable = FALSE; 07056 res_exp_desc->will_fold_later = FALSE; 07057 07058 07059 TRACE (Func_Exit, "adjustl_intrinsic", NULL); 07060 07061 } /* adjustl_intrinsic */ 07062 07063 07064 /******************************************************************************\ 07065 |* *| 07066 |* Description: *| 07067 |* Function CEILING(A) intrinsic. *| 07068 |* *| 07069 |* Input parameters: *| 07070 |* NONE *| 07071 |* *| 07072 |* Output parameters: *| 07073 |* NONE *| 07074 |* *| 07075 |* Returns: *| 07076 |* NOTHING *| 07077 |* *| 07078 \******************************************************************************/ 07079 07080 void ceiling_intrinsic(opnd_type *result_opnd, 07081 expr_arg_type *res_exp_desc, 07082 int *spec_idx) 07083 { 07084 int info_idx2; 07085 int ir_idx; 07086 int list_idx1; 07087 int list_idx2; 07088 07089 07090 TRACE (Func_Entry, "ceiling_intrinsic", NULL); 07091 07092 ir_idx = OPND_IDX((*result_opnd)); 07093 list_idx1 = IR_IDX_R(ir_idx); 07094 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 07095 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 07096 07097 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 07098 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 07099 kind_to_linear_type(&((IL_OPND(list_idx2))), 07100 ATP_RSLT_IDX(*spec_idx), 07101 arg_info_list[info_idx2].ed.kind0seen, 07102 arg_info_list[info_idx2].ed.kind0E0seen, 07103 arg_info_list[info_idx2].ed.kind0D0seen, 07104 ! arg_info_list[info_idx2].ed.kindnotconst); 07105 } 07106 07107 conform_check(0, 07108 ir_idx, 07109 res_exp_desc, 07110 spec_idx, 07111 FALSE); 07112 07113 07114 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 07115 IR_RANK(ir_idx) = res_exp_desc->rank; 07116 07117 IR_OPR(ir_idx) = Ceiling_Opr; 07118 07119 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 07120 IR_OPND_R(ir_idx) = null_opnd; 07121 IR_LIST_CNT_L(ir_idx) = 1; 07122 IL_NEXT_LIST_IDX(list_idx1) = NULL_IDX; 07123 07124 07125 /* must reset foldable and will_fold_later because there is no */ 07126 /* folder for this intrinsic in constructors. */ 07127 07128 res_exp_desc->foldable = FALSE; 07129 res_exp_desc->will_fold_later = FALSE; 07130 07131 TRACE (Func_Exit, "ceiling_intrinsic", NULL); 07132 07133 } /* ceiling_intrinsic */ 07134 07135 07136 /******************************************************************************\ 07137 |* *| 07138 |* Description: *| 07139 |* Function DIGITS(X) intrinsic. *| 07140 |* *| 07141 |* Input parameters: *| 07142 |* NONE *| 07143 |* *| 07144 |* Output parameters: *| 07145 |* NONE *| 07146 |* *| 07147 |* Returns: *| 07148 |* NOTHING *| 07149 |* *| 07150 \******************************************************************************/ 07151 07152 void digits_intrinsic(opnd_type *result_opnd, 07153 expr_arg_type *res_exp_desc, 07154 int *spec_idx) 07155 { 07156 int cn_idx; 07157 long num; 07158 int info_idx1; 07159 int ir_idx; 07160 07161 07162 TRACE (Func_Entry, "digits_intrinsic", NULL); 07163 07164 ir_idx = OPND_IDX((*result_opnd)); 07165 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 07166 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 07167 07168 conform_check(0, 07169 ir_idx, 07170 res_exp_desc, 07171 spec_idx, 07172 TRUE); 07173 07174 res_exp_desc->rank = 0; 07175 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 07176 IR_RANK(ir_idx) = res_exp_desc->rank; 07177 07178 # if 0 07179 07180 switch (arg_info_list[info_idx1].ed.linear_type) { 07181 case Real_4: 07182 num = DIGITS_REAL4_F90; 07183 break; 07184 07185 case Real_8: 07186 num = DIGITS_REAL8_F90; 07187 break; 07188 07189 case Real_16: 07190 num = DIGITS_REAL16_F90; 07191 break; 07192 07193 case Integer_1: 07194 num = DIGITS_INT1_F90; 07195 break; 07196 07197 case Integer_2: 07198 num = DIGITS_INT2_F90; 07199 break; 07200 07201 case Integer_4: 07202 num = DIGITS_INT4_F90; 07203 break; 07204 07205 case Integer_8: 07206 num = DIGITS_INT8_F90; 07207 07208 # ifdef _TARGET_HAS_FAST_INTEGER 07209 if (opt_flags.set_allfastint_option || 07210 (opt_flags.set_fastint_option && 07211 (TYP_DESC(arg_info_list[info_idx1].ed.type_idx) == 07212 Default_Typed))) { 07213 num = 46; 07214 } 07215 # endif 07216 07217 break; 07218 } 07219 07220 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 07221 07222 OPND_IDX((*result_opnd)) = cn_idx; 07223 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 07224 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 07225 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 07226 res_exp_desc->constant = TRUE; 07227 res_exp_desc->foldable = TRUE; 07228 07229 # endif 07230 07231 res_exp_desc->foldable = FALSE; 07232 res_exp_desc->will_fold_later = FALSE; 07233 07234 TRACE (Func_Exit, "digits_intrinsic", NULL); 07235 07236 } /* digits_intrinsic */ 07237 07238 07239 /******************************************************************************\ 07240 |* *| 07241 |* Description: *| 07242 |* Function EPSILON(X) intrinsic. *| 07243 |* *| 07244 |* Input parameters: *| 07245 |* NONE *| 07246 |* *| 07247 |* Output parameters: *| 07248 |* NONE *| 07249 |* *| 07250 |* Returns: *| 07251 |* NOTHING *| 07252 |* *| 07253 \******************************************************************************/ 07254 07255 void epsilon_intrinsic(opnd_type *result_opnd, 07256 expr_arg_type *res_exp_desc, 07257 int *spec_idx) 07258 { 07259 int cn_idx; 07260 int info_idx1; 07261 int ir_idx; 07262 07263 07264 TRACE (Func_Entry, "epsilon_intrinsic", NULL); 07265 07266 ir_idx = OPND_IDX((*result_opnd)); 07267 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 07268 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 07269 07270 conform_check(0, 07271 ir_idx, 07272 res_exp_desc, 07273 spec_idx, 07274 TRUE); 07275 07276 res_exp_desc->rank = 0; 07277 IR_TYPE_IDX(ir_idx) = arg_info_list[info_idx1].ed.type_idx; 07278 IR_RANK(ir_idx) = res_exp_desc->rank; 07279 07280 # if 0 07281 07282 switch (arg_info_list[info_idx1].ed.linear_type) { 07283 case Real_4: 07284 cn_idx = cvrt_str_to_cn(EPSILON_REAL4_F90, 07285 arg_info_list[info_idx1].ed.linear_type); 07286 break; 07287 07288 case Real_8: 07289 cn_idx = cvrt_str_to_cn(EPSILON_REAL8_F90, 07290 arg_info_list[info_idx1].ed.linear_type); 07291 break; 07292 07293 case Real_16: 07294 cn_idx = cvrt_str_to_cn(EPSILON_REAL16_F90, 07295 arg_info_list[info_idx1].ed.linear_type); 07296 break; 07297 } 07298 07299 07300 OPND_IDX((*result_opnd)) = cn_idx; 07301 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 07302 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 07303 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 07304 res_exp_desc->constant = TRUE; 07305 res_exp_desc->foldable = TRUE; 07306 07307 # endif 07308 res_exp_desc->foldable = FALSE; 07309 res_exp_desc->will_fold_later = FALSE; 07310 07311 TRACE (Func_Exit, "epsilon_intrinsic", NULL); 07312 07313 } /* epsilon_intrinsic */ 07314 07315 07316 /******************************************************************************\ 07317 |* *| 07318 |* Description: *| 07319 |* Function EXPONENT(X) intrinsic. *| 07320 |* *| 07321 |* Input parameters: *| 07322 |* NONE *| 07323 |* *| 07324 |* Output parameters: *| 07325 |* NONE *| 07326 |* *| 07327 |* Returns: *| 07328 |* NOTHING *| 07329 |* *| 07330 \******************************************************************************/ 07331 07332 void exponent_intrinsic(opnd_type *result_opnd, 07333 expr_arg_type *res_exp_desc, 07334 int *spec_idx) 07335 { 07336 int ir_idx; 07337 07338 07339 TRACE (Func_Entry, "exponent_intrinsic", NULL); 07340 07341 ir_idx = OPND_IDX((*result_opnd)); 07342 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 07343 07344 conform_check(0, 07345 ir_idx, 07346 res_exp_desc, 07347 spec_idx, 07348 FALSE); 07349 07350 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 07351 IR_RANK(ir_idx) = res_exp_desc->rank; 07352 07353 # if 0 07354 07355 IR_OPR(ir_idx) = Exponent_Opr; 07356 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 07357 IR_OPND_R(ir_idx) = null_opnd; 07358 07359 # endif 07360 07361 /* must reset foldable and will_fold_later because there is no */ 07362 /* folder for this intrinsic in constructors. */ 07363 07364 res_exp_desc->foldable = FALSE; 07365 res_exp_desc->will_fold_later = FALSE; 07366 07367 07368 TRACE (Func_Exit, "exponent_intrinsic", NULL); 07369 07370 } /* exponent_intrinsic */ 07371 07372 07373 /******************************************************************************\ 07374 |* *| 07375 |* Description: *| 07376 |* Function FLOOR(A) intrinsic. *| 07377 |* *| 07378 |* Input parameters: *| 07379 |* NONE *| 07380 |* *| 07381 |* Output parameters: *| 07382 |* NONE *| 07383 |* *| 07384 |* Returns: *| 07385 |* NOTHING *| 07386 |* *| 07387 \******************************************************************************/ 07388 07389 void floor_intrinsic(opnd_type *result_opnd, 07390 expr_arg_type *res_exp_desc, 07391 int *spec_idx) 07392 { 07393 int info_idx2; 07394 int ir_idx; 07395 int list_idx1; 07396 int list_idx2; 07397 07398 07399 TRACE (Func_Entry, "floor_intrinsic", NULL); 07400 07401 ir_idx = OPND_IDX((*result_opnd)); 07402 list_idx1 = IR_IDX_R(ir_idx); 07403 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 07404 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 07405 07406 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 07407 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 07408 kind_to_linear_type(&((IL_OPND(list_idx2))), 07409 ATP_RSLT_IDX(*spec_idx), 07410 arg_info_list[info_idx2].ed.kind0seen, 07411 arg_info_list[info_idx2].ed.kind0E0seen, 07412 arg_info_list[info_idx2].ed.kind0D0seen, 07413 ! arg_info_list[info_idx2].ed.kindnotconst); 07414 } 07415 07416 conform_check(0, 07417 ir_idx, 07418 res_exp_desc, 07419 spec_idx, 07420 FALSE); 07421 07422 07423 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 07424 IR_RANK(ir_idx) = res_exp_desc->rank; 07425 07426 IR_OPR(ir_idx) = Floor_Opr; 07427 07428 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 07429 IR_OPND_R(ir_idx) = null_opnd; 07430 IR_LIST_CNT_L(ir_idx) = 1; 07431 IL_NEXT_LIST_IDX(list_idx1) = NULL_IDX; 07432 07433 /* must reset foldable and will_fold_later because there is no */ 07434 /* folder for this intrinsic in constructors. */ 07435 07436 res_exp_desc->foldable = FALSE; 07437 res_exp_desc->will_fold_later = FALSE; 07438 07439 07440 TRACE (Func_Exit, "floor_intrinsic", NULL); 07441 07442 } /* floor_intrinsic */ 07443 07444 07445 /******************************************************************************\ 07446 |* *| 07447 |* Description: *| 07448 |* Function FRACTION(X) intrinsic. *| 07449 |* *| 07450 |* Input parameters: *| 07451 |* NONE *| 07452 |* *| 07453 |* Output parameters: *| 07454 |* NONE *| 07455 |* *| 07456 |* Returns: *| 07457 |* NOTHING *| 07458 |* *| 07459 \******************************************************************************/ 07460 07461 void fraction_intrinsic(opnd_type *result_opnd, 07462 expr_arg_type *res_exp_desc, 07463 int *spec_idx) 07464 { 07465 int ir_idx; 07466 int info_idx1; 07467 07468 TRACE (Func_Entry, "fraction_intrinsic", NULL); 07469 07470 ir_idx = OPND_IDX((*result_opnd)); 07471 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 07472 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 07473 07474 conform_check(0, 07475 ir_idx, 07476 res_exp_desc, 07477 spec_idx, 07478 FALSE); 07479 07480 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 07481 IR_RANK(ir_idx) = res_exp_desc->rank; 07482 07483 # if 0 07484 07485 IR_OPR(ir_idx) = Fraction_Opr; 07486 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 07487 IR_OPND_R(ir_idx) = null_opnd; 07488 07489 /* must reset foldable and will_fold_later because there is no */ 07490 /* folder for this intrinsic in constructors. */ 07491 07492 # endif 07493 07494 res_exp_desc->foldable = FALSE; 07495 res_exp_desc->will_fold_later = FALSE; 07496 07497 TRACE (Func_Exit, "fraction_intrinsic", NULL); 07498 07499 } /* fraction_intrinsic */ 07500 07501 07502 /******************************************************************************\ 07503 |* *| 07504 |* Description: *| 07505 |* Function HUGE(X) intrinsic. *| 07506 |* *| 07507 |* Input parameters: *| 07508 |* NONE *| 07509 |* *| 07510 |* Output parameters: *| 07511 |* NONE *| 07512 |* *| 07513 |* Returns: *| 07514 |* NOTHING *| 07515 |* *| 07516 \******************************************************************************/ 07517 07518 void huge_intrinsic(opnd_type *result_opnd, 07519 expr_arg_type *res_exp_desc, 07520 int *spec_idx) 07521 { 07522 int cn_idx; 07523 int info_idx1; 07524 int ir_idx; 07525 07526 07527 TRACE (Func_Entry, "huge_intrinsic", NULL); 07528 07529 ir_idx = OPND_IDX((*result_opnd)); 07530 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 07531 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 07532 07533 conform_check(0, 07534 ir_idx, 07535 res_exp_desc, 07536 spec_idx, 07537 TRUE); 07538 res_exp_desc->rank = 0; 07539 IR_TYPE_IDX(ir_idx) = arg_info_list[info_idx1].ed.type_idx; 07540 IR_RANK(ir_idx) = res_exp_desc->rank; 07541 07542 07543 switch (arg_info_list[info_idx1].ed.linear_type) { 07544 case Real_4: 07545 cn_idx = cvrt_str_to_cn(HUGE_REAL4_F90, 07546 arg_info_list[info_idx1].ed.linear_type); 07547 break; 07548 07549 case Real_8: 07550 cn_idx = cvrt_str_to_cn(HUGE_REAL8_F90, 07551 arg_info_list[info_idx1].ed.linear_type); 07552 break; 07553 07554 case Real_16: 07555 cn_idx = cvrt_str_to_cn(HUGE_REAL16_F90, 07556 arg_info_list[info_idx1].ed.linear_type); 07557 break; 07558 07559 case Integer_1: 07560 cn_idx = cvrt_str_to_cn(HUGE_INT1_F90, 07561 arg_info_list[info_idx1].ed.linear_type); 07562 break; 07563 07564 case Integer_2: 07565 cn_idx = cvrt_str_to_cn(HUGE_INT2_F90, 07566 arg_info_list[info_idx1].ed.linear_type); 07567 break; 07568 07569 case Integer_4: 07570 cn_idx = cvrt_str_to_cn(HUGE_INT4_F90, 07571 arg_info_list[info_idx1].ed.linear_type); 07572 break; 07573 07574 case Integer_8: 07575 cn_idx = cvrt_str_to_cn(HUGE_INT8_F90, 07576 arg_info_list[info_idx1].ed.linear_type); 07577 07578 # ifdef _TARGET_HAS_FAST_INTEGER 07579 if (opt_flags.set_allfastint_option || 07580 (opt_flags.set_fastint_option && 07581 (TYP_DESC(arg_info_list[info_idx1].ed.type_idx) == 07582 Default_Typed))) { 07583 cn_idx = C_INT_TO_CN(IR_TYPE_IDX(ir_idx), 70368744177663L); 07584 } 07585 # endif 07586 break; 07587 } 07588 07589 07590 OPND_IDX((*result_opnd)) = cn_idx; 07591 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 07592 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 07593 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 07594 res_exp_desc->constant = TRUE; 07595 res_exp_desc->foldable = TRUE; 07596 07597 07598 TRACE (Func_Exit, "huge_intrinsic", NULL); 07599 07600 } /* huge_intrinsic */ 07601 07602 07603 07604 /******************************************************************************\ 07605 |* *| 07606 |* Description: *| 07607 |* Function IBITS(I, POS, LEN) intrinsic. *| 07608 |* Function IIBITS(I, POS, LEN) intrinsic. *| 07609 |* Function JIBITS(I, POS, LEN) intrinsic. *| 07610 |* Function KIBITS(I, POS, LEN) intrinsic. *| 07611 |* *| 07612 |* Input parameters: *| 07613 |* NONE *| 07614 |* *| 07615 |* Output parameters: *| 07616 |* NONE *| 07617 |* *| 07618 |* Returns: *| 07619 |* NOTHING *| 07620 |* *| 07621 \******************************************************************************/ 07622 07623 void ibits_intrinsic(opnd_type *result_opnd, 07624 expr_arg_type *res_exp_desc, 07625 int *spec_idx) 07626 { 07627 boolean fold_it = FALSE; 07628 int ir_idx; 07629 int info_idx1; 07630 int list_idx1; 07631 int list_idx2; 07632 int list_idx3; 07633 opnd_type opnd; 07634 int typeless_idx; 07635 07636 # if !(defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 07637 int cn_idx; 07638 int cn_idx2; 07639 long num; 07640 int shiftl_idx; 07641 int shiftr_idx; 07642 int shifta_idx; 07643 int first_idx; 07644 int second_idx; 07645 int mask_idx; 07646 int band_idx; 07647 int minus_idx; 07648 int line; 07649 int column; 07650 # endif 07651 07652 07653 TRACE (Func_Entry, "ibits_intrinsic", NULL); 07654 07655 ir_idx = OPND_IDX((*result_opnd)); 07656 list_idx1 = IR_IDX_R(ir_idx); 07657 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 07658 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 07659 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 07660 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 07661 07662 if (arg_info_list[info_idx1].ed.type == Typeless) { 07663 PRINTMSG(arg_info_list[info_idx1].line, 1076, Ansi, 07664 arg_info_list[info_idx1].col); 07665 07666 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 07667 } 07668 07669 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_8) { 07670 typeless_idx = Typeless_8; 07671 # if defined(GENERATE_WHIRL) 07672 typeless_idx = Integer_8; 07673 # endif 07674 07675 } 07676 else { 07677 typeless_idx = TYPELESS_DEFAULT_TYPE; 07678 # if defined(GENERATE_WHIRL) 07679 typeless_idx = INTEGER_DEFAULT_TYPE; 07680 if (arg_info_list[info_idx1].ed.type == Integer) { 07681 typeless_idx = arg_info_list[info_idx1].ed.linear_type; 07682 } 07683 # endif 07684 07685 } 07686 07687 # ifdef _TARGET_OS_MAX 07688 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_1 || 07689 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_2 || 07690 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_4) { 07691 typeless_idx = Typeless_4; 07692 } 07693 # endif 07694 07695 conform_check(0, 07696 ir_idx, 07697 res_exp_desc, 07698 spec_idx, 07699 FALSE); 07700 07701 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 07702 IR_RANK(ir_idx) = res_exp_desc->rank; 07703 07704 # if 0 07705 07706 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 07707 IL_FLD(list_idx2) == CN_Tbl_Idx && 07708 IL_FLD(list_idx3) == CN_Tbl_Idx) { 07709 fold_it = TRUE; 07710 } 07711 07712 # if defined(GENERATE_WHIRL) 07713 07714 IR_OPR(ir_idx) = Ibits_Opr; 07715 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 07716 IR_OPND_R(ir_idx) = null_opnd; 07717 07718 # else 07719 07720 line = IR_LINE_NUM(ir_idx); 07721 column = IR_COL_NUM(ir_idx); 07722 07723 num = storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX( 07724 ATP_RSLT_IDX(*spec_idx)))] * 2; 07725 07726 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 07727 07728 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 07729 Minus_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), line, column, 07730 IL_FLD(list_idx3), IL_IDX(list_idx3)); 07731 07732 mask_idx = gen_ir(IR_Tbl_Idx, minus_idx, 07733 Mask_Opr, typeless_idx, line, column, 07734 NO_Tbl_Idx, NULL_IDX); 07735 07736 NTR_IR_LIST_TBL(first_idx); 07737 IL_FLD(first_idx) = IR_Tbl_Idx; 07738 IL_IDX(first_idx) = mask_idx; 07739 NTR_IR_LIST_TBL(second_idx); 07740 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx2)); 07741 IL_NEXT_LIST_IDX(first_idx) = second_idx; 07742 07743 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 07744 Shiftl_Opr, typeless_idx, line, column, 07745 NO_Tbl_Idx, NULL_IDX); 07746 07747 COPY_OPND(opnd, IL_OPND(list_idx1)); 07748 cast_opnd_to_type_idx(&opnd, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 07749 COPY_OPND(IL_OPND(list_idx1), opnd); 07750 07751 band_idx = gen_ir(IR_Tbl_Idx, shiftl_idx, 07752 Band_Opr, typeless_idx, line, column, 07753 IL_FLD(list_idx1), IL_IDX(list_idx1)); 07754 07755 NTR_IR_LIST_TBL(first_idx); 07756 IL_FLD(first_idx) = IR_Tbl_Idx; 07757 IL_IDX(first_idx) = band_idx; 07758 NTR_IR_LIST_TBL(second_idx); 07759 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx2)); 07760 IL_NEXT_LIST_IDX(first_idx) = second_idx; 07761 07762 shiftr_idx = gen_ir(IL_Tbl_Idx, first_idx, 07763 Shiftr_Opr, typeless_idx, line, column, 07764 NO_Tbl_Idx, NULL_IDX); 07765 07766 num =storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))]; 07767 07768 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 07769 07770 switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) { 07771 case Integer_1: 07772 num = BITSIZE_INT1_F90; 07773 break; 07774 07775 case Integer_2: 07776 num = BITSIZE_INT2_F90; 07777 break; 07778 07779 case Integer_4: 07780 num = BITSIZE_INT4_F90; 07781 break; 07782 07783 case Integer_8: 07784 num = BITSIZE_INT8_F90; 07785 break; 07786 } 07787 07788 cn_idx2 = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 07789 07790 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 07791 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, column, 07792 CN_Tbl_Idx, cn_idx2); 07793 07794 NTR_IR_LIST_TBL(first_idx); 07795 IL_FLD(first_idx) = IR_Tbl_Idx; 07796 IL_IDX(first_idx) = shiftr_idx; 07797 NTR_IR_LIST_TBL(second_idx); 07798 IL_FLD(second_idx) = IR_Tbl_Idx; 07799 IL_IDX(second_idx) = minus_idx; 07800 IL_NEXT_LIST_IDX(first_idx) = second_idx; 07801 07802 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 07803 Shiftl_Opr, typeless_idx, line, column, 07804 NO_Tbl_Idx, NULL_IDX); 07805 07806 NTR_IR_LIST_TBL(first_idx); 07807 IL_FLD(first_idx) = IR_Tbl_Idx; 07808 IL_IDX(first_idx) = shiftl_idx; 07809 NTR_IR_LIST_TBL(second_idx); 07810 IL_FLD(second_idx) = IR_Tbl_Idx; 07811 IL_IDX(second_idx) = minus_idx; 07812 IL_NEXT_LIST_IDX(first_idx) = second_idx; 07813 07814 shifta_idx = gen_ir(IL_Tbl_Idx, first_idx, 07815 Shifta_Opr, typeless_idx, line, column, 07816 NO_Tbl_Idx, NULL_IDX); 07817 07818 IR_OPR(ir_idx) = Cvrt_Opr; 07819 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 07820 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 07821 IR_IDX_L(ir_idx) = shifta_idx; 07822 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 07823 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 07824 IR_OPND_R(ir_idx) = null_opnd; 07825 07826 # endif 07827 07828 if (fold_it) { 07829 COPY_OPND(opnd, (*result_opnd)); 07830 fold_aggragate_expression(&opnd, res_exp_desc, FALSE); 07831 COPY_OPND((*result_opnd), opnd); 07832 } 07833 07834 # endif 07835 07836 res_exp_desc->foldable = FALSE; 07837 res_exp_desc->will_fold_later = FALSE; 07838 07839 TRACE (Func_Exit, "ibits_intrinsic", NULL); 07840 07841 } /* ibits_intrinsic */ 07842 07843 07844 /******************************************************************************\ 07845 |* *| 07846 |* Description: *| 07847 |* Function BTEST(I, POS) intrinsic. *| 07848 |* Function BITEST(I, POS) intrinsic. *| 07849 |* Function BJTEST(I, POS) intrinsic. *| 07850 |* Function BKTEST(I, POS) intrinsic. *| 07851 |* *| 07852 |* Input parameters: *| 07853 |* NONE *| 07854 |* *| 07855 |* Output parameters: *| 07856 |* NONE *| 07857 |* *| 07858 |* Returns: *| 07859 |* NOTHING *| 07860 |* *| 07861 \******************************************************************************/ 07862 07863 void btest_intrinsic(opnd_type *result_opnd, 07864 expr_arg_type *res_exp_desc, 07865 int *spec_idx) 07866 { 07867 int ir_idx; 07868 int cn_idx; 07869 int minus_idx; 07870 int shiftl_idx; 07871 int typeless_idx; 07872 int first_idx; 07873 int second_idx; 07874 int shiftr_idx; 07875 int info_idx1; 07876 int list_idx1; 07877 int list_idx2; 07878 int type_idx; 07879 int line; 07880 int column; 07881 long num; 07882 07883 07884 TRACE (Func_Entry, "btest_intrinsic", NULL); 07885 07886 ir_idx = OPND_IDX((*result_opnd)); 07887 list_idx1 = IR_IDX_R(ir_idx); 07888 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 07889 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 07890 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 07891 07892 if (ATP_INTRIN_ENUM(*spec_idx) == Bitest_Intrinsic) { 07893 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Logical_2; 07894 } 07895 else if (ATP_INTRIN_ENUM(*spec_idx) == Bjtest_Intrinsic) { 07896 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Logical_4; 07897 } 07898 else if (ATP_INTRIN_ENUM(*spec_idx) == Bktest_Intrinsic) { 07899 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Logical_8; 07900 } 07901 07902 if (arg_info_list[info_idx1].ed.linear_type == Integer_8) { 07903 typeless_idx = Typeless_8; 07904 } 07905 else { 07906 typeless_idx = TYPELESS_DEFAULT_TYPE; 07907 } 07908 07909 # ifdef _TARGET_OS_MAX 07910 if (arg_info_list[info_idx1].ed.linear_type == Integer_1 || 07911 arg_info_list[info_idx1].ed.linear_type == Integer_2 || 07912 arg_info_list[info_idx1].ed.linear_type == Integer_4) { 07913 typeless_idx = Typeless_4; 07914 } 07915 # endif 07916 07917 conform_check(0, 07918 ir_idx, 07919 res_exp_desc, 07920 spec_idx, 07921 FALSE); 07922 07923 type_idx = INTEGER_DEFAULT_TYPE; 07924 07925 # ifdef _TARGET32 07926 if (arg_info_list[info_idx1].ed.linear_type == Integer_8) { 07927 type_idx = Integer_8; 07928 } 07929 # endif 07930 07931 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 07932 IR_RANK(ir_idx) = res_exp_desc->rank; 07933 07934 # if 0 07935 07936 num = storage_bit_size_tbl[TYP_LINEAR(typeless_idx)] - 1; 07937 07938 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 07939 07940 line = IR_LINE_NUM(ir_idx); 07941 column = IR_COL_NUM(ir_idx); 07942 07943 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 07944 Minus_Opr, type_idx, line, column, 07945 IL_FLD(list_idx2), IL_IDX(list_idx2)); 07946 07947 NTR_IR_LIST_TBL(first_idx); 07948 COPY_OPND(IL_OPND(first_idx), IL_OPND(list_idx1)); 07949 NTR_IR_LIST_TBL(second_idx); 07950 IL_NEXT_LIST_IDX(first_idx) = second_idx; 07951 IL_FLD(second_idx) = IR_Tbl_Idx; 07952 IL_IDX(second_idx) = minus_idx; 07953 07954 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 07955 Shiftl_Opr, typeless_idx, line, column, 07956 NO_Tbl_Idx, NULL_IDX); 07957 07958 NTR_IR_LIST_TBL(first_idx); 07959 IL_FLD(first_idx) = IR_Tbl_Idx; 07960 IL_IDX(first_idx) = shiftl_idx; 07961 NTR_IR_LIST_TBL(second_idx); 07962 IL_NEXT_LIST_IDX(first_idx) = second_idx; 07963 IL_FLD(second_idx) = CN_Tbl_Idx; 07964 IL_IDX(second_idx) = cn_idx; 07965 IL_LINE_NUM(second_idx) = IR_LINE_NUM(ir_idx); 07966 IL_COL_NUM(second_idx) = IR_COL_NUM(ir_idx); 07967 07968 shiftr_idx = gen_ir(IL_Tbl_Idx, first_idx, 07969 Shifta_Opr, typeless_idx, line, column, 07970 NO_Tbl_Idx, NULL_IDX); 07971 07972 if (target_ieee) { 07973 IR_OPR(shiftr_idx) = Shiftr_Opr; 07974 } 07975 07976 07977 IR_OPR(ir_idx) = Cvrt_Opr; 07978 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 07979 IR_IDX_L(ir_idx) = shiftr_idx; 07980 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 07981 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 07982 IR_OPND_R(ir_idx) = null_opnd; 07983 07984 # endif 07985 07986 /* must reset foldable and will_fold_later because there is no */ 07987 /* folder for this intrinsic in constructors. */ 07988 07989 res_exp_desc->foldable = FALSE; 07990 res_exp_desc->will_fold_later = FALSE; 07991 07992 07993 TRACE (Func_Exit, "btest_intrinsic", NULL); 07994 07995 } /* btest_intrinsic */ 07996 07997 07998 07999 /******************************************************************************\ 08000 |* *| 08001 |* Description: *| 08002 |* Function IBSET(I, POS) intrinsic. *| 08003 |* Function IIBSET(I, POS) intrinsic. *| 08004 |* Function JIBSET(I, POS) intrinsic. *| 08005 |* Function KIBSET(I, POS) intrinsic. *| 08006 |* Function IBCLR(I, POS) intrinsic. *| 08007 |* Function IIBCLR(I, POS) intrinsic. *| 08008 |* Function JIBCLR(I, POS) intrinsic. *| 08009 |* Function KIBCLR(I, POS) intrinsic. *| 08010 |* Function IBCHNG(I, POS) intrinsic. *| 08011 |* Function IIBCHNG(I, POS) intrinsic. *| 08012 |* Function JIBCHNG(I, POS) intrinsic. *| 08013 |* Function KIBCHNG(I, POS) intrinsic. *| 08014 |* *| 08015 |* Input parameters: *| 08016 |* NONE *| 08017 |* *| 08018 |* Output parameters: *| 08019 |* NONE *| 08020 |* *| 08021 |* Returns: *| 08022 |* NOTHING *| 08023 |* *| 08024 \******************************************************************************/ 08025 void ibset_intrinsic(opnd_type *result_opnd, 08026 expr_arg_type *res_exp_desc, 08027 int *spec_idx) 08028 { 08029 int ir_idx; 08030 int cn_idx; 08031 int cn_idx2; 08032 int info_idx1; 08033 int info_idx2; 08034 int list_idx1; 08035 int list_idx2; 08036 long num1; 08037 long num2; 08038 int shiftl_idx; 08039 int shifta_idx; 08040 int csmg_idx; 08041 int minus_idx; 08042 int first_idx; 08043 int second_idx; 08044 int third_idx; 08045 int bor_idx; 08046 int band_idx; 08047 int bnot_idx; 08048 int bnot_idx1; 08049 int typeless_idx; 08050 opnd_type opnd; 08051 boolean fold_it = FALSE; 08052 int line; 08053 int column; 08054 08055 08056 TRACE (Func_Entry, "ibset_intrinsic", NULL); 08057 08058 ir_idx = OPND_IDX((*result_opnd)); 08059 list_idx1 = IR_IDX_R(ir_idx); 08060 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 08061 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 08062 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 08063 08064 if (arg_info_list[info_idx1].ed.type == Typeless) { 08065 PRINTMSG(arg_info_list[info_idx1].line, 1076, Ansi, 08066 arg_info_list[info_idx1].col); 08067 } 08068 08069 switch (arg_info_list[info_idx1].ed.linear_type) { 08070 case Typeless_1: 08071 case Integer_1: 08072 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_1; 08073 typeless_idx = Typeless_1; 08074 # ifdef _TARGET_OS_MAX 08075 typeless_idx = Typeless_4; 08076 # endif 08077 # ifdef _TARGET_OS_UNICOS 08078 typeless_idx = Typeless_8; 08079 # endif 08080 num1 = BITSIZE_INT1_F90 - 1; 08081 num2 = BITSIZE_INT1_F90; 08082 break; 08083 08084 case Typeless_2: 08085 case Integer_2: 08086 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_2; 08087 typeless_idx = Typeless_2; 08088 # ifdef _TARGET_OS_MAX 08089 typeless_idx = Typeless_4; 08090 # endif 08091 # ifdef _TARGET_OS_UNICOS 08092 typeless_idx = Typeless_8; 08093 # endif 08094 num1 = BITSIZE_INT2_F90 - 1; 08095 num2 = BITSIZE_INT2_F90; 08096 break; 08097 08098 case Typeless_4: 08099 case Integer_4: 08100 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_4; 08101 typeless_idx = Typeless_4; 08102 # ifdef _TARGET_OS_UNICOS 08103 typeless_idx = Typeless_8; 08104 # endif 08105 num1 = BITSIZE_INT4_F90 - 1; 08106 num2 = BITSIZE_INT4_F90; 08107 break; 08108 08109 case Typeless_8: 08110 case Integer_8: 08111 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 08112 typeless_idx = Typeless_8; 08113 num1 = BITSIZE_INT8_F90 - 1; 08114 num2 = BITSIZE_INT8_F90; 08115 break; 08116 08117 default: 08118 PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, 08119 IR_COL_NUM(ir_idx), 08120 "ibset_intrinsic"); 08121 break; 08122 } 08123 08124 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { 08125 if (compare_cn_and_value(IL_IDX(list_idx2), 0, Lt_Opr) || 08126 compare_cn_and_value(IL_IDX(list_idx2), num1, Gt_Opr)) { 08127 PRINTMSG(arg_info_list[info_idx2].line, 1062, Error, 08128 arg_info_list[info_idx2].col); 08129 } 08130 } 08131 08132 conform_check(0, 08133 ir_idx, 08134 res_exp_desc, 08135 spec_idx, 08136 FALSE); 08137 08138 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 08139 IR_RANK(ir_idx) = res_exp_desc->rank; 08140 08141 # if 0 08142 08143 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 08144 IL_FLD(list_idx2) == CN_Tbl_Idx) { 08145 fold_it = TRUE; 08146 } 08147 08148 line = IR_LINE_NUM(ir_idx); 08149 column = IR_COL_NUM(ir_idx); 08150 cn_idx = (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == 08151 CG_INTEGER_DEFAULT_TYPE) ? 08152 CN_INTEGER_ONE_IDX : 08153 C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), 1); 08154 08155 NTR_IR_LIST_TBL(first_idx); 08156 IL_FLD(first_idx) = CN_Tbl_Idx; 08157 IL_IDX(first_idx) = cn_idx; 08158 IL_LINE_NUM(first_idx) = line; 08159 IL_COL_NUM(first_idx) = column; 08160 08161 NTR_IR_LIST_TBL(second_idx); 08162 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx2)); 08163 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08164 08165 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 08166 Shiftl_Opr, 08167 typeless_idx, 08168 line, column, 08169 NO_Tbl_Idx, NULL_IDX); 08170 08171 COPY_OPND(opnd, IL_OPND(list_idx1)); 08172 cast_opnd_to_type_idx(&opnd, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 08173 COPY_OPND(IL_OPND(list_idx1), opnd); 08174 08175 num1=storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))]; 08176 08177 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num1); 08178 cn_idx2 = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num2); 08179 08180 switch (ATP_INTRIN_ENUM(*spec_idx)) { 08181 case Ibset_Intrinsic: 08182 case Iibset_Intrinsic: 08183 case Jibset_Intrinsic: 08184 case Kibset_Intrinsic: 08185 bor_idx = gen_ir(IR_Tbl_Idx, shiftl_idx, 08186 Bor_Opr, 08187 typeless_idx, 08188 line, column, 08189 IL_FLD(list_idx1), IL_IDX(list_idx1)); 08190 08191 NTR_IR_LIST_TBL(first_idx); 08192 IL_FLD(first_idx) = IR_Tbl_Idx; 08193 IL_IDX(first_idx) = bor_idx; 08194 break; 08195 08196 08197 case Ibclr_Intrinsic: 08198 case Iibclr_Intrinsic: 08199 case Jibclr_Intrinsic: 08200 case Kibclr_Intrinsic: 08201 bnot_idx = gen_ir(IR_Tbl_Idx, shiftl_idx, 08202 Bnot_Opr, 08203 typeless_idx, 08204 line, column, 08205 NO_Tbl_Idx, NULL_IDX); 08206 08207 band_idx = gen_ir(IR_Tbl_Idx, bnot_idx, 08208 Band_Opr, 08209 typeless_idx, 08210 line, column, 08211 IL_FLD(list_idx1), IL_IDX(list_idx1)); 08212 08213 NTR_IR_LIST_TBL(first_idx); 08214 IL_FLD(first_idx) = IR_Tbl_Idx; 08215 IL_IDX(first_idx) = band_idx; 08216 break; 08217 08218 08219 case Ibchng_Intrinsic: 08220 case Iibchng_Intrinsic: 08221 case Jibchng_Intrinsic: 08222 case Kibchng_Intrinsic: 08223 bnot_idx = gen_ir(IR_Tbl_Idx, shiftl_idx, 08224 Bnot_Opr, 08225 typeless_idx, 08226 line, column, 08227 NO_Tbl_Idx, NULL_IDX); 08228 08229 COPY_OPND(opnd, IL_OPND(list_idx1)); 08230 copy_subtree(&opnd, &opnd); 08231 bnot_idx1 = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 08232 Bnot_Opr, 08233 typeless_idx, 08234 line, column, 08235 NO_Tbl_Idx, NULL_IDX); 08236 08237 NTR_IR_LIST_TBL(first_idx); 08238 COPY_OPND(opnd, IL_OPND(list_idx1)); 08239 copy_subtree(&opnd, &opnd); 08240 COPY_OPND(IL_OPND(first_idx), opnd); 08241 08242 NTR_IR_LIST_TBL(second_idx); 08243 IL_FLD(second_idx) = IR_Tbl_Idx; 08244 IL_IDX(second_idx) = bnot_idx1; 08245 08246 NTR_IR_LIST_TBL(third_idx); 08247 IL_FLD(third_idx) = IR_Tbl_Idx; 08248 IL_IDX(third_idx) = bnot_idx; 08249 08250 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08251 IL_NEXT_LIST_IDX(second_idx) = third_idx; 08252 08253 csmg_idx = gen_ir(IL_Tbl_Idx, first_idx, 08254 Csmg_Opr, 08255 typeless_idx, 08256 line, column, 08257 NO_Tbl_Idx, NULL_IDX); 08258 08259 08260 NTR_IR_LIST_TBL(first_idx); 08261 IL_FLD(first_idx) = IR_Tbl_Idx; 08262 IL_IDX(first_idx) = csmg_idx; 08263 break; 08264 08265 08266 default: 08267 PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, 08268 IR_COL_NUM(ir_idx), 08269 "ibset_intrinsic"); 08270 break; 08271 } 08272 08273 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 08274 Minus_Opr, 08275 CG_INTEGER_DEFAULT_TYPE, 08276 line, column, 08277 CN_Tbl_Idx, cn_idx2); 08278 08279 NTR_IR_LIST_TBL(second_idx); 08280 IL_FLD(second_idx) = IR_Tbl_Idx; 08281 IL_IDX(second_idx) = minus_idx; 08282 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08283 08284 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 08285 Shiftl_Opr, 08286 typeless_idx, 08287 line, column, 08288 NO_Tbl_Idx, NULL_IDX); 08289 08290 NTR_IR_LIST_TBL(first_idx); 08291 IL_FLD(first_idx) = IR_Tbl_Idx; 08292 IL_IDX(first_idx) = shiftl_idx; 08293 08294 NTR_IR_LIST_TBL(second_idx); 08295 IL_FLD(second_idx) = IR_Tbl_Idx; 08296 IL_IDX(second_idx) = minus_idx; 08297 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08298 08299 shifta_idx = gen_ir(IL_Tbl_Idx, first_idx, 08300 Shifta_Opr, 08301 typeless_idx, 08302 line, column, 08303 NO_Tbl_Idx, NULL_IDX); 08304 08305 IR_OPR(ir_idx) = Cvrt_Opr; 08306 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 08307 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 08308 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 08309 IR_IDX_L(ir_idx) = shifta_idx; 08310 IR_OPND_R(ir_idx) = null_opnd; 08311 08312 if (fold_it) { 08313 COPY_OPND(opnd, (*result_opnd)); 08314 fold_aggragate_expression(&opnd, res_exp_desc, FALSE); 08315 COPY_OPND((*result_opnd), opnd); 08316 } 08317 08318 # endif 08319 res_exp_desc->foldable = FALSE; 08320 res_exp_desc->will_fold_later = FALSE; 08321 08322 08323 TRACE (Func_Exit, "ibset_intrinsic", NULL); 08324 08325 } /* ibset_intrinsic */ 08326 08327 08328 /******************************************************************************\ 08329 |* *| 08330 |* Description: *| 08331 |* Function ISHFT(I, SHIFT) intrinsic. *| 08332 |* Function ISHA(I, SHIFT) intrinsic. *| 08333 |* Function ISHL(I, SHIFT) intrinsic. *| 08334 |* *| 08335 |* Input parameters: *| 08336 |* NONE *| 08337 |* *| 08338 |* Output parameters: *| 08339 |* NONE *| 08340 |* *| 08341 |* Returns: *| 08342 |* NOTHING *| 08343 |* *| 08344 \******************************************************************************/ 08345 08346 void ishft_intrinsic(opnd_type *result_opnd, 08347 expr_arg_type *res_exp_desc, 08348 int *spec_idx) 08349 { 08350 int ir_idx; 08351 int gt_idx; 08352 int list_idx1; 08353 int list_idx2; 08354 int info_idx1; 08355 int info_idx2; 08356 int minus_idx; 08357 int first_idx; 08358 int second_idx; 08359 int third_idx; 08360 int shiftl_idx; 08361 int shiftr_idx; 08362 int shifta_idx; 08363 int shiftr_idx2; 08364 int cvmgt_idx; 08365 int typeless_idx; 08366 int cn_idx; 08367 operator_type opr; 08368 int cn_idx2; 08369 opnd_type opnd; 08370 boolean fold_it = FALSE; 08371 int line; 08372 int column; 08373 long num1; 08374 long num2; 08375 08376 08377 TRACE (Func_Entry, "ishft_intrinsic", NULL); 08378 08379 ir_idx = OPND_IDX((*result_opnd)); 08380 list_idx1 = IR_IDX_R(ir_idx); 08381 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 08382 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 08383 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 08384 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 08385 08386 if (ATP_INTRIN_ENUM(*spec_idx) == Isha_Intrinsic || 08387 ATP_INTRIN_ENUM(*spec_idx) == Iisha_Intrinsic || 08388 ATP_INTRIN_ENUM(*spec_idx) == Jisha_Intrinsic || 08389 ATP_INTRIN_ENUM(*spec_idx) == Kisha_Intrinsic) { 08390 opr = Shifta_Opr; 08391 } 08392 else { 08393 opr = Shiftr_Opr; 08394 } 08395 08396 line = IR_LINE_NUM(ir_idx); 08397 column = IR_COL_NUM(ir_idx); 08398 08399 if (arg_info_list[info_idx1].ed.type == Typeless) { 08400 PRINTMSG(arg_info_list[info_idx1].line, 1076, Ansi, 08401 arg_info_list[info_idx1].col); 08402 08403 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 08404 } 08405 08406 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_8) { 08407 typeless_idx = Typeless_8; 08408 } 08409 else { 08410 typeless_idx = TYPELESS_DEFAULT_TYPE; 08411 } 08412 08413 # ifdef _TARGET_OS_MAX 08414 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_1 || 08415 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_2 || 08416 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_4) { 08417 typeless_idx = Typeless_4; 08418 } 08419 # endif 08420 08421 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { 08422 switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) { 08423 case Integer_1: 08424 num1 = BITSIZE_INT1_F90; 08425 num2 = -BITSIZE_INT1_F90; 08426 break; 08427 08428 case Integer_2: 08429 num1 = BITSIZE_INT2_F90; 08430 num2 = -BITSIZE_INT2_F90; 08431 break; 08432 08433 case Integer_4: 08434 num1 = BITSIZE_INT4_F90; 08435 num2 = -BITSIZE_INT4_F90; 08436 break; 08437 08438 case Integer_8: 08439 num1 = BITSIZE_INT8_F90; 08440 num2 = -BITSIZE_INT8_F90; 08441 break; 08442 } 08443 08444 if (compare_cn_and_value(IL_IDX(list_idx2), num1, Gt_Opr) || 08445 compare_cn_and_value(IL_IDX(list_idx2), num2, Lt_Opr)) { 08446 PRINTMSG(arg_info_list[info_idx2].line, 1062, Error, 08447 arg_info_list[info_idx2].col); 08448 } 08449 } 08450 08451 conform_check(0, 08452 ir_idx, 08453 res_exp_desc, 08454 spec_idx, 08455 FALSE); 08456 08457 08458 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 08459 IR_RANK(ir_idx) = res_exp_desc->rank; 08460 08461 # if 0 08462 08463 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) != 08464 TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx)) { 08465 08466 /* cast arg 1 to the result type. */ 08467 08468 COPY_OPND(opnd, IL_OPND(list_idx1)); 08469 cast_to_type_idx(&opnd, 08470 &arg_info_list[info_idx1].ed, 08471 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 08472 COPY_OPND(IL_OPND(list_idx1), opnd); 08473 08474 } 08475 08476 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) != 08477 TYP_LINEAR(arg_info_list[info_idx2].ed.type_idx)) { 08478 08479 /* cast arg 2 to the result type. */ 08480 08481 COPY_OPND(opnd, IL_OPND(list_idx2)); 08482 cast_to_type_idx(&opnd, 08483 &arg_info_list[info_idx2].ed, 08484 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 08485 COPY_OPND(IL_OPND(list_idx2), opnd); 08486 08487 } 08488 08489 if (opr == Shifta_Opr && 08490 IL_FLD(list_idx2) == CN_Tbl_Idx) { 08491 08492 if (CN_INT_TO_C(IL_IDX(list_idx2)) == -8 && 08493 arg_info_list[info_idx1].ed.linear_type == Integer_1) { 08494 cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, -7); 08495 IL_IDX(list_idx2) = cn_idx; 08496 } 08497 08498 else if (CN_INT_TO_C(IL_IDX(list_idx2)) == -16 && 08499 arg_info_list[info_idx1].ed.linear_type == Integer_2) { 08500 cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, -15); 08501 IL_IDX(list_idx2) = cn_idx; 08502 } 08503 08504 else if (CN_INT_TO_C(IL_IDX(list_idx2)) == -32 && 08505 arg_info_list[info_idx1].ed.linear_type == Integer_4) { 08506 cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, -31); 08507 IL_IDX(list_idx2) = cn_idx; 08508 } 08509 08510 else if (CN_INT_TO_C(IL_IDX(list_idx2)) == -64 && 08511 arg_info_list[info_idx1].ed.linear_type == Integer_8) { 08512 cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, -63); 08513 IL_IDX(list_idx2) = cn_idx; 08514 } 08515 } 08516 08517 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 08518 IL_FLD(list_idx2) == CN_Tbl_Idx) { 08519 fold_it = TRUE; 08520 } 08521 08522 num1 = register_bit_size_tbl[ 08523 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))]; 08524 08525 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num1); 08526 08527 switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) { 08528 case Integer_1: 08529 num1 = BITSIZE_INT1_F90; 08530 break; 08531 08532 case Integer_2: 08533 num1 = BITSIZE_INT2_F90; 08534 break; 08535 08536 case Integer_4: 08537 num1 = BITSIZE_INT4_F90; 08538 break; 08539 08540 case Integer_8: 08541 num1 = BITSIZE_INT8_F90; 08542 break; 08543 } 08544 08545 cn_idx2 = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num1); 08546 08547 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 08548 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, column, 08549 CN_Tbl_Idx, cn_idx2); 08550 08551 NTR_IR_LIST_TBL(first_idx); 08552 COPY_OPND(IL_OPND(first_idx), IL_OPND(list_idx1)); 08553 NTR_IR_LIST_TBL(second_idx); 08554 IL_FLD(second_idx) = IR_Tbl_Idx; 08555 IL_IDX(second_idx) = minus_idx; 08556 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08557 08558 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 08559 Shiftl_Opr, typeless_idx, line, column, 08560 NO_Tbl_Idx, NULL_IDX); 08561 08562 NTR_IR_LIST_TBL(first_idx); 08563 IL_FLD(first_idx) = IR_Tbl_Idx; 08564 IL_IDX(first_idx) = shiftl_idx; 08565 NTR_IR_LIST_TBL(second_idx); 08566 IL_FLD(second_idx) = IR_Tbl_Idx; 08567 IL_IDX(second_idx) = minus_idx; 08568 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08569 08570 shiftr_idx2 = gen_ir(IL_Tbl_Idx, first_idx, 08571 opr, typeless_idx, line, column, 08572 NO_Tbl_Idx, NULL_IDX); 08573 08574 /* compute shiftl_idx */ 08575 NTR_IR_LIST_TBL(first_idx); 08576 IL_FLD(first_idx) = IR_Tbl_Idx; 08577 IL_IDX(first_idx) = shiftr_idx2; 08578 NTR_IR_LIST_TBL(second_idx); 08579 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx2)); 08580 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08581 08582 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 08583 Shiftl_Opr, typeless_idx, line, column, 08584 NO_Tbl_Idx, NULL_IDX); 08585 08586 /* compute shiftr_idx */ 08587 08588 COPY_OPND(opnd, IL_OPND(list_idx2)); 08589 copy_subtree(&opnd, &opnd); 08590 08591 minus_idx = gen_ir(CN_Tbl_Idx, CN_INTEGER_ZERO_IDX, 08592 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, column, 08593 OPND_FLD(opnd), OPND_IDX(opnd)); 08594 08595 NTR_IR_LIST_TBL(first_idx); 08596 IL_FLD(first_idx) = IR_Tbl_Idx; 08597 IL_IDX(first_idx) = shiftr_idx2; 08598 NTR_IR_LIST_TBL(second_idx); 08599 IL_FLD(second_idx) = IR_Tbl_Idx; 08600 IL_IDX(second_idx) = minus_idx; 08601 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08602 08603 shiftr_idx = gen_ir(IL_Tbl_Idx, first_idx, 08604 opr, typeless_idx, line, column, 08605 NO_Tbl_Idx, NULL_IDX); 08606 08607 /* compute the condition */ 08608 08609 COPY_OPND(opnd, IL_OPND(list_idx2)); 08610 copy_subtree(&opnd, &opnd); 08611 08612 gt_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 08613 Gt_Opr, LOGICAL_DEFAULT_TYPE, line, column, 08614 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 08615 08616 /* set up CVMGT */ 08617 NTR_IR_LIST_TBL(first_idx); 08618 IL_ARG_DESC_VARIANT(first_idx) = TRUE; 08619 IL_FLD(first_idx) = IR_Tbl_Idx; 08620 IL_IDX(first_idx) = shiftl_idx; 08621 08622 NTR_IR_LIST_TBL(second_idx); 08623 IL_ARG_DESC_VARIANT(second_idx) = TRUE; 08624 IL_FLD(second_idx) = IR_Tbl_Idx; 08625 IL_IDX(second_idx) = shiftr_idx; 08626 08627 NTR_IR_LIST_TBL(third_idx); 08628 IL_ARG_DESC_VARIANT(third_idx) = TRUE; 08629 IL_FLD(third_idx) = IR_Tbl_Idx; 08630 IL_IDX(third_idx) = gt_idx; 08631 08632 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08633 IL_NEXT_LIST_IDX(second_idx) = third_idx; 08634 08635 cvmgt_idx = gen_ir(IL_Tbl_Idx, first_idx, 08636 Cvmgt_Opr, typeless_idx, line, column, 08637 NO_Tbl_Idx, NULL_IDX); 08638 08639 /* set this flag so this opr is pulled off io lists */ 08640 io_item_must_flatten = TRUE; 08641 08642 if (fold_it) { 08643 if (compare_cn_and_value(IL_IDX(list_idx2), 0, Gt_Opr)) { 08644 cvmgt_idx = shiftl_idx; 08645 } 08646 else { 08647 cvmgt_idx = shiftr_idx; 08648 } 08649 } 08650 08651 num1 = register_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX( 08652 ATP_RSLT_IDX(*spec_idx)))]; 08653 08654 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num1); 08655 08656 switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) { 08657 case Integer_1: 08658 num1 = BITSIZE_INT1_F90; 08659 break; 08660 08661 case Integer_2: 08662 num1 = BITSIZE_INT2_F90; 08663 break; 08664 08665 case Integer_4: 08666 num1 = BITSIZE_INT4_F90; 08667 break; 08668 08669 case Integer_8: 08670 num1 = BITSIZE_INT8_F90; 08671 break; 08672 } 08673 08674 cn_idx2 = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num1); 08675 08676 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 08677 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, column, 08678 CN_Tbl_Idx, cn_idx2); 08679 08680 NTR_IR_LIST_TBL(first_idx); 08681 IL_FLD(first_idx) = IR_Tbl_Idx; 08682 IL_IDX(first_idx) = cvmgt_idx; 08683 NTR_IR_LIST_TBL(second_idx); 08684 IL_FLD(second_idx) = IR_Tbl_Idx; 08685 IL_IDX(second_idx) = minus_idx; 08686 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08687 08688 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 08689 Shiftl_Opr, typeless_idx, line, column, 08690 NO_Tbl_Idx, NULL_IDX); 08691 08692 NTR_IR_LIST_TBL(first_idx); 08693 IL_FLD(first_idx) = IR_Tbl_Idx; 08694 IL_IDX(first_idx) = shiftl_idx; 08695 NTR_IR_LIST_TBL(second_idx); 08696 IL_FLD(second_idx) = IR_Tbl_Idx; 08697 IL_IDX(second_idx) = minus_idx; 08698 IL_NEXT_LIST_IDX(first_idx) = second_idx; 08699 08700 shifta_idx = gen_ir(IL_Tbl_Idx, first_idx, 08701 Shifta_Opr, typeless_idx, line, column, 08702 NO_Tbl_Idx, NULL_IDX); 08703 08704 IR_OPR(ir_idx) = Cvrt_Opr; 08705 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 08706 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 08707 IR_IDX_L(ir_idx) = shifta_idx; 08708 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 08709 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 08710 IR_FLD_R(ir_idx) = NO_Tbl_Idx; 08711 IR_IDX_R(ir_idx) = NULL_IDX; 08712 08713 if (fold_it) { 08714 COPY_OPND(opnd, (*result_opnd)); 08715 fold_aggragate_expression(&opnd, res_exp_desc, FALSE); 08716 COPY_OPND((*result_opnd), opnd); 08717 } 08718 08719 # endif 08720 08721 res_exp_desc->foldable = FALSE; 08722 res_exp_desc->will_fold_later = FALSE; 08723 08724 08725 TRACE (Func_Exit, "ishft_intrinsic", NULL); 08726 08727 } /* ishft_intrinsic */ 08728 08729 08730 /******************************************************************************\ 08731 |* *| 08732 |* Description: *| 08733 |* Function ISHFTC(I, SHIFT, SIZE) intrinsic. *| 08734 |* Function ISHC(I, SHIFT) intrinsic. *| 08735 |* *| 08736 |* Input parameters: *| 08737 |* NONE *| 08738 |* *| 08739 |* Output parameters: *| 08740 |* NONE *| 08741 |* *| 08742 |* Returns: *| 08743 |* NOTHING *| 08744 |* *| 08745 \******************************************************************************/ 08746 08747 void ishftc_intrinsic(opnd_type *result_opnd, 08748 expr_arg_type *res_exp_desc, 08749 int *spec_idx) 08750 { 08751 08752 # if !(defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 08753 int ishft2_idx; 08754 int minus_idx; 08755 int uminus_idx; 08756 int shift_idx; 08757 int shiftl_idx; 08758 int shifta_idx; 08759 int mask_idx; 08760 int sign_idx; 08761 int csmg_idx; 08762 int abs_idx; 08763 int ior_idx; 08764 int plus_idx; 08765 int band_idx; 08766 int band1_idx; 08767 int first_idx; 08768 int second_idx; 08769 int third_idx; 08770 int cn_idx2; 08771 opnd_type save_opnd; 08772 int line; 08773 int column; 08774 int ishft1_idx; 08775 # endif 08776 08777 int cn_idx; 08778 boolean fold_it = FALSE; 08779 int ir_idx; 08780 int list_idx1; 08781 int list_idx2; 08782 int list_idx3; 08783 int info_idx1; 08784 int info_idx2; 08785 int info_idx3; 08786 long num; 08787 opnd_type opnd; 08788 int typeless_idx; 08789 08790 08791 TRACE (Func_Entry, "ishftc_intrinsic", NULL); 08792 08793 ir_idx = OPND_IDX((*result_opnd)); 08794 list_idx1 = IR_IDX_R(ir_idx); 08795 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 08796 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 08797 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 08798 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 08799 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 08800 08801 if (arg_info_list[info_idx1].ed.type == Typeless) { 08802 PRINTMSG(arg_info_list[info_idx1].line, 1076, Ansi, 08803 arg_info_list[info_idx1].col); 08804 08805 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 08806 } 08807 08808 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_8) { 08809 typeless_idx = Typeless_8; 08810 } 08811 else { 08812 typeless_idx = TYPELESS_DEFAULT_TYPE; 08813 } 08814 08815 # ifdef _TARGET_OS_MAX 08816 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_1 || 08817 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_2 || 08818 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_4) { 08819 typeless_idx = Typeless_4; 08820 } 08821 # endif 08822 08823 conform_check(3, 08824 ir_idx, 08825 res_exp_desc, 08826 spec_idx, 08827 FALSE); 08828 08829 08830 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 08831 IR_RANK(ir_idx) = res_exp_desc->rank; 08832 08833 # if 0 08834 08835 switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) { 08836 case Integer_1: 08837 num = BITSIZE_INT1_F90; 08838 break; 08839 08840 case Integer_2: 08841 num = BITSIZE_INT2_F90; 08842 break; 08843 08844 case Integer_4: 08845 num = BITSIZE_INT4_F90; 08846 break; 08847 08848 case Integer_8: 08849 num = BITSIZE_INT8_F90; 08850 break; 08851 } 08852 08853 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 08854 08855 if (ATP_INTRIN_ENUM(*spec_idx) != Ishc_Intrinsic && 08856 ATP_INTRIN_ENUM(*spec_idx) != Iishc_Intrinsic && 08857 ATP_INTRIN_ENUM(*spec_idx) != Jishc_Intrinsic && 08858 ATP_INTRIN_ENUM(*spec_idx) != Kishc_Intrinsic) { 08859 if (IL_IDX(list_idx3) == NULL_IDX) { 08860 IL_FLD(list_idx3) = CN_Tbl_Idx; 08861 IL_IDX(list_idx3) = cn_idx; 08862 IL_LINE_NUM(list_idx3) = IR_LINE_NUM(ir_idx); 08863 IL_COL_NUM(list_idx3) = IR_COL_NUM(ir_idx); 08864 08865 arg_info_list_base = arg_info_list_top; 08866 arg_info_list_top = arg_info_list_base + 1; 08867 08868 if (arg_info_list_top >= arg_info_list_size) { 08869 enlarge_info_list_table(); 08870 } 08871 08872 IL_ARG_DESC_IDX(list_idx3) = arg_info_list_top; 08873 arg_info_list[arg_info_list_top] = init_arg_info; 08874 arg_info_list[arg_info_list_top].ed.type_idx = 08875 CG_INTEGER_DEFAULT_TYPE; 08876 arg_info_list[arg_info_list_top].ed.type = Integer; 08877 arg_info_list[arg_info_list_top].ed.linear_type = 08878 CG_INTEGER_DEFAULT_TYPE; 08879 arg_info_list[arg_info_list_top].line = IR_LINE_NUM(ir_idx); 08880 arg_info_list[arg_info_list_top].col = IR_COL_NUM(ir_idx); 08881 08882 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 08883 } 08884 else { 08885 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 08886 } 08887 } 08888 else { 08889 NTR_IR_LIST_TBL(list_idx3); 08890 IL_FLD(list_idx3) = CN_Tbl_Idx; 08891 IL_IDX(list_idx3) = cn_idx; 08892 IL_LINE_NUM(list_idx3) = IR_LINE_NUM(ir_idx); 08893 IL_COL_NUM(list_idx3) = IR_COL_NUM(ir_idx); 08894 IL_NEXT_LIST_IDX(list_idx2) = list_idx3; 08895 IR_LIST_CNT_R(ir_idx) = 3; 08896 } 08897 08898 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) != 08899 TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx)) { 08900 08901 /* cast arg 1 to the result type. */ 08902 08903 COPY_OPND(opnd, IL_OPND(list_idx1)); 08904 cast_to_type_idx(&opnd, 08905 &arg_info_list[info_idx1].ed, 08906 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 08907 COPY_OPND(IL_OPND(list_idx1), opnd); 08908 } 08909 08910 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) != 08911 TYP_LINEAR(arg_info_list[info_idx2].ed.type_idx)) { 08912 08913 /* cast arg 2 to the result type. */ 08914 08915 COPY_OPND(opnd, IL_OPND(list_idx2)); 08916 cast_to_type_idx(&opnd, 08917 &arg_info_list[info_idx2].ed, 08918 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 08919 COPY_OPND(IL_OPND(list_idx2), opnd); 08920 } 08921 08922 if (ATP_INTRIN_ENUM(*spec_idx) != Ishc_Intrinsic && 08923 ATP_INTRIN_ENUM(*spec_idx) != Iishc_Intrinsic && 08924 ATP_INTRIN_ENUM(*spec_idx) != Jishc_Intrinsic && 08925 ATP_INTRIN_ENUM(*spec_idx) != Kishc_Intrinsic) { 08926 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) != 08927 TYP_LINEAR(arg_info_list[info_idx3].ed.type_idx)) { 08928 08929 /* cast arg 3 to the result type. */ 08930 08931 COPY_OPND(opnd, IL_OPND(list_idx3)); 08932 cast_to_type_idx(&opnd, 08933 &arg_info_list[info_idx3].ed, 08934 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 08935 COPY_OPND(IL_OPND(list_idx3), opnd); 08936 } 08937 08938 if (IL_FLD(list_idx3) == CN_Tbl_Idx) { 08939 if (compare_cn_and_value(IL_IDX(list_idx3), num, Gt_Opr)) { 08940 PRINTMSG(arg_info_list[info_idx3].line, 1062, Error, 08941 arg_info_list[info_idx3].col); 08942 } 08943 } 08944 } 08945 08946 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 08947 IL_FLD(list_idx2) == CN_Tbl_Idx && 08948 IL_FLD(list_idx3) == CN_Tbl_Idx) { 08949 fold_it = TRUE; 08950 } 08951 08952 # if defined(GENERATE_WHIRL) 08953 08954 IR_OPR(ir_idx) = Ishftc_Opr; 08955 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 08956 IR_OPND_R(ir_idx) = null_opnd; 08957 08958 # else 08959 08960 line = IR_LINE_NUM(ir_idx); 08961 column = IR_COL_NUM(ir_idx); 08962 08963 /* start computing band1_idx */ 08964 08965 num = storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX( 08966 ATP_RSLT_IDX(*spec_idx)))] * 2; 08967 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 08968 08969 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 08970 Minus_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 08971 IL_FLD(list_idx3), IL_IDX(list_idx3)); 08972 08973 mask_idx = gen_ir(IR_Tbl_Idx, minus_idx, 08974 Mask_Opr, typeless_idx, line, column, 08975 NO_Tbl_Idx, NULL_IDX); 08976 08977 COPY_OPND(opnd, IL_OPND(list_idx1)); 08978 cast_opnd_to_type_idx(&opnd, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 08979 COPY_OPND(IL_OPND(list_idx1), opnd); 08980 08981 band1_idx = gen_ir(IR_Tbl_Idx, mask_idx, 08982 Band_Opr, typeless_idx, line, column, 08983 IL_FLD(list_idx1), IL_IDX(list_idx1)); 08984 08985 /* start computing ishft1_idx */ 08986 08987 num =storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))]; 08988 08989 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 08990 08991 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 08992 Minus_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 08993 IL_FLD(list_idx2), IL_IDX(list_idx2)); 08994 08995 mask_idx = gen_ir(IR_Tbl_Idx, minus_idx, 08996 Mask_Opr, typeless_idx, line, column, 08997 NO_Tbl_Idx, NULL_IDX); 08998 08999 num =storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))]; 09000 09001 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 09002 09003 COPY_OPND(opnd, IL_OPND(list_idx2)); 09004 copy_subtree(&opnd, &opnd); 09005 09006 plus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 09007 Plus_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 09008 OPND_FLD(opnd), OPND_IDX(opnd)); 09009 09010 num = storage_bit_size_tbl[TYP_LINEAR( 09011 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))] - 1; 09012 09013 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 09014 09015 band_idx = gen_ir(IR_Tbl_Idx, plus_idx, 09016 Band_Opr, typeless_idx, line, column, 09017 CN_Tbl_Idx, cn_idx); 09018 09019 NTR_IR_LIST_TBL(first_idx); 09020 IL_FLD(first_idx) = IR_Tbl_Idx; 09021 IL_IDX(first_idx) = band1_idx; 09022 NTR_IR_LIST_TBL(second_idx); 09023 IL_FLD(second_idx) = IR_Tbl_Idx; 09024 IL_IDX(second_idx) = band_idx; 09025 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09026 09027 shift_idx = gen_ir(IL_Tbl_Idx, first_idx, 09028 Shift_Opr, typeless_idx, line, column, 09029 NO_Tbl_Idx, NULL_IDX); 09030 09031 ishft1_idx = gen_ir(IR_Tbl_Idx, shift_idx, 09032 Band_Opr, typeless_idx, line, column, 09033 IR_Tbl_Idx, mask_idx); 09034 09035 /* start computing sign_idx */ 09036 09037 COPY_OPND(opnd, IL_OPND(list_idx2)); 09038 copy_subtree(&opnd, &opnd); 09039 09040 abs_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 09041 Abs_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 09042 NO_Tbl_Idx, NULL_IDX); 09043 09044 COPY_OPND(opnd, IL_OPND(list_idx3)); 09045 copy_subtree(&opnd, &opnd); 09046 09047 minus_idx = gen_ir(IR_Tbl_Idx, abs_idx, 09048 Minus_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 09049 OPND_FLD(opnd), OPND_IDX(opnd)); 09050 09051 NTR_IR_LIST_TBL(first_idx); 09052 IL_FLD(first_idx) = IR_Tbl_Idx; 09053 IL_IDX(first_idx) = minus_idx; 09054 NTR_IR_LIST_TBL(second_idx); 09055 09056 COPY_OPND(opnd, IL_OPND(list_idx2)); 09057 copy_subtree(&opnd, &opnd); 09058 09059 COPY_OPND(IL_OPND(second_idx), opnd); 09060 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09061 09062 sign_idx = gen_ir(IL_Tbl_Idx, first_idx, 09063 Sign_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 09064 NO_Tbl_Idx, NULL_IDX); 09065 09066 uminus_idx = gen_ir(IR_Tbl_Idx, sign_idx, 09067 Uminus_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 09068 NO_Tbl_Idx, NULL_IDX); 09069 09070 /* start computing ishft2_idx */ 09071 09072 num =storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))]; 09073 09074 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 09075 09076 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 09077 Minus_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 09078 IR_Tbl_Idx, uminus_idx); 09079 09080 mask_idx = gen_ir(IR_Tbl_Idx, minus_idx, 09081 Mask_Opr, typeless_idx, line, column, 09082 NO_Tbl_Idx, NULL_IDX); 09083 09084 num = storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX( 09085 ATP_RSLT_IDX(*spec_idx)))]; 09086 09087 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 09088 09089 plus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 09090 Plus_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 09091 IR_Tbl_Idx, uminus_idx); 09092 09093 num = storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX( 09094 ATP_RSLT_IDX(*spec_idx)))] - 1; 09095 09096 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 09097 09098 band_idx = gen_ir(IR_Tbl_Idx, plus_idx, 09099 Band_Opr, typeless_idx, line, column, 09100 CN_Tbl_Idx, cn_idx); 09101 09102 NTR_IR_LIST_TBL(first_idx); 09103 IL_FLD(first_idx) = IR_Tbl_Idx; 09104 IL_IDX(first_idx) = band1_idx; 09105 NTR_IR_LIST_TBL(second_idx); 09106 IL_FLD(second_idx) = IR_Tbl_Idx; 09107 IL_IDX(second_idx) = band_idx; 09108 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09109 09110 shift_idx = gen_ir(IL_Tbl_Idx, first_idx, 09111 Shift_Opr, typeless_idx, line, column, 09112 NO_Tbl_Idx, NULL_IDX); 09113 09114 ishft2_idx = gen_ir(IR_Tbl_Idx, shift_idx, 09115 Band_Opr, typeless_idx, line, column, 09116 IR_Tbl_Idx, mask_idx); 09117 09118 /* OR together the two ishfts */ 09119 09120 ior_idx = gen_ir(IR_Tbl_Idx, ishft1_idx, 09121 Bor_Opr, typeless_idx, line, column, 09122 IR_Tbl_Idx, ishft2_idx); 09123 09124 /* compute third argument to CSMG */ 09125 09126 num =storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))]; 09127 09128 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 09129 09130 COPY_OPND(opnd, IL_OPND(list_idx3)); 09131 copy_subtree(&opnd, &opnd); 09132 09133 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 09134 Minus_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 09135 OPND_FLD(opnd), OPND_IDX(opnd)); 09136 09137 mask_idx = gen_ir(IR_Tbl_Idx, minus_idx, 09138 Mask_Opr, typeless_idx, line, column, 09139 NO_Tbl_Idx, NULL_IDX); 09140 09141 /* set up arguments */ 09142 09143 NTR_IR_LIST_TBL(first_idx); 09144 IL_ARG_DESC_VARIANT(first_idx) = TRUE; 09145 COPY_OPND(opnd, IL_OPND(list_idx1)); 09146 copy_subtree(&opnd, &opnd); 09147 COPY_OPND(IL_OPND(first_idx), opnd); 09148 09149 NTR_IR_LIST_TBL(second_idx); 09150 IL_ARG_DESC_VARIANT(second_idx) = TRUE; 09151 IL_FLD(second_idx) = IR_Tbl_Idx; 09152 IL_IDX(second_idx) = ior_idx; 09153 09154 NTR_IR_LIST_TBL(third_idx); 09155 IL_ARG_DESC_VARIANT(third_idx) = TRUE; 09156 IL_FLD(third_idx) = IR_Tbl_Idx; 09157 IL_IDX(third_idx) = mask_idx; 09158 09159 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09160 IL_NEXT_LIST_IDX(second_idx) = third_idx; 09161 09162 csmg_idx = gen_ir(IL_Tbl_Idx, first_idx, 09163 Csmg_Opr, typeless_idx, line, column, 09164 NO_Tbl_Idx, NULL_IDX); 09165 09166 num = storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX( 09167 ATP_RSLT_IDX(*spec_idx)))]; 09168 09169 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 09170 09171 switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) { 09172 case Integer_1: 09173 num = BITSIZE_INT1_F90; 09174 break; 09175 09176 case Integer_2: 09177 num = BITSIZE_INT2_F90; 09178 break; 09179 09180 case Integer_4: 09181 num = BITSIZE_INT4_F90; 09182 break; 09183 09184 case Integer_8: 09185 num = BITSIZE_INT8_F90; 09186 break; 09187 } 09188 09189 cn_idx2 = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 09190 09191 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 09192 Minus_Opr, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 09193 CN_Tbl_Idx, cn_idx2); 09194 09195 NTR_IR_LIST_TBL(first_idx); 09196 IL_FLD(first_idx) = IR_Tbl_Idx; 09197 IL_IDX(first_idx) = csmg_idx; 09198 NTR_IR_LIST_TBL(second_idx); 09199 IL_FLD(second_idx) = IR_Tbl_Idx; 09200 IL_IDX(second_idx) = minus_idx; 09201 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09202 09203 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 09204 Shiftl_Opr, typeless_idx, line, column, 09205 NO_Tbl_Idx, NULL_IDX); 09206 09207 NTR_IR_LIST_TBL(first_idx); 09208 IL_FLD(first_idx) = IR_Tbl_Idx; 09209 IL_IDX(first_idx) = shiftl_idx; 09210 NTR_IR_LIST_TBL(second_idx); 09211 IL_FLD(second_idx) = IR_Tbl_Idx; 09212 IL_IDX(second_idx) = minus_idx; 09213 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09214 09215 shifta_idx = gen_ir(IL_Tbl_Idx, first_idx, 09216 Shifta_Opr, typeless_idx, line, column, 09217 NO_Tbl_Idx, NULL_IDX); 09218 09219 IR_OPR(ir_idx) = Cvrt_Opr; 09220 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 09221 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 09222 IR_IDX_L(ir_idx) = shifta_idx; 09223 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 09224 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 09225 IR_OPND_R(ir_idx) = null_opnd; 09226 09227 # endif 09228 09229 if (fold_it) { 09230 COPY_OPND(opnd, (*result_opnd)); 09231 fold_aggragate_expression(&opnd, res_exp_desc, FALSE); 09232 COPY_OPND((*result_opnd), opnd); 09233 } 09234 09235 # endif 09236 09237 res_exp_desc->foldable = FALSE; 09238 res_exp_desc->will_fold_later = FALSE; 09239 09240 TRACE (Func_Exit, "ishftc_intrinsic", NULL); 09241 09242 } /* ishftc_intrinsic */ 09243 09244 09245 /******************************************************************************\ 09246 |* *| 09247 |* Description: *| 09248 |* Subroutine MVBITS(FROM, FROMPOS, LEN, TO, TOPOS) intrinsic. *| 09249 |* Subroutine IMVBITS(FROM, FROMPOS, LEN, TO, TOPOS) intrinsic. *| 09250 |* Subroutine JMVBITS(FROM, FROMPOS, LEN, TO, TOPOS) intrinsic. *| 09251 |* Subroutine KMVBITS(FROM, FROMPOS, LEN, TO, TOPOS) intrinsic. *| 09252 |* *| 09253 |* Input parameters: *| 09254 |* NONE *| 09255 |* *| 09256 |* Output parameters: *| 09257 |* NONE *| 09258 |* *| 09259 |* Returns: *| 09260 |* NOTHING *| 09261 |* *| 09262 \******************************************************************************/ 09263 09264 void mvbits_intrinsic(opnd_type *result_opnd, 09265 expr_arg_type *res_exp_desc, 09266 int *spec_idx) 09267 { 09268 int info_idx1; 09269 int info_idx2; 09270 int info_idx3; 09271 int info_idx4; 09272 int info_idx5; 09273 int ir_idx; 09274 int list_idx1; 09275 int list_idx2; 09276 int list_idx3; 09277 int list_idx4; 09278 int list_idx5; 09279 int mask_idx; 09280 int minus_idx; 09281 int shiftr_idx; 09282 int shiftl_idx; 09283 int shiftl1_idx; 09284 int shiftl2_idx; 09285 int csmg_idx; 09286 int band_idx; 09287 int first_idx; 09288 int second_idx; 09289 int third_idx; 09290 int cn_idx; 09291 int u_idx; 09292 int type_idx; 09293 int typeless_idx; 09294 opnd_type opnd; 09295 opnd_type left_hand_side_opnd; 09296 int line; 09297 int column; 09298 long num; 09299 09300 09301 TRACE (Func_Entry, "mvbits_intrinsic", NULL); 09302 09303 ir_idx = OPND_IDX((*result_opnd)); 09304 09305 conform_check(0, 09306 ir_idx, 09307 res_exp_desc, 09308 spec_idx, 09309 FALSE); 09310 09311 09312 list_idx1 = IR_IDX_R(ir_idx); 09313 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 09314 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 09315 list_idx4 = IL_NEXT_LIST_IDX(list_idx3); 09316 list_idx5 = IL_NEXT_LIST_IDX(list_idx4); 09317 09318 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 09319 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 09320 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 09321 info_idx4 = IL_ARG_DESC_IDX(list_idx4); 09322 info_idx5 = IL_ARG_DESC_IDX(list_idx5); 09323 09324 if (TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx) != 09325 TYP_LINEAR(arg_info_list[info_idx4].ed.type_idx)) { 09326 PRINTMSG(arg_info_list[info_idx1].line, 727, Error, 09327 arg_info_list[info_idx1].col); 09328 } 09329 09330 if (arg_info_list[info_idx1].ed.linear_type == Integer_8 || 09331 arg_info_list[info_idx4].ed.linear_type == Integer_8) { 09332 type_idx = Integer_8; 09333 } 09334 else { 09335 type_idx = INTEGER_DEFAULT_TYPE; 09336 } 09337 09338 if (TYP_LINEAR(type_idx) == Integer_8) { 09339 typeless_idx = Typeless_8; 09340 } 09341 else { 09342 typeless_idx = TYPELESS_DEFAULT_TYPE; 09343 } 09344 09345 # ifdef _TARGET_OS_MAX 09346 if (TYP_LINEAR(type_idx) == Integer_1 || 09347 TYP_LINEAR(type_idx) == Integer_2 || 09348 TYP_LINEAR(type_idx) == Integer_4) { 09349 typeless_idx = Typeless_4; 09350 } 09351 # endif 09352 09353 if (res_exp_desc->rank != arg_info_list[info_idx4].ed.rank) { 09354 PRINTMSG(arg_info_list[info_idx4].line, 1093, Error, 09355 arg_info_list[info_idx4].col); 09356 } 09357 09358 # if 0 09359 09360 if (TYP_LINEAR(type_idx) != 09361 TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx)) { 09362 09363 /* cast arg 1 to the result type. */ 09364 09365 COPY_OPND(opnd, IL_OPND(list_idx1)); 09366 cast_to_type_idx(&opnd, 09367 &arg_info_list[info_idx1].ed, 09368 type_idx); 09369 COPY_OPND(IL_OPND(list_idx1), opnd); 09370 09371 } 09372 09373 if (TYP_LINEAR(type_idx) != 09374 TYP_LINEAR(arg_info_list[info_idx2].ed.type_idx)) { 09375 09376 /* cast arg 2 to the result type. */ 09377 09378 COPY_OPND(opnd, IL_OPND(list_idx2)); 09379 cast_to_type_idx(&opnd, 09380 &arg_info_list[info_idx2].ed, 09381 type_idx); 09382 COPY_OPND(IL_OPND(list_idx2), opnd); 09383 09384 } 09385 09386 if (TYP_LINEAR(type_idx) != 09387 TYP_LINEAR(arg_info_list[info_idx3].ed.type_idx)) { 09388 09389 /* cast arg 3 to the result type. */ 09390 09391 COPY_OPND(opnd, IL_OPND(list_idx3)); 09392 cast_to_type_idx(&opnd, 09393 &arg_info_list[info_idx3].ed, 09394 type_idx); 09395 COPY_OPND(IL_OPND(list_idx3), opnd); 09396 09397 } 09398 09399 /* save the original arg 4 for the left side of assignment. */ 09400 09401 COPY_OPND(left_hand_side_opnd, IL_OPND(list_idx4)); 09402 09403 if (TYP_LINEAR(type_idx) != 09404 TYP_LINEAR(arg_info_list[info_idx4].ed.type_idx)) { 09405 09406 /* cast arg 4 to the result type. */ 09407 09408 COPY_OPND(opnd, IL_OPND(list_idx4)); 09409 cast_to_type_idx(&opnd, 09410 &arg_info_list[info_idx4].ed, 09411 type_idx); 09412 COPY_OPND(IL_OPND(list_idx4), opnd); 09413 09414 } 09415 09416 if (TYP_LINEAR(type_idx) != 09417 TYP_LINEAR(arg_info_list[info_idx5].ed.type_idx)) { 09418 09419 /* cast arg 5 to the result type. */ 09420 09421 COPY_OPND(opnd, IL_OPND(list_idx5)); 09422 cast_to_type_idx(&opnd, 09423 &arg_info_list[info_idx5].ed, 09424 type_idx); 09425 COPY_OPND(IL_OPND(list_idx5), opnd); 09426 09427 } 09428 09429 line = IR_LINE_NUM(ir_idx); 09430 column = IR_COL_NUM(ir_idx); 09431 09432 /* start computing band_idx */ 09433 09434 num = storage_bit_size_tbl[TYP_LINEAR(typeless_idx)] * 2; 09435 cn_idx = C_INT_TO_CN(type_idx, num); 09436 09437 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 09438 Minus_Opr, type_idx, line, column, 09439 IL_FLD(list_idx3), IL_IDX(list_idx3)); 09440 09441 mask_idx = gen_ir(IR_Tbl_Idx, minus_idx, 09442 Mask_Opr, typeless_idx, line, column, 09443 NO_Tbl_Idx, NULL_IDX); 09444 09445 NTR_IR_LIST_TBL(first_idx); 09446 IL_FLD(first_idx) = IR_Tbl_Idx; 09447 IL_IDX(first_idx) = mask_idx; 09448 NTR_IR_LIST_TBL(second_idx); 09449 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx5)); 09450 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09451 09452 shiftl1_idx = gen_ir(IL_Tbl_Idx, first_idx, 09453 Shiftl_Opr, typeless_idx, line, column, 09454 NO_Tbl_Idx, NULL_IDX); 09455 09456 /* compute shiftl2_idx */ 09457 NTR_IR_LIST_TBL(first_idx); 09458 IL_FLD(first_idx) = IR_Tbl_Idx; 09459 IL_IDX(first_idx) = mask_idx; 09460 NTR_IR_LIST_TBL(second_idx); 09461 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx2)); 09462 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09463 09464 shiftl2_idx = gen_ir(IL_Tbl_Idx, first_idx, 09465 Shiftl_Opr, typeless_idx, line, column, 09466 NO_Tbl_Idx, NULL_IDX); 09467 09468 band_idx = gen_ir(IR_Tbl_Idx, shiftl2_idx, 09469 Band_Opr, typeless_idx, line, column, 09470 IL_FLD(list_idx1), IL_IDX(list_idx1)); 09471 09472 NTR_IR_LIST_TBL(first_idx); 09473 IL_FLD(first_idx) = IR_Tbl_Idx; 09474 IL_IDX(first_idx) = band_idx; 09475 NTR_IR_LIST_TBL(second_idx); 09476 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx2)); 09477 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09478 09479 shiftr_idx = gen_ir(IL_Tbl_Idx, first_idx, 09480 Shiftr_Opr, typeless_idx, line, column, 09481 NO_Tbl_Idx, NULL_IDX); 09482 09483 NTR_IR_LIST_TBL(first_idx); 09484 IL_FLD(first_idx) = IR_Tbl_Idx; 09485 IL_IDX(first_idx) = shiftr_idx; 09486 NTR_IR_LIST_TBL(second_idx); 09487 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx5)); 09488 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09489 09490 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 09491 Shiftl_Opr, typeless_idx, line, column, 09492 NO_Tbl_Idx, NULL_IDX); 09493 09494 /* set up arguments to CSMG */ 09495 09496 NTR_IR_LIST_TBL(first_idx); 09497 IL_ARG_DESC_VARIANT(first_idx) = TRUE; 09498 IL_FLD(first_idx) = IR_Tbl_Idx; 09499 IL_IDX(first_idx) = shiftl_idx; 09500 09501 NTR_IR_LIST_TBL(second_idx); 09502 IL_ARG_DESC_VARIANT(second_idx) = TRUE; 09503 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx4)); 09504 09505 NTR_IR_LIST_TBL(third_idx); 09506 IL_ARG_DESC_VARIANT(third_idx) = TRUE; 09507 IL_FLD(third_idx) = IR_Tbl_Idx; 09508 IL_IDX(third_idx) = shiftl1_idx; 09509 09510 IL_NEXT_LIST_IDX(first_idx) = second_idx; 09511 IL_NEXT_LIST_IDX(second_idx) = third_idx; 09512 09513 csmg_idx = gen_ir(IL_Tbl_Idx, first_idx, 09514 Csmg_Opr, typeless_idx, line, column, 09515 NO_Tbl_Idx, NULL_IDX); 09516 09517 u_idx = gen_ir(IR_Tbl_Idx, csmg_idx, 09518 Cvrt_Unsigned_Opr, type_idx, line, column, 09519 NO_Tbl_Idx, NULL_IDX); 09520 09521 IR_OPR(ir_idx) = Asg_Opr; 09522 # if defined(GENERATE_WHIRL) 09523 IR_OPR(ir_idx) = Mvbits_Opr; 09524 # else 09525 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 09526 IR_IDX_R(ir_idx) = u_idx; 09527 # endif 09528 09529 IR_TYPE_IDX(ir_idx) = type_idx; 09530 COPY_OPND(IR_OPND_L(ir_idx), left_hand_side_opnd); 09531 09532 /* must reset foldable and will_fold_later because there is no */ 09533 /* folder for this intrinsic in constructors. */ 09534 09535 # endif 09536 09537 res_exp_desc->foldable = FALSE; 09538 res_exp_desc->will_fold_later = FALSE; 09539 09540 TRACE (Func_Exit, "mvbits_intrinsic", NULL); 09541 09542 } /* mvbits_intrinsic */ 09543 09544 09545 /******************************************************************************\ 09546 |* *| 09547 |* Description: *| 09548 |* Subroutine EXIT(STATUS) intrinsic. *| 09549 |* *| 09550 |* Input parameters: *| 09551 |* NONE *| 09552 |* *| 09553 |* Output parameters: *| 09554 |* NONE *| 09555 |* *| 09556 |* Returns: *| 09557 |* NOTHING *| 09558 |* *| 09559 \******************************************************************************/ 09560 09561 void exit_intrinsic(opnd_type *result_opnd, 09562 expr_arg_type *res_exp_desc, 09563 int *spec_idx) 09564 { 09565 int ir_idx; 09566 09567 09568 TRACE (Func_Entry, "exit_intrinsic", NULL); 09569 09570 ir_idx = OPND_IDX((*result_opnd)); 09571 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 09572 09573 /* must reset foldable and will_fold_later because there is no */ 09574 /* folder for this intrinsic in constructors. */ 09575 09576 res_exp_desc->foldable = FALSE; 09577 res_exp_desc->will_fold_later = FALSE; 09578 09579 TRACE (Func_Exit, "exit_intrinsic", NULL); 09580 09581 } /* exit_intrinsic */ 09582 09583 09584 09585 /******************************************************************************\ 09586 |* *| 09587 |* Description: *| 09588 |* Subroutine SYSTEM_CLOCK(COUNT, COUNT_RATE, COUNT_MAX) intrinsic. *| 09589 |* *| 09590 |* Input parameters: *| 09591 |* NONE *| 09592 |* *| 09593 |* Output parameters: *| 09594 |* NONE *| 09595 |* *| 09596 |* Returns: *| 09597 |* NOTHING *| 09598 |* *| 09599 \******************************************************************************/ 09600 09601 void system_clock_intrinsic(opnd_type *result_opnd, 09602 expr_arg_type *res_exp_desc, 09603 int *spec_idx) 09604 { 09605 int ir_idx; 09606 int info_idx1; 09607 int info_idx2; 09608 int info_idx3; 09609 int list_idx1; 09610 int list_idx2; 09611 int list_idx3; 09612 09613 09614 TRACE (Func_Entry, "system_clock_intrinsic", NULL); 09615 09616 ir_idx = OPND_IDX((*result_opnd)); 09617 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 09618 09619 list_idx1 = IR_IDX_R(ir_idx); 09620 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 09621 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 09622 09623 if ((list_idx3 != NULL_IDX) && (IL_IDX(list_idx3) != NULL_IDX)) { 09624 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 09625 if (arg_info_list[info_idx3].ed.type_idx != INTEGER_DEFAULT_TYPE) { 09626 PRINTMSG(arg_info_list[info_idx3].line, 1533, Error, 09627 arg_info_list[info_idx3].col); 09628 } 09629 } 09630 09631 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 09632 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 09633 if (arg_info_list[info_idx2].ed.type_idx != INTEGER_DEFAULT_TYPE) { 09634 PRINTMSG(arg_info_list[info_idx2].line, 1533, Error, 09635 arg_info_list[info_idx2].col); 09636 } 09637 } 09638 09639 if ((list_idx1 != NULL_IDX) && (IL_IDX(list_idx1) != NULL_IDX)) { 09640 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 09641 if (arg_info_list[info_idx1].ed.type_idx != INTEGER_DEFAULT_TYPE) { 09642 PRINTMSG(arg_info_list[info_idx1].line, 1533, Error, 09643 arg_info_list[info_idx1].col); 09644 } 09645 } 09646 09647 /* must reset foldable and will_fold_later because there is no */ 09648 /* folder for this intrinsic in constructors. */ 09649 09650 res_exp_desc->foldable = FALSE; 09651 res_exp_desc->will_fold_later = FALSE; 09652 09653 TRACE (Func_Exit, "system_clock_intrinsic", NULL); 09654 09655 } /* system_clock_intrinsic */ 09656 09657 09658 09659 /******************************************************************************\ 09660 |* *| 09661 |* Description: *| 09662 |* Subroutine IDATE(I, J, K) intrinsic. *| 09663 |* *| 09664 |* Input parameters: *| 09665 |* NONE *| 09666 |* *| 09667 |* Output parameters: *| 09668 |* NONE *| 09669 |* *| 09670 |* Returns: *| 09671 |* NOTHING *| 09672 |* *| 09673 \******************************************************************************/ 09674 09675 void idate_intrinsic(opnd_type *result_opnd, 09676 expr_arg_type *res_exp_desc, 09677 int *spec_idx) 09678 { 09679 int ir_idx; 09680 int info_idx1; 09681 int info_idx2; 09682 int info_idx3; 09683 int list_idx1; 09684 int list_idx2; 09685 int list_idx3; 09686 09687 TRACE (Func_Entry, "idate_intrinsic", NULL); 09688 09689 ir_idx = OPND_IDX((*result_opnd)); 09690 09691 list_idx1 = IR_IDX_R(ir_idx); 09692 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 09693 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 09694 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 09695 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 09696 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 09697 09698 if (IL_FLD(list_idx1) == CN_Tbl_Idx) { 09699 PRINTMSG(arg_info_list[info_idx1].line, 1650, Error, 09700 arg_info_list[info_idx1].col); 09701 } 09702 09703 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { 09704 PRINTMSG(arg_info_list[info_idx2].line, 1650, Error, 09705 arg_info_list[info_idx2].col); 09706 } 09707 09708 if (IL_FLD(list_idx3) == CN_Tbl_Idx) { 09709 PRINTMSG(arg_info_list[info_idx3].line, 1650, Error, 09710 arg_info_list[info_idx3].col); 09711 } 09712 09713 09714 /* must reset foldable and will_fold_later because there is no */ 09715 /* folder for this intrinsic in constructors. */ 09716 09717 res_exp_desc->foldable = FALSE; 09718 res_exp_desc->will_fold_later = FALSE; 09719 09720 TRACE (Func_Exit, "idate_intrinsic", NULL); 09721 09722 } /* idate_intrinsic */ 09723 09724 09725 09726 /******************************************************************************\ 09727 |* *| 09728 |* Description: *| 09729 |* Subroutine RANDOM_SEED(SIZE, PUT, GET) intrinsic. *| 09730 |* *| 09731 |* Input parameters: *| 09732 |* NONE *| 09733 |* *| 09734 |* Output parameters: *| 09735 |* NONE *| 09736 |* *| 09737 |* Returns: *| 09738 |* NOTHING *| 09739 |* *| 09740 \******************************************************************************/ 09741 09742 void random_seed_intrinsic(opnd_type *result_opnd, 09743 expr_arg_type *res_exp_desc, 09744 int *spec_idx) 09745 { 09746 int ir_idx; 09747 int cn_idx; 09748 int info_idx1; 09749 int info_idx2; 09750 int info_idx3; 09751 int list_idx1; 09752 int list_idx2; 09753 int list_idx3; 09754 int loc_idx; 09755 int ranget_idx; 09756 int ranset_idx; 09757 int ranf_idx; 09758 int tmp_attr; 09759 int unused1 = NULL_IDX; 09760 int unused2 = NULL_IDX; 09761 opnd_type old_opnd; 09762 opnd_type base_opnd; 09763 int line; 09764 int column; 09765 09766 09767 TRACE (Func_Entry, "random_seed_intrinsic", NULL); 09768 09769 ir_idx = OPND_IDX((*result_opnd)); 09770 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 09771 09772 line = IR_LINE_NUM(ir_idx); 09773 column = IR_COL_NUM(ir_idx); 09774 09775 list_idx1 = IR_IDX_R(ir_idx); 09776 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 09777 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 09778 09779 if (((IL_IDX(list_idx1) != NULL_IDX) && 09780 (IL_IDX(list_idx2) != NULL_IDX)) || 09781 ((IL_IDX(list_idx1) != NULL_IDX) && 09782 (IL_IDX(list_idx3) != NULL_IDX)) || 09783 ((IL_IDX(list_idx2) != NULL_IDX) && 09784 (IL_IDX(list_idx3) != NULL_IDX))) { 09785 PRINTMSG(IR_LINE_NUM(ir_idx), 830, Error, 09786 IR_COL_NUM(ir_idx)); 09787 } 09788 09789 09790 if ((list_idx3 != NULL_IDX) && (IL_IDX(list_idx3) != NULL_IDX)) { 09791 09792 COPY_OPND(old_opnd, IL_OPND(list_idx3)); 09793 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 09794 09795 if (IL_FLD(list_idx3) == CN_Tbl_Idx) { 09796 PRINTMSG(arg_info_list[info_idx3].line, 1214, Error, 09797 arg_info_list[info_idx3].col); 09798 } 09799 09800 09801 if (! arg_info_list[info_idx3].ed.reference && 09802 ! arg_info_list[info_idx3].ed.tmp_reference) { 09803 09804 # if 0 09805 09806 tmp_attr = create_tmp_asg(&old_opnd, 09807 (expr_arg_type *)&(arg_info_list[info_idx3].ed), 09808 &base_opnd, 09809 Intent_In, 09810 TRUE, 09811 FALSE); 09812 09813 COPY_OPND(old_opnd, base_opnd); 09814 # endif 09815 09816 } 09817 09818 if (arg_info_list[info_idx3].ed.rank > 0) { 09819 /* make_base_subtree(&old_opnd, &base_opnd, &unused1, &unused2); */ 09820 } 09821 else { 09822 /* COPY_OPND(base_opnd, old_opnd); */ 09823 } 09824 09825 # if 0 09826 loc_idx = gen_ir(OPND_FLD(base_opnd), OPND_IDX(base_opnd), 09827 Aloc_Opr, CRI_Ptr_8, line, column, 09828 NO_Tbl_Idx, NULL_IDX); 09829 09830 ranget_idx = gen_ir(IR_Tbl_Idx, loc_idx, 09831 Ranget_Opr, TYPELESS_DEFAULT_TYPE, line, column, 09832 NO_Tbl_Idx, NULL_IDX); 09833 09834 IR_OPR(ir_idx) = Asg_Opr; 09835 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(loc_idx)); 09836 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 09837 IR_IDX_R(ir_idx) = ranget_idx; 09838 IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx); 09839 IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx); 09840 09841 # endif 09842 09843 } 09844 else if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 09845 09846 COPY_OPND(old_opnd, IL_OPND(list_idx2)); 09847 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 09848 09849 if (! arg_info_list[info_idx2].ed.reference && 09850 ! arg_info_list[info_idx2].ed.tmp_reference) { 09851 09852 # if 0 09853 09854 tmp_attr = create_tmp_asg(&old_opnd, 09855 (expr_arg_type *)&(arg_info_list[info_idx2].ed), 09856 &base_opnd, 09857 Intent_In, 09858 TRUE, 09859 FALSE); 09860 09861 COPY_OPND(old_opnd, base_opnd); 09862 # endif 09863 } 09864 09865 if (arg_info_list[info_idx2].ed.rank > 0) { 09866 /* make_base_subtree(&old_opnd, &base_opnd, &unused1, &unused2); */ 09867 } 09868 else { 09869 /* COPY_OPND(base_opnd, old_opnd); */ 09870 } 09871 09872 # if 0 09873 09874 ranset_idx = gen_ir(OPND_FLD(base_opnd), OPND_IDX(base_opnd), 09875 Ranset_Opr, TYPELESS_DEFAULT_TYPE, line, column, 09876 NO_Tbl_Idx, NULL_IDX); 09877 09878 IR_OPR(ir_idx) = Asg_Opr; 09879 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(ranset_idx)); 09880 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 09881 IR_IDX_R(ir_idx) = ranset_idx; 09882 IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx); 09883 IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx); 09884 09885 # endif 09886 09887 } 09888 else if ((list_idx1 != NULL_IDX) && (IL_IDX(list_idx1) != NULL_IDX)) { 09889 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 09890 09891 if (IL_FLD(list_idx1) == CN_Tbl_Idx) { 09892 PRINTMSG(arg_info_list[info_idx1].line, 1214, Error, 09893 arg_info_list[info_idx1].col); 09894 } 09895 09896 # if 0 09897 09898 # if defined(GENERATE_WHIRL) 09899 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 64); 09900 # else 09901 cn_idx = CN_INTEGER_ONE_IDX; 09902 # endif 09903 09904 IR_OPR(ir_idx) = Asg_Opr; 09905 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx1)); 09906 IR_FLD_R(ir_idx) = CN_Tbl_Idx; 09907 IR_IDX_R(ir_idx) = cn_idx; 09908 IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx); 09909 IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx); 09910 09911 # endif 09912 09913 } 09914 else { 09915 09916 # if 0 09917 ranf_idx = gen_ir(NO_Tbl_Idx, NULL_IDX, 09918 Ranf_Opr, REAL_DEFAULT_TYPE, line, column, 09919 NO_Tbl_Idx, NULL_IDX); 09920 09921 tree_has_ranf = TRUE; 09922 09923 tmp_attr = gen_compiler_tmp(IR_LINE_NUM(ir_idx), 09924 IR_COL_NUM(ir_idx), 09925 Priv, TRUE); 09926 ATD_STOR_BLK_IDX(tmp_attr) = SCP_SB_STACK_IDX(curr_scp_idx); 09927 ATD_TYPE_IDX(tmp_attr) = REAL_DEFAULT_TYPE; 09928 AT_SEMANTICS_DONE(tmp_attr) = TRUE; 09929 09930 IR_OPR(ir_idx) = Asg_Opr; 09931 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 09932 IR_IDX_L(ir_idx) = tmp_attr; 09933 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 09934 IR_IDX_R(ir_idx) = ranf_idx; 09935 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 09936 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 09937 09938 # endif 09939 09940 } 09941 09942 /* must reset foldable and will_fold_later because there is no */ 09943 /* folder for this intrinsic in constructors. */ 09944 09945 res_exp_desc->foldable = FALSE; 09946 res_exp_desc->will_fold_later = FALSE; 09947 09948 TRACE (Func_Exit, "random_seed_intrinsic", NULL); 09949 09950 } /* random_seed_intrinsic */ 09951 09952 09953 /******************************************************************************\ 09954 |* *| 09955 |* Description: *| 09956 |* Subroutine GET_IEEE_STATUS(STATUS) intrinsic. *| 09957 |* Subroutine SET_IEEE_STATUS(STATUS) intrinsic. *| 09958 |* Subroutine GET_IEEE_EXCEPTIONS(STATUS) intrinsic. *| 09959 |* Subroutine SET_IEEE_EXCEPTIONS(STATUS) intrinsic. *| 09960 |* Subroutine GET_IEEE_INTERRUPTS(STATUS) intrinsic. *| 09961 |* Subroutine SET_IEEE_INTERRUPTS(STATUS) intrinsic. *| 09962 |* Subroutine GET_IEEE_ROUNDING_MODE(STATUS) intrinsic. *| 09963 |* Subroutine SET_IEEE_ROUNDING_MODE(STATUS) intrinsic. *| 09964 |* *| 09965 |* Input parameters: *| 09966 |* NONE *| 09967 |* *| 09968 |* Output parameters: *| 09969 |* NONE *| 09970 |* *| 09971 |* Returns: *| 09972 |* NOTHING *| 09973 |* *| 09974 \******************************************************************************/ 09975 09976 void get_ieee_status_intrinsic(opnd_type *result_opnd, 09977 expr_arg_type *res_exp_desc, 09978 int *spec_idx) 09979 { 09980 int idx; 09981 int idx1; 09982 int ir_idx; 09983 int info_idx1; 09984 int list_idx1; 09985 int line; 09986 int column; 09987 09988 09989 TRACE (Func_Entry, "get_ieee_status_intrinsic", NULL); 09990 09991 ir_idx = OPND_IDX((*result_opnd)); 09992 list_idx1 = IR_IDX_R(ir_idx); 09993 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 09994 09995 line = IR_LINE_NUM(ir_idx); 09996 column = IR_COL_NUM(ir_idx); 09997 09998 conform_check(0, 09999 ir_idx, 10000 res_exp_desc, 10001 spec_idx, 10002 FALSE); 10003 10004 # if 0 10005 10006 switch (ATP_INTRIN_ENUM(*spec_idx)) { 10007 10008 case Get_Ieee_Status_Intrinsic: 10009 IR_OPR(ir_idx) = Asg_Opr; 10010 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx1)); 10011 10012 NTR_IR_LIST_TBL(idx1); 10013 IL_FLD(idx1) = CN_Tbl_Idx; 10014 IL_IDX(idx1) = CN_INTEGER_ZERO_IDX; 10015 IL_LINE_NUM(idx1) = IR_LINE_NUM(ir_idx); 10016 IL_COL_NUM(idx1) = IR_COL_NUM(ir_idx); 10017 10018 idx = gen_ir(IL_Tbl_Idx, idx1, 10019 Get_Ieee_Status_Opr, arg_info_list[info_idx1].ed.type_idx, 10020 line, column, 10021 NO_Tbl_Idx, NULL_IDX); 10022 10023 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 10024 IR_IDX_R(ir_idx) = idx; 10025 break; 10026 10027 case Set_Ieee_Status_Intrinsic: 10028 IR_OPR(ir_idx) = Set_Ieee_Status_Opr; 10029 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10030 IR_IDX_R(ir_idx) = NULL_IDX; 10031 IR_FLD_R(ir_idx) = NO_Tbl_Idx; 10032 break; 10033 10034 case Get_Ieee_Exceptions_Intrinsic: 10035 IR_OPR(ir_idx) = Asg_Opr; 10036 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx1)); 10037 10038 idx = gen_ir(NO_Tbl_Idx, NULL_IDX, 10039 Get_Ieee_Exceptions_Opr, arg_info_list[info_idx1].ed.type_idx, 10040 line, column, 10041 NO_Tbl_Idx, NULL_IDX); 10042 10043 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 10044 IR_IDX_R(ir_idx) = idx; 10045 break; 10046 10047 case Set_Ieee_Exceptions_Intrinsic: 10048 IR_OPR(ir_idx) = Set_Ieee_Exceptions_Opr; 10049 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10050 IR_OPND_R(ir_idx) = null_opnd; 10051 break; 10052 10053 case Get_Ieee_Interrupts_Intrinsic: 10054 IR_OPR(ir_idx) = Asg_Opr; 10055 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx1)); 10056 10057 idx = gen_ir(NO_Tbl_Idx, NULL_IDX, 10058 Get_Ieee_Interrupts_Opr, arg_info_list[info_idx1].ed.type_idx, 10059 line, column, 10060 NO_Tbl_Idx, NULL_IDX); 10061 10062 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 10063 IR_IDX_R(ir_idx) = idx; 10064 break; 10065 10066 case Set_Ieee_Interrupts_Intrinsic: 10067 IR_OPR(ir_idx) = Set_Ieee_Interrupts_Opr; 10068 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10069 IR_OPND_R(ir_idx) = null_opnd; 10070 break; 10071 10072 case Get_Ieee_Rounding_Mode_Intrinsic: 10073 IR_OPR(ir_idx) = Asg_Opr; 10074 COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(list_idx1)); 10075 10076 idx = gen_ir(NO_Tbl_Idx, NULL_IDX, 10077 Get_Ieee_Rounding_Mode_Opr, 10078 arg_info_list[info_idx1].ed.type_idx, line, column, 10079 NO_Tbl_Idx, NULL_IDX); 10080 10081 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 10082 IR_IDX_R(ir_idx) = idx; 10083 break; 10084 10085 case Set_Ieee_Rounding_Mode_Intrinsic: 10086 IR_OPR(ir_idx) = Set_Ieee_Rounding_Mode_Opr; 10087 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10088 IR_OPND_R(ir_idx) = null_opnd; 10089 break; 10090 } 10091 10092 IR_TYPE_IDX(ir_idx) = arg_info_list[info_idx1].ed.type_idx; 10093 IR_RANK(ir_idx) = res_exp_desc->rank; 10094 10095 # endif 10096 10097 /* must reset foldable and will_fold_later because there is no */ 10098 /* folder for this intrinsic in constructors. */ 10099 10100 res_exp_desc->foldable = FALSE; 10101 res_exp_desc->will_fold_later = FALSE; 10102 10103 10104 TRACE (Func_Exit, "get_ieee_status_intrinsic", NULL); 10105 10106 } /* get_ieee_status_intrinsic */ 10107 10108 10109 /******************************************************************************\ 10110 |* *| 10111 |* Description: *| 10112 |* Function TEST_IEEE_INTERRUPT(INTERRUPT) intrinsic. *| 10113 |* Function TEST_IEEE_EXCEPTION(EXCEPTION) intrinsic. *| 10114 |* *| 10115 |* Input parameters: *| 10116 |* NONE *| 10117 |* *| 10118 |* Output parameters: *| 10119 |* NONE *| 10120 |* *| 10121 |* Returns: *| 10122 |* NOTHING *| 10123 |* *| 10124 \******************************************************************************/ 10125 10126 void test_ieee_interrupt_intrinsic(opnd_type *result_opnd, 10127 expr_arg_type *res_exp_desc, 10128 int *spec_idx) 10129 { 10130 int ir_idx; 10131 10132 10133 TRACE (Func_Entry, "test_ieee_interrupt_intrinsic", NULL); 10134 10135 ir_idx = OPND_IDX((*result_opnd)); 10136 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 10137 10138 conform_check(0, 10139 ir_idx, 10140 res_exp_desc, 10141 spec_idx, 10142 FALSE); 10143 10144 # if 0 10145 10146 switch (ATP_INTRIN_ENUM(*spec_idx)) { 10147 10148 case Test_Ieee_Interrupt_Intrinsic: 10149 IR_OPR(ir_idx) = Test_Ieee_Interrupt_Opr; 10150 break; 10151 10152 case Test_Ieee_Exception_Intrinsic: 10153 IR_OPR(ir_idx) = Test_Ieee_Exception_Opr; 10154 break; 10155 } 10156 10157 # endif 10158 10159 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 10160 IR_RANK(ir_idx) = res_exp_desc->rank; 10161 10162 #if 0 10163 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10164 IR_OPND_R(ir_idx) = null_opnd; 10165 #endif 10166 10167 /* must reset foldable and will_fold_later because there is no */ 10168 /* folder for this intrinsic in constructors. */ 10169 10170 res_exp_desc->foldable = FALSE; 10171 res_exp_desc->will_fold_later = FALSE; 10172 10173 10174 TRACE (Func_Exit, "test_ieee_interrupt_intrinsic", NULL); 10175 10176 } /* test_ieee_interrupt_intrinsic */ 10177 10178 10179 /******************************************************************************\ 10180 |* *| 10181 |* Description: *| 10182 |* Subroutine SET_IEEE_EXCEPTION(EXCEPTION) intrinsic. *| 10183 |* Subroutine CLEAR_IEEE_EXCEPTION(EXCEPTION) intrinsic. *| 10184 |* Subroutine ENABLE_IEEE_INTERRUPT(INTERRUPT) intrinsic. *| 10185 |* Subroutine DISABLE_IEEE_INTERRUPT(INTERRUPT) intrinsic. *| 10186 |* *| 10187 |* Input parameters: *| 10188 |* NONE *| 10189 |* *| 10190 |* Output parameters: *| 10191 |* NONE *| 10192 |* *| 10193 |* Returns: *| 10194 |* NOTHING *| 10195 |* *| 10196 \******************************************************************************/ 10197 10198 void set_ieee_exception_intrinsic(opnd_type *result_opnd, 10199 expr_arg_type *res_exp_desc, 10200 int *spec_idx) 10201 { 10202 int ir_idx; 10203 int idx; 10204 int info_idx1; 10205 int list_idx1; 10206 10207 TRACE (Func_Entry, "set_ieee_exception_intrinsic", NULL); 10208 10209 ir_idx = OPND_IDX((*result_opnd)); 10210 list_idx1 = IR_IDX_R(ir_idx); 10211 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 10212 10213 conform_check(0, 10214 ir_idx, 10215 res_exp_desc, 10216 spec_idx, 10217 FALSE); 10218 # if 0 10219 10220 switch (ATP_INTRIN_ENUM(*spec_idx)) { 10221 10222 case Set_Ieee_Exception_Intrinsic: 10223 IR_OPR(ir_idx) = Set_Ieee_Exception_Opr; 10224 10225 NTR_IR_LIST_TBL(idx); 10226 IL_NEXT_LIST_IDX(list_idx1) = idx; 10227 IL_FLD(idx) = CN_Tbl_Idx; 10228 IL_IDX(idx) = CN_INTEGER_ONE_IDX; 10229 IL_LINE_NUM(idx) = IR_LINE_NUM(ir_idx); 10230 IL_COL_NUM(idx) = IR_COL_NUM(ir_idx); 10231 IR_LIST_CNT_R(ir_idx) = 2; 10232 break; 10233 10234 case Clear_Ieee_Exception_Intrinsic: 10235 IR_OPR(ir_idx) = Clear_Ieee_Exception_Opr; 10236 10237 NTR_IR_LIST_TBL(idx); 10238 IL_NEXT_LIST_IDX(list_idx1) = idx; 10239 IL_FLD(idx) = CN_Tbl_Idx; 10240 IL_IDX(idx) = CN_INTEGER_ZERO_IDX; 10241 IL_LINE_NUM(idx) = IR_LINE_NUM(ir_idx); 10242 IL_COL_NUM(idx) = IR_COL_NUM(ir_idx); 10243 IR_LIST_CNT_R(ir_idx) = 2; 10244 break; 10245 10246 case Enable_Ieee_Interrupt_Intrinsic: 10247 IR_OPR(ir_idx) = Enable_Ieee_Interrupt_Opr; 10248 break; 10249 10250 case Disable_Ieee_Interrupt_Intrinsic: 10251 IR_OPR(ir_idx) = Disable_Ieee_Interrupt_Opr; 10252 break; 10253 } 10254 10255 # endif 10256 10257 if (arg_info_list[info_idx1].ed.rank > 1) { 10258 PRINTMSG(arg_info_list[info_idx1].line, 654, Error, 10259 arg_info_list[info_idx1].col); 10260 } 10261 10262 IR_TYPE_IDX(ir_idx) = arg_info_list[info_idx1].ed.type_idx; 10263 IR_RANK(ir_idx) = res_exp_desc->rank; 10264 10265 #if 0 10266 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10267 IR_OPND_R(ir_idx) = null_opnd; 10268 #endif 10269 10270 /* must reset foldable and will_fold_later because there is no */ 10271 /* folder for this intrinsic in constructors. */ 10272 10273 res_exp_desc->foldable = FALSE; 10274 res_exp_desc->will_fold_later = FALSE; 10275 10276 10277 TRACE (Func_Exit, "set_ieee_exception_intrinsic", NULL); 10278 10279 } /* set_ieee_exception_intrinsic */ 10280 10281 10282 /******************************************************************************\ 10283 |* *| 10284 |* Description: *| 10285 |* Function IEEE_BINARY_SCALE(Y, N) intrinsic. *| 10286 |* Function IEEE_COPY_SIGN(X, Y) intrinsic. *| 10287 |* Function IEEE_EXPONENT(X, Y) intrinsic. *| 10288 |* Function IEEE_INT(X, Y) intrinsic. *| 10289 |* Function INT_MULT_UPPER(I, J) intrinsic. *| 10290 |* Function IEEE_NEXT_AFTER(X, Y) intrinsic. *| 10291 |* Function IEEE_REAL(X, Y) intrinsic. *| 10292 |* Function IEEE_REMAINDER(X, Y) intrinsic. *| 10293 |* Function IEEE_UNORDERED(X, Y) intrinsic. *| 10294 |* *| 10295 |* Input parameters: *| 10296 |* NONE *| 10297 |* *| 10298 |* Output parameters: *| 10299 |* NONE *| 10300 |* *| 10301 |* Returns: *| 10302 |* NOTHING *| 10303 |* *| 10304 \******************************************************************************/ 10305 10306 void ieee_real_intrinsic(opnd_type *result_opnd, 10307 expr_arg_type *res_exp_desc, 10308 int *spec_idx) 10309 { 10310 int ir_idx; 10311 int list_idx1; 10312 int list_idx2; 10313 int info_idx1; 10314 int info_idx2; 10315 opnd_type opnd; 10316 10317 10318 TRACE (Func_Entry, "ieee_real_intrinsic", NULL); 10319 10320 ir_idx = OPND_IDX((*result_opnd)); 10321 list_idx1 = IR_IDX_R(ir_idx); 10322 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 10323 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 10324 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 10325 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 10326 } 10327 10328 switch (ATP_INTRIN_ENUM(*spec_idx)) { 10329 case Ieee_Int_Intrinsic: 10330 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 10331 10332 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 10333 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 10334 arg_info_list[info_idx2].ed.type_idx; 10335 } 10336 10337 IL_NEXT_LIST_IDX(list_idx1) = NULL_IDX; 10338 IR_LIST_CNT_R(ir_idx) = 1; 10339 IR_OPR(ir_idx) = Ieee_Int_Opr; 10340 break; 10341 10342 case Ieee_Real_Intrinsic: 10343 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = REAL_DEFAULT_TYPE; 10344 10345 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 10346 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 10347 arg_info_list[info_idx2].ed.type_idx; 10348 } 10349 10350 IL_NEXT_LIST_IDX(list_idx1) = NULL_IDX; 10351 IR_LIST_CNT_R(ir_idx) = 1; 10352 IR_OPR(ir_idx) = Ieee_Real_Opr; 10353 break; 10354 10355 case Int_Mult_Upper_Intrinsic: 10356 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 10357 arg_info_list[info_idx1].ed.type_idx; 10358 10359 if (arg_info_list[info_idx1].ed.type == Typeless) { 10360 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 10361 10362 COPY_OPND(opnd, IL_OPND(list_idx1)); 10363 cast_opnd_to_type_idx(&opnd, INTEGER_DEFAULT_TYPE); 10364 COPY_OPND(IL_OPND(list_idx1), opnd); 10365 10366 COPY_OPND(opnd, IL_OPND(list_idx2)); 10367 cast_opnd_to_type_idx(&opnd, INTEGER_DEFAULT_TYPE); 10368 COPY_OPND(IL_OPND(list_idx2), opnd); 10369 } 10370 10371 IR_OPR(ir_idx) = Int_Mult_Upper_Opr; 10372 break; 10373 10374 case Ieee_Exponent_Intrinsic: 10375 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 10376 10377 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 10378 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 10379 arg_info_list[info_idx2].ed.type_idx; 10380 10381 if (arg_info_list[info_idx2].ed.rank != 0) { 10382 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 10383 arg_info_list[info_idx2].col); 10384 } 10385 } 10386 10387 IL_NEXT_LIST_IDX(list_idx1) = NULL_IDX; 10388 IR_LIST_CNT_R(ir_idx) = 1; 10389 IR_OPR(ir_idx) = Ieee_Exponent_Opr; 10390 break; 10391 10392 case Ieee_Remainder_Intrinsic: 10393 if (TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx) > 10394 TYP_LINEAR(arg_info_list[info_idx2].ed.type_idx)) { 10395 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 10396 arg_info_list[info_idx1].ed.type_idx; 10397 } 10398 else { 10399 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 10400 arg_info_list[info_idx2].ed.type_idx; 10401 } 10402 IR_OPR(ir_idx) = Ieee_Remainder_Opr; 10403 break; 10404 10405 case Ieee_Unordered_Intrinsic: 10406 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 10407 IR_OPR(ir_idx) = Ieee_Unordered_Opr; 10408 break; 10409 10410 case Ieee_Binary_Scale_Intrinsic: 10411 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 10412 arg_info_list[info_idx1].ed.type_idx; 10413 IR_OPR(ir_idx) = Ieee_Binary_Scale_Opr; 10414 break; 10415 10416 case Ieee_Next_After_Intrinsic: 10417 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 10418 arg_info_list[info_idx1].ed.type_idx; 10419 IR_OPR(ir_idx) = Ieee_Next_After_Opr; 10420 break; 10421 10422 case Ieee_Copy_Sign_Intrinsic: 10423 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 10424 arg_info_list[info_idx1].ed.type_idx; 10425 IR_OPR(ir_idx) = Ieee_Copy_Sign_Opr; 10426 break; 10427 } 10428 10429 conform_check(0, 10430 ir_idx, 10431 res_exp_desc, 10432 spec_idx, 10433 FALSE); 10434 10435 10436 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 10437 IR_RANK(ir_idx) = res_exp_desc->rank; 10438 10439 # if 0 10440 10441 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10442 IR_OPND_R(ir_idx) = null_opnd; 10443 10444 /* must reset foldable and will_fold_later because there is no */ 10445 /* folder for this intrinsic in constructors. */ 10446 10447 # endif 10448 10449 res_exp_desc->foldable = FALSE; 10450 res_exp_desc->will_fold_later = FALSE; 10451 10452 TRACE (Func_Exit, "ieee_real_intrinsic", NULL); 10453 10454 } /* ieee_real_intrinsic */ 10455 10456 10457 10458 /******************************************************************************\ 10459 |* *| 10460 |* Description: *| 10461 |* Function IEEE_FINITE(X) intrinsic. *| 10462 |* Function IEEE_IS_NAN(X) intrinsic. *| 10463 |* Function ISNAN(X) intrinsic. *| 10464 |* Function IEEE_CLASS(X) intrinsic. *| 10465 |* Function FP_CLASS(X) intrinsic. *| 10466 |* *| 10467 |* Input parameters: *| 10468 |* NONE *| 10469 |* *| 10470 |* Output parameters: *| 10471 |* NONE *| 10472 |* *| 10473 |* Returns: *| 10474 |* NOTHING *| 10475 |* *| 10476 \******************************************************************************/ 10477 10478 void ieee_finite_intrinsic(opnd_type *result_opnd, 10479 expr_arg_type *res_exp_desc, 10480 int *spec_idx) 10481 { 10482 int ir_idx; 10483 10484 10485 TRACE (Func_Entry, "ieee_finite_intrinsic", NULL); 10486 10487 ir_idx = OPND_IDX((*result_opnd)); 10488 10489 switch (ATP_INTRIN_ENUM(*spec_idx)) { 10490 10491 case Ieee_Finite_Intrinsic: 10492 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 10493 IR_OPR(ir_idx) = Ieee_Finite_Opr; 10494 break; 10495 10496 case Ieee_Is_Nan_Intrinsic: 10497 case Isnan_Intrinsic: 10498 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 10499 IR_OPR(ir_idx) = Ieee_Is_Nan_Opr; 10500 break; 10501 10502 case Ieee_Class_Intrinsic: 10503 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 10504 IR_OPR(ir_idx) = Ieee_Class_Opr; 10505 break; 10506 10507 case Fp_Class_Intrinsic: 10508 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 10509 break; 10510 } 10511 10512 conform_check(0, 10513 ir_idx, 10514 res_exp_desc, 10515 spec_idx, 10516 FALSE); 10517 10518 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 10519 IR_RANK(ir_idx) = res_exp_desc->rank; 10520 10521 # if 0 10522 10523 if (ATP_INTRIN_ENUM(*spec_idx) != Fp_Class_Intrinsic) { 10524 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10525 IR_OPND_R(ir_idx) = null_opnd; 10526 } 10527 10528 # endif 10529 10530 /* must reset foldable and will_fold_later because there is no */ 10531 /* folder for this intrinsic in constructors. */ 10532 10533 res_exp_desc->foldable = FALSE; 10534 res_exp_desc->will_fold_later = FALSE; 10535 10536 TRACE (Func_Exit, "ieee_finite_intrinsic", NULL); 10537 10538 } /* ieee_finite_intrinsic */ 10539 10540 10541 10542 /******************************************************************************\ 10543 |* *| 10544 |* Description: *| 10545 |* Subroutine LOCK_RELEASE(I) intrinsic. *| 10546 |* *| 10547 |* Input parameters: *| 10548 |* NONE *| 10549 |* *| 10550 |* Output parameters: *| 10551 |* NONE *| 10552 |* *| 10553 |* Returns: *| 10554 |* NOTHING *| 10555 |* *| 10556 \******************************************************************************/ 10557 void lock_release_intrinsic(opnd_type *result_opnd, 10558 expr_arg_type *res_exp_desc, 10559 int *spec_idx) 10560 { 10561 int ir_idx; 10562 10563 10564 TRACE (Func_Entry, "lock_release_intrinsic", NULL); 10565 10566 ir_idx = OPND_IDX((*result_opnd)); 10567 IR_TYPE_IDX(ir_idx) = REAL_DEFAULT_TYPE; 10568 10569 #if 0 10570 IR_OPR(ir_idx) = Lock_Release_Opr; 10571 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10572 IR_OPND_R(ir_idx) = null_opnd; 10573 10574 io_item_must_flatten = TRUE; 10575 #endif 10576 10577 /* must reset foldable and will_fold_later because there is no */ 10578 /* folder for this intrinsic in constructors. */ 10579 10580 res_exp_desc->foldable = FALSE; 10581 res_exp_desc->will_fold_later = FALSE; 10582 10583 TRACE (Func_Exit, "lock_release_intrinsic", NULL); 10584 10585 } /* lock_release_intrinsic */ 10586 10587 10588 10589 /******************************************************************************\ 10590 |* *| 10591 |* Description: *| 10592 |* Subroutine RANDOM_NUMBER(HARVEST) intrinsic. *| 10593 |* *| 10594 |* Input parameters: *| 10595 |* NONE *| 10596 |* *| 10597 |* Output parameters: *| 10598 |* NONE *| 10599 |* *| 10600 |* Returns: *| 10601 |* NOTHING *| 10602 |* *| 10603 \******************************************************************************/ 10604 10605 void random_number_intrinsic(opnd_type *result_opnd, 10606 expr_arg_type *res_exp_desc, 10607 int *spec_idx) 10608 { 10609 int ir_idx; 10610 int list_idx1; 10611 int info_idx1; 10612 int ranf_idx; 10613 int attr_idx; 10614 int line; 10615 int col; 10616 10617 10618 TRACE (Func_Entry, "random_number_intrinsic", NULL); 10619 10620 ir_idx = OPND_IDX((*result_opnd)); 10621 IR_TYPE_IDX(ir_idx) = REAL_DEFAULT_TYPE; 10622 list_idx1 = IR_IDX_R(ir_idx); 10623 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 10624 IR_TYPE_IDX(ir_idx) = arg_info_list[info_idx1].ed.type_idx; 10625 10626 if (arg_info_list[info_idx1].ed.reference) { 10627 attr_idx = find_base_attr(&IL_OPND(list_idx1), &line, &col); 10628 AT_DEFINED(attr_idx) = TRUE; 10629 10630 if ((AT_OBJ_CLASS(attr_idx) == Data_Obj) && 10631 (ATD_CLASS(attr_idx) == Function_Result) && 10632 (ATD_FUNC_IDX(attr_idx) != NULL_IDX)) { 10633 AT_DEFINED(ATD_FUNC_IDX(attr_idx)) = TRUE; 10634 } 10635 } 10636 10637 if (IL_FLD(list_idx1) == CN_Tbl_Idx) { 10638 PRINTMSG(arg_info_list[info_idx1].line, 1214, Error, 10639 arg_info_list[info_idx1].col); 10640 } 10641 10642 # if 0 10643 10644 ranf_idx = gen_ir(NO_Tbl_Idx, NULL_IDX, 10645 Ranf_Opr, IR_TYPE_IDX(ir_idx), IR_LINE_NUM(ir_idx), 10646 IR_COL_NUM(ir_idx), 10647 NO_Tbl_Idx, NULL_IDX); 10648 10649 IR_OPR(ir_idx) = Asg_Opr; 10650 IR_FLD_L(ir_idx) = IL_FLD(list_idx1); 10651 IR_IDX_L(ir_idx) = IL_IDX(list_idx1); 10652 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 10653 IR_IDX_R(ir_idx) = ranf_idx; 10654 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 10655 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 10656 IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx); 10657 IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx); 10658 10659 /* must reset foldable and will_fold_later because there is no */ 10660 /* folder for this intrinsic in constructors. */ 10661 10662 # endif 10663 10664 res_exp_desc->foldable = FALSE; 10665 res_exp_desc->will_fold_later = FALSE; 10666 10667 TRACE (Func_Exit, "random_number_intrinsic", NULL); 10668 10669 } /* random_number_intrinsic */ 10670 10671 10672 /******************************************************************************\ 10673 |* *| 10674 |* Description: *| 10675 |* Function ALL(MASK, DIM) intrinsic. *| 10676 |* Function ANY(MASK, DIM) intrinsic. *| 10677 |* Function COUNT(MASK, DIM) intrinsic. *| 10678 |* *| 10679 |* Input parameters: *| 10680 |* NONE *| 10681 |* *| 10682 |* Output parameters: *| 10683 |* NONE *| 10684 |* *| 10685 |* Returns: *| 10686 |* NOTHING *| 10687 |* *| 10688 \******************************************************************************/ 10689 10690 void all_intrinsic(opnd_type *result_opnd, 10691 expr_arg_type *res_exp_desc, 10692 int *spec_idx) 10693 { 10694 int list_idx1; 10695 int list_idx2; 10696 int info_idx1; 10697 int info_idx2; 10698 int attr_idx; 10699 int ir_idx; 10700 int i; 10701 int j; 10702 int line; 10703 int col; 10704 opnd_type opnd; 10705 10706 10707 TRACE (Func_Entry, "all_intrinsic", NULL); 10708 ir_idx = OPND_IDX((*result_opnd)); 10709 list_idx1 = IR_IDX_R(ir_idx); 10710 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 10711 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 10712 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 10713 10714 if (ATP_INTRIN_ENUM(*spec_idx) == Count_Intrinsic) { 10715 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 10716 } 10717 else { 10718 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 10719 arg_info_list[info_idx1].ed.type_idx; 10720 } 10721 10722 if (arg_info_list[info_idx1].ed.rank < 1) { 10723 PRINTMSG(arg_info_list[info_idx1].line, 640, Error, 10724 arg_info_list[info_idx1].col); 10725 } 10726 10727 conform_check(0, 10728 ir_idx, 10729 res_exp_desc, 10730 spec_idx, 10731 FALSE); 10732 10733 if (list_idx2 != NULL_IDX && IL_IDX(list_idx2) != NULL_IDX) { 10734 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 10735 10736 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { /* DIM is a constant */ 10737 if (compare_cn_and_value(IL_IDX(list_idx2), 1, Lt_Opr) || 10738 compare_cn_and_value(IL_IDX(list_idx2), 10739 (long) arg_info_list[info_idx1].ed.rank, 10740 Gt_Opr)) { 10741 10742 PRINTMSG(arg_info_list[info_idx2].line, 881, Error, 10743 arg_info_list[info_idx2].col); 10744 } 10745 10746 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 10747 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 10748 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 10749 j = 1; 10750 for (i = 1; i < 8; i++) { 10751 if (i == CN_INT_TO_C(IL_IDX(list_idx2))) { 10752 j = j + 1; 10753 } 10754 10755 COPY_OPND(res_exp_desc->shape[i-1], 10756 arg_info_list[info_idx1].ed.shape[j-1]); 10757 j = j + 1; 10758 } 10759 10760 # ifdef _INLINE_INTRINSICS 10761 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 10762 # endif 10763 } 10764 else { /* DIM is not constant */ 10765 if (arg_info_list[info_idx2].ed.reference) { 10766 attr_idx = find_base_attr(&IL_OPND(list_idx2), &line, &col); 10767 10768 if ((AT_OPTIONAL(attr_idx)) && 10769 (arg_info_list[info_idx2].line != 0)) { 10770 PRINTMSG(arg_info_list[info_idx2].line, 875, Error, 10771 arg_info_list[info_idx2].col); 10772 } 10773 } 10774 } 10775 10776 COPY_OPND(opnd, IL_OPND(list_idx2)); 10777 cast_to_cg_default(&opnd, &(arg_info_list[info_idx2].ed)); 10778 COPY_OPND(IL_OPND(list_idx2), opnd); 10779 10780 res_exp_desc->rank = arg_info_list[info_idx1].ed.rank - 1; 10781 } 10782 else { 10783 res_exp_desc->rank = 0; /* result is scalar */ 10784 NTR_IR_LIST_TBL(list_idx2); 10785 IL_INTRIN_PLACE_HOLDER(list_idx2) = TRUE; 10786 IL_ARG_DESC_VARIANT(list_idx2) = TRUE; 10787 IL_NEXT_LIST_IDX(list_idx1) = list_idx2; 10788 IR_LIST_CNT_R(ir_idx) = 2; 10789 # ifdef _INLINE_INTRINSICS 10790 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 10791 # endif 10792 } 10793 10794 10795 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 10796 /* io_item_must_flatten = TRUE; */ 10797 if (ATP_INTRIN_ENUM(*spec_idx) == Any_Intrinsic) { 10798 IR_OPR(ir_idx) = Any_Opr; 10799 } 10800 else if (ATP_INTRIN_ENUM(*spec_idx) == All_Intrinsic) { 10801 IR_OPR(ir_idx) = All_Opr; 10802 } 10803 else { 10804 IR_OPR(ir_idx) = Count_Opr; 10805 } 10806 10807 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10808 IR_OPND_R(ir_idx) = null_opnd; 10809 IR_LIST_CNT_L(ir_idx) = IR_LIST_CNT_R(ir_idx); 10810 } 10811 10812 10813 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 10814 IR_RANK(ir_idx) = res_exp_desc->rank; 10815 10816 /* must reset foldable and will_fold_later because there is no */ 10817 /* folder for this intrinsic in constructors. */ 10818 res_exp_desc->foldable = FALSE; 10819 res_exp_desc->will_fold_later = FALSE; 10820 10821 TRACE (Func_Exit, "all_intrinsic", NULL); 10822 10823 } /* all_intrinsic */ 10824 10825 10826 /******************************************************************************\ 10827 |* *| 10828 |* Description: *| 10829 |* Function TINY(X) intrinsic. *| 10830 |* *| 10831 |* Input parameters: *| 10832 |* NONE *| 10833 |* *| 10834 |* Output parameters: *| 10835 |* NONE *| 10836 |* *| 10837 |* Returns: *| 10838 |* NOTHING *| 10839 |* *| 10840 \******************************************************************************/ 10841 10842 void tiny_intrinsic(opnd_type *result_opnd, 10843 expr_arg_type *res_exp_desc, 10844 int *spec_idx) 10845 { 10846 int cn_idx; 10847 int info_idx1; 10848 int ir_idx; 10849 10850 10851 TRACE (Func_Entry, "tiny_intrinsic", NULL); 10852 10853 ir_idx = OPND_IDX((*result_opnd)); 10854 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 10855 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 10856 10857 conform_check(0, 10858 ir_idx, 10859 res_exp_desc, 10860 spec_idx, 10861 FALSE); 10862 10863 res_exp_desc->rank = 0; 10864 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 10865 IR_RANK(ir_idx) = res_exp_desc->rank; 10866 10867 # if 0 10868 10869 switch (arg_info_list[info_idx1].ed.linear_type) { 10870 case Real_4: 10871 cn_idx = cvrt_str_to_cn(TINY_REAL4_F90, 10872 arg_info_list[info_idx1].ed.linear_type); 10873 break; 10874 10875 case Real_8: 10876 cn_idx = cvrt_str_to_cn(TINY_REAL8_F90, 10877 arg_info_list[info_idx1].ed.linear_type); 10878 break; 10879 10880 case Real_16: 10881 cn_idx = cvrt_str_to_cn(TINY_REAL16_F90, 10882 arg_info_list[info_idx1].ed.linear_type); 10883 break; 10884 } 10885 10886 10887 OPND_IDX((*result_opnd)) = cn_idx; 10888 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 10889 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 10890 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 10891 res_exp_desc->constant = TRUE; 10892 res_exp_desc->foldable = TRUE; 10893 10894 # endif 10895 10896 res_exp_desc->foldable = FALSE; 10897 res_exp_desc->will_fold_later = FALSE; 10898 10899 TRACE (Func_Exit, "tiny_intrinsic", NULL); 10900 10901 } /* tiny_intrinsic */ 10902 10903 10904 /******************************************************************************\ 10905 |* *| 10906 |* Description: *| 10907 |* Function SPACING(X) intrinsic. *| 10908 |* *| 10909 |* Input parameters: *| 10910 |* NONE *| 10911 |* *| 10912 |* Output parameters: *| 10913 |* NONE *| 10914 |* *| 10915 |* Returns: *| 10916 |* NOTHING *| 10917 |* *| 10918 \******************************************************************************/ 10919 10920 void spacing_intrinsic(opnd_type *result_opnd, 10921 expr_arg_type *res_exp_desc, 10922 int *spec_idx) 10923 { 10924 int ir_idx; 10925 int cn_idx; 10926 int info_idx1; 10927 int list_idx1; 10928 int list_idx2; 10929 long num; 10930 10931 10932 TRACE (Func_Entry, "spacing_intrinsic", NULL); 10933 10934 ir_idx = OPND_IDX((*result_opnd)); 10935 list_idx1 = IR_IDX_R(ir_idx); 10936 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 10937 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 10938 10939 conform_check(0, 10940 ir_idx, 10941 res_exp_desc, 10942 spec_idx, 10943 FALSE); 10944 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 10945 IR_RANK(ir_idx) = res_exp_desc->rank; 10946 10947 # if 0 10948 10949 IR_OPR(ir_idx) = Spacing_Opr; 10950 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 10951 IR_LIST_CNT_L(ir_idx) = 2; 10952 10953 switch (arg_info_list[info_idx1].ed.linear_type) { 10954 case Real_4: 10955 num = DIGITS_REAL4_F90; 10956 break; 10957 10958 case Real_8: 10959 num = DIGITS_REAL8_F90; 10960 break; 10961 10962 case Real_16: 10963 num = DIGITS_REAL16_F90; 10964 break; 10965 } 10966 10967 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num); 10968 10969 NTR_IR_LIST_TBL(list_idx2); 10970 IL_ARG_DESC_VARIANT(list_idx2) = TRUE; 10971 10972 /* link list together */ 10973 IL_NEXT_LIST_IDX(list_idx1) = list_idx2; 10974 10975 IL_IDX(list_idx2) = cn_idx; 10976 IL_FLD(list_idx2) = CN_Tbl_Idx; 10977 10978 IL_LINE_NUM(list_idx2) = IL_LINE_NUM(list_idx1); 10979 IL_COL_NUM(list_idx2) = IL_COL_NUM(list_idx1); 10980 10981 IR_OPND_R(ir_idx) = null_opnd; 10982 10983 # endif 10984 10985 /* must reset foldable and will_fold_later because there is no */ 10986 /* folder for this intrinsic in constructors. */ 10987 res_exp_desc->foldable = FALSE; 10988 res_exp_desc->will_fold_later = FALSE; 10989 10990 10991 TRACE (Func_Exit, "spacing_intrinsic", NULL); 10992 10993 } /* spacing_intrinsic */ 10994 10995 10996 /******************************************************************************\ 10997 |* *| 10998 |* Description: *| 10999 |* Function CSHIFT(ARRAY, SHIFT, DIM) intrinsic. *| 11000 |* *| 11001 |* Input parameters: *| 11002 |* NONE *| 11003 |* *| 11004 |* Output parameters: *| 11005 |* NONE *| 11006 |* *| 11007 |* Returns: *| 11008 |* NOTHING *| 11009 |* *| 11010 \******************************************************************************/ 11011 11012 void cshift_intrinsic(opnd_type *result_opnd, 11013 expr_arg_type *res_exp_desc, 11014 int *spec_idx) 11015 { 11016 int ir_idx; 11017 int cn_idx; 11018 int list_idx1; 11019 int list_idx2; 11020 int list_idx3; 11021 int info_idx1; 11022 int info_idx2; 11023 int info_idx3; 11024 int type_idx; 11025 opnd_type opnd; 11026 11027 11028 TRACE (Func_Entry, "cshift_intrinsic", NULL); 11029 11030 11031 # ifdef _INLINE_INTRINSICS 11032 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 11033 # endif 11034 11035 # if defined(GENERATE_WHIRL) 11036 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 11037 # endif 11038 11039 ir_idx = OPND_IDX((*result_opnd)); 11040 list_idx1 = IR_IDX_R(ir_idx); 11041 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 11042 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 11043 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 11044 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 11045 type_idx = arg_info_list[info_idx1].ed.type_idx; 11046 11047 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 11048 11049 if ((arg_info_list[info_idx1].ed.rank == 1) && 11050 (arg_info_list[info_idx2].ed.rank != 0)) { 11051 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 11052 arg_info_list[info_idx2].col); 11053 } 11054 else if ((arg_info_list[info_idx2].ed.rank != 0) && 11055 (arg_info_list[info_idx2].ed.rank != 11056 (arg_info_list[info_idx1].ed.rank - 1))) { 11057 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 11058 arg_info_list[info_idx2].col); 11059 } 11060 11061 if (list_idx3 != NULL_IDX && IL_IDX(list_idx3) != NULL_IDX) { 11062 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 11063 11064 if (arg_info_list[info_idx3].ed.rank != 0) { 11065 PRINTMSG(arg_info_list[info_idx3].line, 654, Error, 11066 arg_info_list[info_idx3].col); 11067 } 11068 11069 if (IL_FLD(list_idx3) == CN_Tbl_Idx) { 11070 if (compare_cn_and_value(IL_IDX(list_idx3), 11071 (long) arg_info_list[info_idx1].ed.rank, 11072 Gt_Opr) || 11073 compare_cn_and_value(IL_IDX(list_idx3), 1, Lt_Opr)) { 11074 11075 PRINTMSG(arg_info_list[info_idx3].line, 1017, Error, 11076 arg_info_list[info_idx3].col); 11077 } 11078 } 11079 } 11080 else { /* DIM is not present */ 11081 11082 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 11083 CN_INTEGER_ONE_IDX : C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 1); 11084 IL_FLD(list_idx3) = CN_Tbl_Idx; 11085 IL_IDX(list_idx3) = cn_idx; 11086 IL_LINE_NUM(list_idx3) = IR_LINE_NUM(ir_idx); 11087 IL_COL_NUM(list_idx3) = IR_COL_NUM(ir_idx); 11088 11089 arg_info_list_base = arg_info_list_top; 11090 arg_info_list_top = arg_info_list_base + 1; 11091 11092 if (arg_info_list_top >= arg_info_list_size) { 11093 enlarge_info_list_table(); 11094 } 11095 11096 IL_ARG_DESC_IDX(list_idx3) = arg_info_list_top; 11097 arg_info_list[arg_info_list_top] = init_arg_info; 11098 arg_info_list[arg_info_list_top].ed.type_idx = INTEGER_DEFAULT_TYPE; 11099 arg_info_list[arg_info_list_top].ed.type = Integer; 11100 arg_info_list[arg_info_list_top].ed.linear_type = INTEGER_DEFAULT_TYPE; 11101 arg_info_list[arg_info_list_top].line = IR_LINE_NUM(ir_idx); 11102 arg_info_list[arg_info_list_top].col = IR_COL_NUM(ir_idx); 11103 11104 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 11105 } 11106 11107 # if defined(GENERATE_WHIRL) 11108 if (list_idx3 != NULL_IDX && 11109 IL_IDX(list_idx3) != NULL_IDX && 11110 IL_FLD(list_idx3) == CN_Tbl_Idx) { 11111 # ifdef _INLINE_INTRINSICS 11112 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 11113 # endif 11114 } 11115 # endif 11116 11117 COPY_OPND(opnd, IL_OPND(list_idx3)); 11118 cast_to_cg_default(&opnd, &(arg_info_list[info_idx3].ed)); 11119 COPY_OPND(IL_OPND(list_idx3), opnd); 11120 11121 11122 conform_check(0, 11123 ir_idx, 11124 res_exp_desc, 11125 spec_idx, 11126 FALSE); 11127 # if 0 11128 11129 COPY_OPND(res_exp_desc->shape[0], arg_info_list[info_idx1].ed.shape[0]); 11130 COPY_OPND(res_exp_desc->shape[1], arg_info_list[info_idx1].ed.shape[1]); 11131 COPY_OPND(res_exp_desc->shape[2], arg_info_list[info_idx1].ed.shape[2]); 11132 COPY_OPND(res_exp_desc->shape[3], arg_info_list[info_idx1].ed.shape[3]); 11133 COPY_OPND(res_exp_desc->shape[4], arg_info_list[info_idx1].ed.shape[4]); 11134 COPY_OPND(res_exp_desc->shape[5], arg_info_list[info_idx1].ed.shape[5]); 11135 COPY_OPND(res_exp_desc->shape[6], arg_info_list[info_idx1].ed.shape[6]); 11136 11137 COPY_OPND(res_exp_desc->char_len, arg_info_list[info_idx1].ed.char_len); 11138 11139 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 11140 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 11141 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 11142 11143 11144 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 11145 io_item_must_flatten = TRUE; 11146 IR_OPR(ir_idx) = Cshift_Opr; 11147 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 11148 IR_OPND_R(ir_idx) = null_opnd; 11149 } 11150 11151 # endif 11152 11153 IR_TYPE_IDX(ir_idx) = type_idx; 11154 IR_RANK(ir_idx) = res_exp_desc->rank; 11155 11156 /* must reset foldable and will_fold_later because there is no */ 11157 /* folder for this intrinsic in constructors. */ 11158 11159 res_exp_desc->foldable = FALSE; 11160 res_exp_desc->will_fold_later = FALSE; 11161 11162 TRACE (Func_Exit, "cshift_intrinsic", NULL); 11163 11164 } /* cshift_intrinsic */ 11165 11166 11167 /******************************************************************************\ 11168 |* *| 11169 |* Description: *| 11170 |* Function EOSHIFT(ARRAY, SHIFT, BOUNDARY, DIM) intrinsic. *| 11171 |* *| 11172 |* Input parameters: *| 11173 |* NONE *| 11174 |* *| 11175 |* Output parameters: *| 11176 |* NONE *| 11177 |* *| 11178 |* Returns: *| 11179 |* NOTHING *| 11180 |* *| 11181 \******************************************************************************/ 11182 11183 void eoshift_intrinsic(opnd_type *result_opnd, 11184 expr_arg_type *res_exp_desc, 11185 int *spec_idx) 11186 { 11187 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 11188 long_type cnst[MAX_WORDS_FOR_INTEGER]; 11189 int ir_idx; 11190 int list_idx1; 11191 int list_idx2; 11192 int list_idx3; 11193 int list_idx4; 11194 int info_idx1; 11195 int info_idx2; 11196 int info_idx3; 11197 int info_idx4; 11198 int input_type_idx; 11199 int output_type_idx; 11200 int cn_idx; 11201 opnd_type opnd; 11202 11203 11204 TRACE (Func_Entry, "eoshift_intrinsic", NULL); 11205 11206 # ifdef _INLINE_INTRINSICS 11207 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 11208 # endif 11209 11210 ir_idx = OPND_IDX((*result_opnd)); 11211 list_idx1 = IR_IDX_R(ir_idx); 11212 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 11213 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 11214 list_idx4 = IL_NEXT_LIST_IDX(list_idx3); 11215 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 11216 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 11217 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 11218 11219 if ((arg_info_list[info_idx1].ed.rank == 1) && 11220 (arg_info_list[info_idx2].ed.rank != 0)) { 11221 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 11222 arg_info_list[info_idx2].col); 11223 } 11224 else { 11225 if ((arg_info_list[info_idx2].ed.rank != 0) && 11226 (arg_info_list[info_idx2].ed.rank != 11227 (arg_info_list[info_idx1].ed.rank - 1))) { 11228 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 11229 arg_info_list[info_idx2].col); 11230 } 11231 } 11232 11233 conform_check(0, 11234 ir_idx, 11235 res_exp_desc, 11236 spec_idx, 11237 FALSE); 11238 11239 if (list_idx3 != NULL_IDX && IL_IDX(list_idx3) != NULL_IDX) { 11240 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 11241 11242 if (TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx) != 11243 TYP_LINEAR(arg_info_list[info_idx3].ed.type_idx)) { 11244 PRINTMSG(arg_info_list[info_idx3].line, 727, Error, 11245 arg_info_list[info_idx3].col); 11246 } 11247 11248 if ((arg_info_list[info_idx1].ed.rank == 1) && 11249 (arg_info_list[info_idx3].ed.rank != 0)) { 11250 PRINTMSG(arg_info_list[info_idx3].line, 654, Error, 11251 arg_info_list[info_idx3].col); 11252 } 11253 else { 11254 if ((arg_info_list[info_idx3].ed.rank != 0) && 11255 (arg_info_list[info_idx3].ed.rank != 11256 (arg_info_list[info_idx1].ed.rank - 1))) { 11257 PRINTMSG(arg_info_list[info_idx3].line, 654, Error, 11258 arg_info_list[info_idx3].col); 11259 } 11260 } 11261 } 11262 else { /* boundary not present */ 11263 11264 /* fzhao try Jan# if 0 */ 11265 11266 switch (arg_info_list[info_idx1].ed.type) { 11267 case Structure : 11268 PRINTMSG(arg_info_list[info_idx1].line, 888, Error, 11269 arg_info_list[info_idx1].col); 11270 break; 11271 11272 case Integer : 11273 11274 cn_idx = (TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx) == 11275 CG_INTEGER_DEFAULT_TYPE) ? CN_INTEGER_ZERO_IDX : 11276 C_INT_TO_CN(arg_info_list[info_idx1].ed.type_idx, 0); 11277 11278 IL_FLD(list_idx3) = CN_Tbl_Idx; 11279 IL_IDX(list_idx3) = cn_idx; 11280 IL_LINE_NUM(list_idx3) = IR_LINE_NUM(ir_idx); 11281 IL_COL_NUM(list_idx3) = IR_COL_NUM(ir_idx); 11282 11283 arg_info_list_base = arg_info_list_top; 11284 arg_info_list_top = arg_info_list_base + 1; 11285 11286 if (arg_info_list_top >= arg_info_list_size) { 11287 enlarge_info_list_table(); 11288 } 11289 11290 IL_ARG_DESC_IDX(list_idx3) = arg_info_list_top; 11291 arg_info_list[arg_info_list_top] = init_arg_info; 11292 arg_info_list[arg_info_list_top].ed.type_idx = 11293 arg_info_list[info_idx1].ed.type_idx; 11294 arg_info_list[arg_info_list_top].ed.type = Integer; 11295 arg_info_list[arg_info_list_top].ed.linear_type = 11296 TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx); 11297 arg_info_list[arg_info_list_top].line = IR_LINE_NUM(ir_idx); 11298 arg_info_list[arg_info_list_top].col = IR_COL_NUM(ir_idx); 11299 11300 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 11301 break; 11302 11303 case Real : 11304 output_type_idx = arg_info_list[info_idx1].ed.type_idx; 11305 input_type_idx = CG_INTEGER_DEFAULT_TYPE; 11306 11307 if (folder_driver((char *)&CN_CONST(CN_INTEGER_ZERO_IDX), 11308 input_type_idx, 11309 NULL, 11310 NULL_IDX, 11311 folded_const, 11312 &output_type_idx, 11313 IR_LINE_NUM(ir_idx), 11314 IR_COL_NUM(ir_idx), 11315 1, 11316 Cvrt_Opr)) { 11317 } 11318 11319 cn_idx = ntr_const_tbl(output_type_idx, 11320 FALSE, 11321 folded_const); 11322 11323 IL_FLD(list_idx3) = CN_Tbl_Idx; 11324 IL_IDX(list_idx3) = cn_idx; 11325 IL_LINE_NUM(list_idx3) = IR_LINE_NUM(ir_idx); 11326 IL_COL_NUM(list_idx3) = IR_COL_NUM(ir_idx); 11327 11328 arg_info_list_base = arg_info_list_top; 11329 arg_info_list_top = arg_info_list_base + 1; 11330 11331 if (arg_info_list_top >= arg_info_list_size) { 11332 enlarge_info_list_table(); 11333 } 11334 11335 IL_ARG_DESC_IDX(list_idx3) = arg_info_list_top; 11336 arg_info_list[arg_info_list_top] = init_arg_info; 11337 arg_info_list[arg_info_list_top].ed.type_idx = 11338 arg_info_list[info_idx1].ed.type_idx; 11339 arg_info_list[arg_info_list_top].ed.type = Real; 11340 arg_info_list[arg_info_list_top].ed.linear_type = 11341 TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx); 11342 arg_info_list[arg_info_list_top].line = IR_LINE_NUM(ir_idx); 11343 arg_info_list[arg_info_list_top].col = IR_COL_NUM(ir_idx); 11344 break; 11345 11346 case Complex : 11347 output_type_idx = arg_info_list[info_idx1].ed.type_idx; 11348 input_type_idx = CG_INTEGER_DEFAULT_TYPE; 11349 11350 if (folder_driver((char *)&CN_CONST(CN_INTEGER_ZERO_IDX), 11351 input_type_idx, 11352 NULL, 11353 NULL_IDX, 11354 folded_const, 11355 &output_type_idx, 11356 IR_LINE_NUM(ir_idx), 11357 IR_COL_NUM(ir_idx), 11358 1, 11359 Cvrt_Opr)) { 11360 } 11361 11362 cn_idx = ntr_const_tbl(output_type_idx, 11363 FALSE, 11364 folded_const); 11365 11366 IL_FLD(list_idx3) = CN_Tbl_Idx; 11367 IL_IDX(list_idx3) = cn_idx; 11368 IL_LINE_NUM(list_idx3) = IR_LINE_NUM(ir_idx); 11369 IL_COL_NUM(list_idx3) = IR_COL_NUM(ir_idx); 11370 11371 arg_info_list_base = arg_info_list_top; 11372 arg_info_list_top = arg_info_list_base + 1; 11373 11374 if (arg_info_list_top >= arg_info_list_size) { 11375 enlarge_info_list_table(); 11376 } 11377 11378 IL_ARG_DESC_IDX(list_idx3) = arg_info_list_top; 11379 arg_info_list[arg_info_list_top] = init_arg_info; 11380 arg_info_list[arg_info_list_top].ed.type_idx = 11381 arg_info_list[info_idx1].ed.type_idx; 11382 arg_info_list[arg_info_list_top].ed.type = Complex; 11383 arg_info_list[arg_info_list_top].ed.linear_type = 11384 TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx); 11385 arg_info_list[arg_info_list_top].line = IR_LINE_NUM(ir_idx); 11386 arg_info_list[arg_info_list_top].col = IR_COL_NUM(ir_idx); 11387 break; 11388 11389 case Logical : 11390 cn_idx = set_up_logical_constant(cnst, 11391 arg_info_list[info_idx1].ed.type_idx, 11392 FALSE_VALUE, 11393 TRUE); 11394 IL_FLD(list_idx3) = CN_Tbl_Idx; 11395 IL_IDX(list_idx3) = cn_idx; 11396 IL_LINE_NUM(list_idx3) = IR_LINE_NUM(ir_idx); 11397 IL_COL_NUM(list_idx3) = IR_COL_NUM(ir_idx); 11398 11399 arg_info_list_base = arg_info_list_top; 11400 arg_info_list_top = arg_info_list_base + 1; 11401 11402 if (arg_info_list_top >= arg_info_list_size) { 11403 enlarge_info_list_table(); 11404 } 11405 11406 IL_ARG_DESC_IDX(list_idx3) = arg_info_list_top; 11407 arg_info_list[arg_info_list_top] = init_arg_info; 11408 arg_info_list[arg_info_list_top].ed.type_idx = 11409 arg_info_list[info_idx1].ed.type_idx; 11410 arg_info_list[arg_info_list_top].ed.type = Logical; 11411 arg_info_list[arg_info_list_top].ed.linear_type = 11412 TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx); 11413 arg_info_list[arg_info_list_top].line = IR_LINE_NUM(ir_idx); 11414 arg_info_list[arg_info_list_top].col = IR_COL_NUM(ir_idx); 11415 11416 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 11417 break; 11418 11419 case Character : 11420 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 11421 break; 11422 } 11423 11424 /* fzhao try Jan #endif */ 11425 11426 } 11427 11428 if (list_idx4 != NULL_IDX && IL_IDX(list_idx4) != NULL_IDX) { 11429 info_idx4 = IL_ARG_DESC_IDX(list_idx4); 11430 11431 if (arg_info_list[info_idx4].ed.rank != 0) { 11432 PRINTMSG(arg_info_list[info_idx4].line, 654, Error, 11433 arg_info_list[info_idx4].col); 11434 } 11435 11436 if (IL_FLD(list_idx4) == CN_Tbl_Idx) { 11437 if (compare_cn_and_value(IL_IDX(list_idx4), 11438 (long) arg_info_list[info_idx1].ed.rank, 11439 Gt_Opr) || 11440 compare_cn_and_value(IL_IDX(list_idx4), 1, Lt_Opr)) { 11441 11442 PRINTMSG(arg_info_list[info_idx4].line, 1017, Error, 11443 arg_info_list[info_idx4].col); 11444 } 11445 } 11446 } 11447 else { /* DIM is not present */ 11448 11449 # if 0 11450 11451 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 11452 CN_INTEGER_ONE_IDX : C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 1); 11453 IL_FLD(list_idx4) = CN_Tbl_Idx; 11454 IL_IDX(list_idx4) = cn_idx; 11455 IL_LINE_NUM(list_idx4) = IR_LINE_NUM(ir_idx); 11456 IL_COL_NUM(list_idx4) = IR_COL_NUM(ir_idx); 11457 11458 arg_info_list_base = arg_info_list_top; 11459 arg_info_list_top = arg_info_list_base + 1; 11460 11461 if (arg_info_list_top >= arg_info_list_size) { 11462 enlarge_info_list_table(); 11463 } 11464 11465 IL_ARG_DESC_IDX(list_idx4) = arg_info_list_top; 11466 arg_info_list[arg_info_list_top] = init_arg_info; 11467 arg_info_list[arg_info_list_top].ed.type_idx = INTEGER_DEFAULT_TYPE; 11468 arg_info_list[arg_info_list_top].ed.type = Integer; 11469 arg_info_list[arg_info_list_top].ed.linear_type = INTEGER_DEFAULT_TYPE; 11470 arg_info_list[arg_info_list_top].line = IR_LINE_NUM(ir_idx); 11471 arg_info_list[arg_info_list_top].col = IR_COL_NUM(ir_idx); 11472 11473 info_idx4 = IL_ARG_DESC_IDX(list_idx4); 11474 11475 # endif 11476 11477 } 11478 11479 # if 0 11480 11481 if (IL_FLD(list_idx4) != CN_Tbl_Idx) { 11482 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 11483 } 11484 11485 COPY_OPND(opnd, IL_OPND(list_idx4)); 11486 cast_to_cg_default(&opnd, &(arg_info_list[info_idx4].ed)); 11487 COPY_OPND(IL_OPND(list_idx4), opnd); 11488 11489 COPY_OPND(res_exp_desc->shape[0], arg_info_list[info_idx1].ed.shape[0]); 11490 COPY_OPND(res_exp_desc->shape[1], arg_info_list[info_idx1].ed.shape[1]); 11491 COPY_OPND(res_exp_desc->shape[2], arg_info_list[info_idx1].ed.shape[2]); 11492 COPY_OPND(res_exp_desc->shape[3], arg_info_list[info_idx1].ed.shape[3]); 11493 COPY_OPND(res_exp_desc->shape[4], arg_info_list[info_idx1].ed.shape[4]); 11494 COPY_OPND(res_exp_desc->shape[5], arg_info_list[info_idx1].ed.shape[5]); 11495 COPY_OPND(res_exp_desc->shape[6], arg_info_list[info_idx1].ed.shape[6]); 11496 11497 COPY_OPND(res_exp_desc->char_len, arg_info_list[info_idx1].ed.char_len); 11498 11499 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 11500 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 11501 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 11502 11503 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 11504 io_item_must_flatten = TRUE; 11505 IR_OPR(ir_idx) = Eoshift_Opr; 11506 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 11507 IR_OPND_R(ir_idx) = null_opnd; 11508 } 11509 11510 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 11511 IR_RANK(ir_idx) = res_exp_desc->rank; 11512 11513 /* must reset foldable and will_fold_later because there is no */ 11514 /* folder for this intrinsic in constructors. */ 11515 11516 # endif 11517 11518 res_exp_desc->foldable = FALSE; 11519 res_exp_desc->will_fold_later = FALSE; 11520 11521 TRACE (Func_Exit, "eoshift_intrinsic", NULL); 11522 11523 } /* eoshift_intrinsic */ 11524 11525 11526 /******************************************************************************\ 11527 |* *| 11528 |* Description: *| 11529 |* Function MINEXPONENT(X) intrinsic. *| 11530 |* *| 11531 |* Input parameters: *| 11532 |* NONE *| 11533 |* *| 11534 |* Output parameters: *| 11535 |* NONE *| 11536 |* *| 11537 |* Returns: *| 11538 |* NOTHING *| 11539 |* *| 11540 \******************************************************************************/ 11541 11542 void minexponent_intrinsic(opnd_type *result_opnd, 11543 expr_arg_type *res_exp_desc, 11544 int *spec_idx) 11545 { 11546 int ir_idx; 11547 long num; 11548 int info_idx1; 11549 int cn_idx; 11550 11551 11552 TRACE (Func_Entry, "minexponent_intrinsic", NULL); 11553 11554 ir_idx = OPND_IDX((*result_opnd)); 11555 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 11556 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 11557 11558 conform_check(0, 11559 ir_idx, 11560 res_exp_desc, 11561 spec_idx, 11562 TRUE); 11563 11564 11565 res_exp_desc->rank = 0; 11566 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 11567 IR_RANK(ir_idx) = res_exp_desc->rank; 11568 11569 # if 0 11570 11571 switch (arg_info_list[info_idx1].ed.linear_type) { 11572 case Real_4: 11573 num = MINEXPONENT_REAL4_F90; 11574 break; 11575 11576 case Real_8: 11577 num = MINEXPONENT_REAL8_F90; 11578 break; 11579 11580 case Real_16: 11581 num = MINEXPONENT_REAL16_F90; 11582 break; 11583 } 11584 11585 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 11586 11587 OPND_IDX((*result_opnd)) = cn_idx; 11588 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 11589 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 11590 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 11591 res_exp_desc->constant = TRUE; 11592 res_exp_desc->foldable = TRUE; 11593 11594 # endif 11595 res_exp_desc->foldable = FALSE; 11596 res_exp_desc->will_fold_later = FALSE; 11597 11598 TRACE (Func_Exit, "minexponent_intrinsic", NULL); 11599 11600 } /* minexponent_intrinsic */ 11601 11602 11603 /******************************************************************************\ 11604 |* *| 11605 |* Description: *| 11606 |* Function MAXEXPONENT(X) intrinsic. *| 11607 |* *| 11608 |* Input parameters: *| 11609 |* NONE *| 11610 |* *| 11611 |* Output parameters: *| 11612 |* NONE *| 11613 |* *| 11614 |* Returns: *| 11615 |* NOTHING *| 11616 |* *| 11617 \******************************************************************************/ 11618 11619 void maxexponent_intrinsic(opnd_type *result_opnd, 11620 expr_arg_type *res_exp_desc, 11621 int *spec_idx) 11622 { 11623 int ir_idx; 11624 int info_idx1; 11625 int cn_idx; 11626 long num; 11627 11628 11629 TRACE (Func_Entry, "maxexponent_intrinsic", NULL); 11630 11631 ir_idx = OPND_IDX((*result_opnd)); 11632 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 11633 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 11634 11635 conform_check(0, 11636 ir_idx, 11637 res_exp_desc, 11638 spec_idx, 11639 TRUE); 11640 11641 res_exp_desc->rank = 0; 11642 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 11643 IR_RANK(ir_idx) = res_exp_desc->rank; 11644 11645 # if 0 11646 11647 switch (arg_info_list[info_idx1].ed.linear_type) { 11648 case Real_4: 11649 num = MAXEXPONENT_REAL4_F90; 11650 break; 11651 11652 case Real_8: 11653 num = MAXEXPONENT_REAL8_F90; 11654 break; 11655 11656 case Real_16: 11657 num = MAXEXPONENT_REAL16_F90; 11658 break; 11659 } 11660 11661 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 11662 11663 OPND_IDX((*result_opnd)) = cn_idx; 11664 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 11665 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 11666 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 11667 res_exp_desc->constant = TRUE; 11668 res_exp_desc->foldable = TRUE; 11669 11670 # endif 11671 11672 res_exp_desc->foldable = FALSE; 11673 res_exp_desc->will_fold_later = FALSE; 11674 11675 TRACE (Func_Exit, "maxexponent_intrinsic", NULL); 11676 11677 } /* maxexponent_intrinsic */ 11678 11679 11680 /******************************************************************************\ 11681 |* *| 11682 |* Description: *| 11683 |* Function RADIX(X) intrinsic. *| 11684 |* *| 11685 |* Input parameters: *| 11686 |* NONE *| 11687 |* *| 11688 |* Output parameters: *| 11689 |* NONE *| 11690 |* *| 11691 |* Returns: *| 11692 |* NOTHING *| 11693 |* *| 11694 \******************************************************************************/ 11695 11696 void radix_intrinsic(opnd_type *result_opnd, 11697 expr_arg_type *res_exp_desc, 11698 int *spec_idx) 11699 { 11700 int ir_idx; 11701 int cn_idx; 11702 11703 11704 TRACE (Func_Entry, "radix_intrinsic", NULL); 11705 11706 ir_idx = OPND_IDX((*result_opnd)); 11707 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 11708 11709 conform_check(0, 11710 ir_idx, 11711 res_exp_desc, 11712 spec_idx, 11713 TRUE); 11714 11715 res_exp_desc->rank = 0; 11716 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 11717 IR_RANK(ir_idx) = res_exp_desc->rank; 11718 11719 # if 0 11720 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, RADIX_F90); 11721 11722 OPND_IDX((*result_opnd)) = cn_idx; 11723 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 11724 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 11725 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 11726 res_exp_desc->constant = TRUE; 11727 res_exp_desc->foldable = TRUE; 11728 11729 # endif 11730 res_exp_desc->foldable = FALSE; 11731 res_exp_desc->will_fold_later = FALSE; 11732 11733 TRACE (Func_Exit, "radix_intrinsic", NULL); 11734 11735 } /* radix_intrinsic */ 11736 11737 11738 /******************************************************************************\ 11739 |* *| 11740 |* Description: *| 11741 |* Function RANGE(X) intrinsic. *| 11742 |* *| 11743 |* Input parameters: *| 11744 |* NONE *| 11745 |* *| 11746 |* Output parameters: *| 11747 |* NONE *| 11748 |* *| 11749 |* Returns: *| 11750 |* NOTHING *| 11751 |* *| 11752 \******************************************************************************/ 11753 11754 void range_intrinsic(opnd_type *result_opnd, 11755 expr_arg_type *res_exp_desc, 11756 int *spec_idx) 11757 { 11758 int ir_idx; 11759 int cn_idx; 11760 int info_idx1; 11761 long num; 11762 11763 11764 TRACE (Func_Entry, "range_intrinsic", NULL); 11765 11766 ir_idx = OPND_IDX((*result_opnd)); 11767 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 11768 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 11769 11770 conform_check(0, 11771 ir_idx, 11772 res_exp_desc, 11773 spec_idx, 11774 TRUE); 11775 11776 res_exp_desc->rank = 0; 11777 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 11778 IR_RANK(ir_idx) = res_exp_desc->rank; 11779 11780 # if 0 11781 11782 switch (arg_info_list[info_idx1].ed.linear_type) { 11783 case Complex_4: 11784 num = RANGE_REAL4_F90; 11785 break; 11786 11787 case Complex_8: 11788 num = RANGE_REAL8_F90; 11789 break; 11790 11791 case Complex_16: 11792 num = RANGE_REAL16_F90; 11793 break; 11794 11795 case Real_4: 11796 num = RANGE_REAL4_F90; 11797 break; 11798 11799 case Real_8: 11800 num = RANGE_REAL8_F90; 11801 break; 11802 11803 case Real_16: 11804 num = RANGE_REAL16_F90; 11805 break; 11806 11807 case Integer_1: 11808 num = RANGE_INT1_F90; 11809 break; 11810 11811 case Integer_2: 11812 num = RANGE_INT2_F90; 11813 break; 11814 11815 case Integer_4: 11816 num = RANGE_INT4_F90; 11817 break; 11818 11819 case Integer_8: 11820 num = RANGE_INT8_F90; 11821 11822 # ifdef _TARGET_HAS_FAST_INTEGER 11823 if (opt_flags.set_allfastint_option || 11824 (opt_flags.set_fastint_option && 11825 (TYP_DESC(arg_info_list[info_idx1].ed.type_idx) == 11826 Default_Typed))) { 11827 num = 13; 11828 } 11829 # endif 11830 11831 break; 11832 } 11833 11834 11835 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 11836 11837 OPND_IDX((*result_opnd)) = cn_idx; 11838 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 11839 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 11840 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 11841 res_exp_desc->constant = TRUE; 11842 res_exp_desc->foldable = TRUE; 11843 11844 # endif 11845 11846 res_exp_desc->foldable = FALSE; 11847 res_exp_desc->will_fold_later = FALSE; 11848 11849 TRACE (Func_Exit, "range_intrinsic", NULL); 11850 11851 } /* range_intrinsic */ 11852 11853 11854 /******************************************************************************\ 11855 |* *| 11856 |* Description: *| 11857 |* Function PRECISION(X) intrinsic. *| 11858 |* *| 11859 |* Input parameters: *| 11860 |* NONE *| 11861 |* *| 11862 |* Output parameters: *| 11863 |* NONE *| 11864 |* *| 11865 |* Returns: *| 11866 |* NOTHING *| 11867 |* *| 11868 \******************************************************************************/ 11869 11870 void precision_intrinsic(opnd_type *result_opnd, 11871 expr_arg_type *res_exp_desc, 11872 int *spec_idx) 11873 { 11874 int ir_idx; 11875 int cn_idx; 11876 int info_idx1; 11877 long num; 11878 11879 11880 TRACE (Func_Entry, "precision_intrinsic", NULL); 11881 11882 ir_idx = OPND_IDX((*result_opnd)); 11883 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 11884 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 11885 11886 conform_check(0, 11887 ir_idx, 11888 res_exp_desc, 11889 spec_idx, 11890 TRUE); 11891 11892 res_exp_desc->rank = 0; 11893 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 11894 IR_RANK(ir_idx) = res_exp_desc->rank; 11895 11896 switch (arg_info_list[info_idx1].ed.linear_type) { 11897 case Complex_4: 11898 num = PRECISION_REAL4_F90; 11899 break; 11900 11901 case Complex_8: 11902 num = PRECISION_REAL8_F90; 11903 break; 11904 11905 case Complex_16: 11906 num = PRECISION_REAL16_F90; 11907 break; 11908 11909 case Real_4: 11910 num = PRECISION_REAL4_F90; 11911 break; 11912 11913 case Real_8: 11914 num = PRECISION_REAL8_F90; 11915 break; 11916 11917 case Real_16: 11918 num = PRECISION_REAL16_F90; 11919 break; 11920 } 11921 11922 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 11923 11924 OPND_IDX((*result_opnd)) = cn_idx; 11925 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 11926 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 11927 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 11928 res_exp_desc->constant = TRUE; 11929 res_exp_desc->foldable = TRUE; 11930 11931 TRACE (Func_Exit, "precision_intrinsic", NULL); 11932 11933 } /* precision_intrinsic */ 11934 11935 11936 /******************************************************************************\ 11937 |* *| 11938 |* Description: *| 11939 |* Function KIND(X) intrinsic. *| 11940 |* *| 11941 |* Input parameters: *| 11942 |* NONE *| 11943 |* *| 11944 |* Output parameters: *| 11945 |* NONE *| 11946 |* *| 11947 |* Returns: *| 11948 |* NOTHING *| 11949 |* *| 11950 \******************************************************************************/ 11951 11952 void kind_intrinsic(opnd_type *result_opnd, 11953 expr_arg_type *res_exp_desc, 11954 int *spec_idx) 11955 { 11956 int ir_idx; 11957 int cn_idx; 11958 int list_idx1; 11959 int info_idx1; 11960 long num; 11961 11962 11963 TRACE (Func_Entry, "kind_intrinsic", NULL); 11964 11965 ir_idx = OPND_IDX((*result_opnd)); 11966 list_idx1 = IR_IDX_R(ir_idx); 11967 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 11968 11969 if (IL_FLD(list_idx1) == AT_Tbl_Idx) { 11970 AT_ARG_TO_KIND(IL_IDX(list_idx1)) = TRUE; 11971 } 11972 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 11973 11974 conform_check(0, 11975 ir_idx, 11976 res_exp_desc, 11977 spec_idx, 11978 TRUE); 11979 11980 res_exp_desc->rank = 0; 11981 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 11982 IR_RANK(ir_idx) = res_exp_desc->rank; 11983 11984 11985 switch (arg_info_list[info_idx1].ed.linear_type) { 11986 case Complex_4: 11987 num = 4; 11988 break; 11989 11990 case Complex_8: 11991 num = 8; 11992 break; 11993 11994 case Complex_16: 11995 num = 16; 11996 break; 11997 11998 case Real_4: 11999 num = 4; 12000 break; 12001 12002 case Real_8: 12003 num = 8; 12004 break; 12005 12006 case Real_16: 12007 num = 16; 12008 break; 12009 12010 case Integer_1: 12011 num = 1; 12012 break; 12013 12014 case Integer_2: 12015 num = 2; 12016 break; 12017 12018 case Integer_4: 12019 num = 4; 12020 break; 12021 12022 case Integer_8: 12023 num = 8; 12024 break; 12025 12026 case Logical_1: 12027 num = 1; 12028 break; 12029 12030 case Logical_2: 12031 num = 2; 12032 break; 12033 12034 case Logical_4: 12035 num = 4; 12036 break; 12037 12038 case Logical_8: 12039 num = 8; 12040 break; 12041 12042 case Short_Char_Const: 12043 num = 1; 12044 break; 12045 12046 case Character_1: 12047 num = 1; 12048 break; 12049 12050 case Character_2: 12051 num = 2; 12052 break; 12053 12054 case Character_4: 12055 num = 4; 12056 break; 12057 } 12058 12059 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 12060 12061 OPND_IDX((*result_opnd)) = cn_idx; 12062 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 12063 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 12064 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 12065 res_exp_desc->constant = TRUE; 12066 res_exp_desc->foldable = TRUE; 12067 12068 if (TYP_DESC(arg_info_list[info_idx1].ed.type_idx) == Default_Typed) { 12069 12070 if (arg_info_list[info_idx1].ed.linear_type == 12071 init_default_linear_type[Fortran_Double] || 12072 (TYP_DP_HIT_ME(arg_info_list[info_idx1].ed.type_idx) && 12073 arg_info_list[info_idx1].ed.linear_type == 12074 half_linear_type[Fortran_Double])) { 12075 12076 res_exp_desc->kind0D0seen = TRUE; 12077 } 12078 else if (arg_info_list[info_idx1].ed.linear_type == REAL_DEFAULT_TYPE && 12079 ! TYP_DP_HIT_ME(arg_info_list[info_idx1].ed.type_idx)) { 12080 12081 res_exp_desc->kind0E0seen = TRUE; 12082 } 12083 else if (arg_info_list[info_idx1].ed.linear_type == 12084 INTEGER_DEFAULT_TYPE || 12085 arg_info_list[info_idx1].ed.linear_type == 12086 LOGICAL_DEFAULT_TYPE) { 12087 12088 res_exp_desc->kind0seen = TRUE; 12089 } 12090 else { 12091 res_exp_desc->kindnotconst = TRUE; 12092 } 12093 } 12094 12095 12096 12097 TRACE (Func_Exit, "eind_intrinsic", NULL); 12098 12099 } /* kind_intrinsic */ 12100 12101 12102 /******************************************************************************\ 12103 |* *| 12104 |* Description: *| 12105 |* Function BIT_SIZE(I) intrinsic. *| 12106 |* *| 12107 |* Input parameters: *| 12108 |* NONE *| 12109 |* *| 12110 |* Output parameters: *| 12111 |* NONE *| 12112 |* *| 12113 |* Returns: *| 12114 |* NOTHING *| 12115 |* *| 12116 \******************************************************************************/ 12117 12118 void bit_size_intrinsic(opnd_type *result_opnd, 12119 expr_arg_type *res_exp_desc, 12120 int *spec_idx) 12121 { 12122 int ir_idx; 12123 int cn_idx; 12124 int info_idx1; 12125 long num; 12126 12127 12128 TRACE (Func_Entry, "bit_size_intrinsic", NULL); 12129 12130 ir_idx = OPND_IDX((*result_opnd)); 12131 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 12132 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 12133 12134 conform_check(0, 12135 ir_idx, 12136 res_exp_desc, 12137 spec_idx, 12138 TRUE); 12139 res_exp_desc->rank = 0; 12140 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 12141 IR_RANK(ir_idx) = res_exp_desc->rank; 12142 12143 # if 0 12144 12145 switch (arg_info_list[info_idx1].ed.linear_type) { 12146 case Integer_1: 12147 num = BITSIZE_INT1_F90; 12148 break; 12149 12150 case Integer_2: 12151 num = BITSIZE_INT2_F90; 12152 break; 12153 12154 case Integer_4: 12155 num = BITSIZE_INT4_F90; 12156 break; 12157 12158 case Integer_8: 12159 num = BITSIZE_INT8_F90; 12160 break; 12161 } 12162 12163 cn_idx = C_INT_TO_CN(arg_info_list[info_idx1].ed.type_idx, num); 12164 12165 OPND_IDX((*result_opnd)) = cn_idx; 12166 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 12167 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 12168 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 12169 res_exp_desc->constant = TRUE; 12170 res_exp_desc->foldable = TRUE; 12171 12172 # endif 12173 res_exp_desc->foldable = FALSE; 12174 res_exp_desc->will_fold_later = FALSE; 12175 12176 TRACE (Func_Exit, "bit_size_intrinsic", NULL); 12177 12178 } /* bit_size_intrinsic */ 12179 12180 12181 /******************************************************************************\ 12182 |* *| 12183 |* Description: *| 12184 |* Function LBOUND(ARRAY, DIM) intrinsic. *| 12185 |* *| 12186 |* Input parameters: *| 12187 |* NONE *| 12188 |* *| 12189 |* Output parameters: *| 12190 |* NONE *| 12191 |* *| 12192 |* Returns: *| 12193 |* NOTHING *| 12194 |* *| 12195 \******************************************************************************/ 12196 void lbound_intrinsic(opnd_type *result_opnd, 12197 expr_arg_type *res_exp_desc, 12198 int *spec_idx) 12199 { 12200 int select; 12201 int asg_idx; 12202 int attr_idx = NULL_IDX; 12203 int subscript_idx; 12204 long64 bit_length; 12205 int constant_type_idx; 12206 long dim; 12207 int arg1; 12208 int arg2; 12209 int arg3; 12210 int ir_idx; 12211 int il_idx; 12212 int le_idx; 12213 int eq_idx; 12214 int array_attr; 12215 boolean ok; 12216 int i; 12217 int idx; 12218 int idx2; 12219 int bd_idx; 12220 int new_idx; 12221 int cn_idx; 12222 opnd_type opnd; 12223 opnd_type base_opnd; 12224 int info_idx1; 12225 int info_idx2; 12226 int list_idx1; 12227 int list_idx2; 12228 int line; 12229 int col; 12230 boolean make_const_tmp = FALSE; 12231 int the_cn_idx; 12232 int tmp_idx; 12233 expr_arg_type loc_exp_desc; 12234 int expr_IDX[MAX_NUM_DIMS]; 12235 fld_type expr_FLD[MAX_NUM_DIMS]; 12236 int save_arg3; 12237 # ifdef _WHIRL_HOST64_TARGET64 12238 int const_array[MAX_NUM_DIMS]; 12239 # else 12240 long_type const_array[MAX_NUM_DIMS]; 12241 # endif /* _WHIRL_HOST64_TARGET64 */ 12242 long64 host_array[MAX_NUM_DIMS]; 12243 12244 12245 TRACE (Func_Entry, "lbound_intrinsic", NULL); 12246 12247 for (i = 0; i < MAX_NUM_DIMS; i++) { 12248 expr_IDX[i] = NULL_IDX; 12249 expr_FLD[i] = NO_Tbl_Idx; 12250 host_array[i] = 0; 12251 } 12252 12253 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 12254 12255 ir_idx = OPND_IDX((*result_opnd)); 12256 list_idx1 = IR_IDX_R(ir_idx); 12257 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 12258 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 12259 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 12260 12261 if (arg_info_list[info_idx1].ed.reference) { 12262 attr_idx = find_base_attr(&IL_OPND(list_idx1), &line, &col); 12263 } 12264 12265 conform_check(0, 12266 ir_idx, 12267 res_exp_desc, 12268 spec_idx, 12269 TRUE); 12270 12271 12272 /* assume these for now */ 12273 res_exp_desc->foldable = FALSE; 12274 res_exp_desc->will_fold_later = FALSE; 12275 12276 if (arg_info_list[info_idx1].ed.rank == 0) { 12277 PRINTMSG(arg_info_list[info_idx1].line, 640, Error, 12278 arg_info_list[info_idx1].col); 12279 } 12280 12281 if (list_idx2 != NULL_IDX && IL_IDX(list_idx2) != NULL_IDX) { 12282 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 12283 12284 if (IL_FLD(list_idx2) == CN_Tbl_Idx && 12285 (compare_cn_and_value(IL_IDX(list_idx2), 1, Lt_Opr) || 12286 compare_cn_and_value(IL_IDX(list_idx2), 12287 (long) arg_info_list[info_idx1].ed.rank, 12288 Gt_Opr))) { 12289 12290 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx2), 12291 &line, 12292 &col); 12293 PRINTMSG(line, 1012, Error, col); 12294 goto EXIT; 12295 } 12296 12297 if (arg_info_list[info_idx2].ed.rank != 0) { 12298 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 12299 arg_info_list[info_idx2].col); 12300 goto EXIT; 12301 } 12302 12303 res_exp_desc->rank = 0; 12304 12305 if (arg_info_list[info_idx2].ed.reference) { 12306 attr_idx = find_base_attr(&IL_OPND(list_idx2), &line, &col); 12307 12308 if (AT_OPTIONAL(attr_idx)) { 12309 PRINTMSG(arg_info_list[info_idx2].line, 875, Error, 12310 arg_info_list[info_idx2].col); 12311 } 12312 } 12313 12314 # if 0 12315 12316 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { /* DIM is a constant */ 12317 12318 dim = (long) CN_INT_TO_C(IL_IDX(list_idx2)); 12319 12320 if ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 12321 (IR_OPR(IL_IDX(list_idx1)) == Whole_Subscript_Opr || 12322 (IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 12323 IR_FLD_L(IL_IDX(list_idx1)) == IR_Tbl_Idx && 12324 IR_OPR(IR_IDX_L(IL_IDX(list_idx1))) == Whole_Subscript_Opr))) { 12325 12326 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 12327 12328 COPY_OPND(opnd, IL_OPND(list_idx1)); 12329 array_attr = find_base_attr(&opnd, &line, &col); 12330 12331 bd_idx = ATD_ARRAY_IDX(array_attr); 12332 12333 /* find the whole_subscript for lower bound info */ 12334 /* bounds entries don't have it for dope vectors */ 12335 12336 idx = IL_IDX(list_idx1); 12337 12338 if (IR_OPR(idx) == Whole_Substring_Opr) { 12339 idx = IR_IDX_L(idx); 12340 } 12341 12342 idx = IR_IDX_R(idx); /* first dim IL */ 12343 12344 for (i = 1; i < dim; i++) { 12345 idx = IL_NEXT_LIST_IDX(idx); 12346 } 12347 idx = IL_IDX(idx); /* sitting at Triplet_Opr */ 12348 idx = IR_IDX_L(idx); /* sitting at start value IL */ 12349 12350 if (arg_info_list[info_idx1].ed.shape[dim-1].fld == CN_Tbl_Idx) { 12351 12352 if (compare_cn_and_value( 12353 arg_info_list[info_idx1].ed.shape[dim-1].idx, 0, Le_Opr)) { 12354 12355 /* lbound of zero size dimension is 1 */ 12356 12357 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 12358 CN_INTEGER_ONE_IDX : 12359 C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 1); 12360 12361 OPND_IDX((*result_opnd)) = cn_idx; 12362 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 12363 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 12364 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 12365 } 12366 else { 12367 /* copy lbound from triplet */ 12368 COPY_OPND((*result_opnd), IL_OPND(idx)); 12369 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 12370 res_exp_desc->type_idx = 12371 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 12372 res_exp_desc->linear_type = 12373 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 12374 } 12375 12376 if (OPND_FLD((*result_opnd)) == CN_Tbl_Idx) { 12377 res_exp_desc->constant = TRUE; 12378 res_exp_desc->foldable = TRUE; 12379 } 12380 } 12381 else { 12382 12383 /* set up switch on the extent */ 12384 12385 NTR_IR_LIST_TBL(arg1); 12386 IL_ARG_DESC_VARIANT(arg1) = TRUE; 12387 12388 NTR_IR_LIST_TBL(arg2); 12389 IL_ARG_DESC_VARIANT(arg2) = TRUE; 12390 12391 NTR_IR_LIST_TBL(arg3); 12392 IL_ARG_DESC_VARIANT(arg3) = TRUE; 12393 12394 /* link list together */ 12395 IL_NEXT_LIST_IDX(arg1) = arg2; 12396 IL_NEXT_LIST_IDX(arg2) = arg3; 12397 12398 IR_OPR(ir_idx) = Cvmgt_Opr; 12399 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 12400 IR_IDX_L(ir_idx) = arg1; 12401 IR_LIST_CNT_L(ir_idx) = 3; 12402 12403 /* set this flag so this opr is pulled off io lists */ 12404 io_item_must_flatten = TRUE; 12405 12406 /* clear out right side, used to be arg list */ 12407 IR_OPND_R(ir_idx) = null_opnd; 12408 12409 IL_FLD(arg1) = CN_Tbl_Idx; 12410 IL_IDX(arg1) = CN_INTEGER_ONE_IDX; 12411 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 12412 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 12413 12414 COPY_OPND(IL_OPND(arg2), IL_OPND(idx)); 12415 12416 le_idx=gen_ir(OPND_FLD(arg_info_list[info_idx1].ed.shape[dim-1]), 12417 OPND_IDX(arg_info_list[info_idx1].ed.shape[dim-1]), 12418 Le_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 12419 IR_COL_NUM(ir_idx), 12420 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 12421 12422 IL_FLD(arg3) = IR_Tbl_Idx; 12423 IL_IDX(arg3) = le_idx; 12424 IL_LINE_NUM(arg3) = IR_LINE_NUM(ir_idx); 12425 IL_COL_NUM(arg3) = IR_COL_NUM(ir_idx); 12426 } 12427 } 12428 else if (IL_FLD(list_idx1) == AT_Tbl_Idx || 12429 (IL_FLD(list_idx1) == IR_Tbl_Idx && 12430 IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 12431 IR_FLD_L(IL_IDX(list_idx1)) == AT_Tbl_Idx)) { 12432 12433 /* it is assumed size array */ 12434 /* and whole array reference */ 12435 12436 if (IL_FLD(list_idx1) == AT_Tbl_Idx) { 12437 attr_idx = IL_IDX(list_idx1); 12438 } 12439 else { 12440 attr_idx = IR_IDX_L(IL_IDX(list_idx1)); 12441 } 12442 12443 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 12444 bd_idx = ATD_ARRAY_IDX(attr_idx); 12445 12446 if (dim == BD_RANK(bd_idx)) { 12447 OPND_IDX((*result_opnd)) = BD_LB_IDX(bd_idx, dim); 12448 OPND_FLD((*result_opnd)) = BD_LB_FLD(bd_idx, dim); 12449 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 12450 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 12451 12452 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 12453 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 12454 res_exp_desc->linear_type = 12455 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 12456 12457 if (OPND_FLD((*result_opnd)) == CN_Tbl_Idx) { 12458 res_exp_desc->constant = TRUE; 12459 res_exp_desc->foldable = TRUE; 12460 } 12461 } 12462 else if (BD_XT_FLD(bd_idx, dim) == CN_Tbl_Idx) { 12463 12464 if (compare_cn_and_value(BD_XT_IDX(bd_idx, dim), 0, Le_Opr)) { 12465 12466 /* lbound of zero size dimension is 1 */ 12467 12468 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 12469 CN_INTEGER_ONE_IDX : 12470 C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 1); 12471 12472 OPND_IDX((*result_opnd)) = cn_idx; 12473 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 12474 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 12475 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 12476 } 12477 else { 12478 OPND_IDX((*result_opnd)) = BD_LB_IDX(bd_idx, dim); 12479 OPND_FLD((*result_opnd)) = BD_LB_FLD(bd_idx, dim); 12480 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 12481 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 12482 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 12483 res_exp_desc->type_idx = 12484 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 12485 res_exp_desc->linear_type = 12486 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 12487 } 12488 12489 if (OPND_FLD((*result_opnd)) == CN_Tbl_Idx) { 12490 res_exp_desc->constant = TRUE; 12491 res_exp_desc->foldable = TRUE; 12492 } 12493 } 12494 else { 12495 12496 /* set up switch on the extent */ 12497 12498 NTR_IR_LIST_TBL(arg1); 12499 IL_ARG_DESC_VARIANT(arg1) = TRUE; 12500 12501 NTR_IR_LIST_TBL(arg2); 12502 IL_ARG_DESC_VARIANT(arg2) = TRUE; 12503 12504 NTR_IR_LIST_TBL(arg3); 12505 IL_ARG_DESC_VARIANT(arg3) = TRUE; 12506 12507 /* link list together */ 12508 IL_NEXT_LIST_IDX(arg1) = arg2; 12509 IL_NEXT_LIST_IDX(arg2) = arg3; 12510 12511 IR_OPR(ir_idx) = Cvmgt_Opr; 12512 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 12513 IR_IDX_L(ir_idx) = arg1; 12514 IR_LIST_CNT_L(ir_idx) = 3; 12515 12516 /* set this flag so this opr is pulled off io lists */ 12517 io_item_must_flatten = TRUE; 12518 12519 /* clear out right side, used to be arg list */ 12520 IR_OPND_R(ir_idx) = null_opnd; 12521 12522 IL_FLD(arg1) = CN_Tbl_Idx; 12523 IL_IDX(arg1) = CN_INTEGER_ONE_IDX; 12524 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 12525 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 12526 12527 IL_FLD(arg2) = BD_LB_FLD(bd_idx, dim); 12528 IL_IDX(arg2) = BD_LB_IDX(bd_idx, dim); 12529 IL_LINE_NUM(arg2) = IR_LINE_NUM(ir_idx); 12530 IL_COL_NUM(arg2) = IR_COL_NUM(ir_idx); 12531 12532 le_idx = gen_ir(BD_XT_FLD(bd_idx, dim), BD_XT_IDX(bd_idx, dim), 12533 Le_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 12534 IR_COL_NUM(ir_idx), 12535 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 12536 12537 IL_FLD(arg3) = IR_Tbl_Idx; 12538 IL_IDX(arg3) = le_idx; 12539 } 12540 } 12541 else if (arg_info_list[info_idx1].ed.section || 12542 ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 12543 (IR_OPR(IL_IDX(list_idx1)) != Whole_Subscript_Opr))) { 12544 12545 /* lbound is always one for section */ 12546 12547 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 12548 12549 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 12550 CN_INTEGER_ONE_IDX : 12551 C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 1); 12552 OPND_IDX((*result_opnd)) = cn_idx; 12553 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 12554 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 12555 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 12556 res_exp_desc->constant = TRUE; 12557 res_exp_desc->foldable = TRUE; 12558 } 12559 } 12560 else { 12561 /* dim is present, but not constant */ 12562 12563 COPY_OPND(opnd, IL_OPND(list_idx2)); 12564 cast_to_cg_default(&opnd, &(arg_info_list[info_idx2].ed)); 12565 COPY_OPND(IL_OPND(list_idx2), opnd); 12566 12567 if ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 12568 (IR_OPR(IL_IDX(list_idx1)) == Whole_Subscript_Opr || 12569 (IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 12570 IR_FLD_L(IL_IDX(list_idx1)) == IR_Tbl_Idx && 12571 IR_OPR(IR_IDX_L(IL_IDX(list_idx1))) == Whole_Subscript_Opr))) { 12572 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 12573 12574 COPY_OPND(opnd, IL_OPND(list_idx1)); 12575 array_attr = find_base_attr(&opnd, &line, &col); 12576 12577 bd_idx = ATD_ARRAY_IDX(array_attr); 12578 12579 /* find the whole_subscript for lower bound info */ 12580 /* bounds entries don't have it for dope vectors */ 12581 12582 idx = IL_IDX(list_idx1); 12583 12584 if (IR_OPR(idx) == Whole_Substring_Opr) { 12585 idx = IR_IDX_L(idx); 12586 } 12587 12588 il_idx = IR_IDX_R(idx); /* first dim IL */ 12589 idx = IL_IDX(il_idx); /* sitting at Triplet_Opr */ 12590 idx = IR_IDX_L(idx); /* sitting at start value IL */ 12591 12592 OPND_FLD(base_opnd) = CN_Tbl_Idx; 12593 OPND_IDX(base_opnd) = CN_INTEGER_ZERO_IDX; 12594 OPND_LINE_NUM(base_opnd) = IR_LINE_NUM(ir_idx); 12595 OPND_COL_NUM(base_opnd) = IR_COL_NUM(ir_idx); 12596 12597 for (i = 1; i <= arg_info_list[info_idx1].ed.rank; i++) { 12598 12599 NTR_IR_LIST_TBL(arg1); 12600 IL_ARG_DESC_VARIANT(arg1) = TRUE; 12601 NTR_IR_LIST_TBL(arg2); 12602 IL_ARG_DESC_VARIANT(arg2) = TRUE; 12603 NTR_IR_LIST_TBL(arg3); 12604 IL_ARG_DESC_VARIANT(arg3) = TRUE; 12605 12606 /* link list together */ 12607 IL_NEXT_LIST_IDX(arg1) = arg2; 12608 IL_NEXT_LIST_IDX(arg2) = arg3; 12609 12610 select = gen_ir(IL_Tbl_Idx, arg1, 12611 Cvmgt_Opr, INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 12612 IR_COL_NUM(ir_idx), 12613 NO_Tbl_Idx, NULL_IDX); 12614 12615 /* set this flag so this opr is pulled off io lists */ 12616 io_item_must_flatten = TRUE; 12617 12618 COPY_OPND(IL_OPND(arg1), IL_OPND(idx)); 12619 il_idx = IL_NEXT_LIST_IDX(il_idx); 12620 idx = IL_IDX(il_idx); /* sitting at Triplet_Opr */ 12621 idx = IR_IDX_L(idx); /* sitting at start value IL */ 12622 12623 COPY_OPND(IL_OPND(arg2), base_opnd); 12624 12625 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, i); 12626 12627 eq_idx = gen_ir(IL_FLD(list_idx2), IL_IDX(list_idx2), 12628 Eq_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 12629 IR_COL_NUM(ir_idx), 12630 CN_Tbl_Idx, cn_idx); 12631 12632 IL_FLD(arg3) = IR_Tbl_Idx; 12633 IL_IDX(arg3) = eq_idx; 12634 IL_LINE_NUM(arg3) = IR_LINE_NUM(ir_idx); 12635 IL_COL_NUM(arg3) = IR_COL_NUM(ir_idx); 12636 12637 OPND_FLD(base_opnd) = IR_Tbl_Idx; 12638 OPND_IDX(base_opnd) = select; 12639 } 12640 12641 /* set up switch on the extent */ 12642 12643 NTR_IR_LIST_TBL(arg1); 12644 IL_ARG_DESC_VARIANT(arg1) = TRUE; 12645 12646 NTR_IR_LIST_TBL(arg2); 12647 IL_ARG_DESC_VARIANT(arg2) = TRUE; 12648 12649 NTR_IR_LIST_TBL(arg3); 12650 IL_ARG_DESC_VARIANT(arg3) = TRUE; 12651 12652 /* link list together */ 12653 IL_NEXT_LIST_IDX(arg1) = arg2; 12654 IL_NEXT_LIST_IDX(arg2) = arg3; 12655 12656 IR_OPR(ir_idx) = Cvmgt_Opr; 12657 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 12658 IR_IDX_L(ir_idx) = arg1; 12659 IR_LIST_CNT_L(ir_idx) = 3; 12660 12661 /* set this flag so this opr is pulled off io lists */ 12662 io_item_must_flatten = TRUE; 12663 12664 /* clear out right side, used to be arg list */ 12665 IR_OPND_R(ir_idx) = null_opnd; 12666 12667 IL_FLD(arg1) = CN_Tbl_Idx; 12668 IL_IDX(arg1) = CN_INTEGER_ONE_IDX; 12669 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 12670 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 12671 12672 IL_FLD(arg2) = IR_Tbl_Idx; 12673 IL_IDX(arg2) = select; 12674 12675 save_arg3 = arg3; 12676 12677 OPND_FLD(base_opnd) = CN_Tbl_Idx; 12678 OPND_IDX(base_opnd) = CN_INTEGER_ZERO_IDX; 12679 OPND_LINE_NUM(base_opnd) = IR_LINE_NUM(ir_idx); 12680 OPND_COL_NUM(base_opnd) = IR_COL_NUM(ir_idx); 12681 12682 for (i = 1; i <= arg_info_list[info_idx1].ed.rank; i++) { 12683 12684 NTR_IR_LIST_TBL(arg1); 12685 IL_ARG_DESC_VARIANT(arg1) = TRUE; 12686 NTR_IR_LIST_TBL(arg2); 12687 IL_ARG_DESC_VARIANT(arg2) = TRUE; 12688 NTR_IR_LIST_TBL(arg3); 12689 IL_ARG_DESC_VARIANT(arg3) = TRUE; 12690 12691 /* link list together */ 12692 IL_NEXT_LIST_IDX(arg1) = arg2; 12693 IL_NEXT_LIST_IDX(arg2) = arg3; 12694 12695 select = gen_ir(IL_Tbl_Idx, arg1, 12696 Cvmgt_Opr, INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 12697 IR_COL_NUM(ir_idx), 12698 NO_Tbl_Idx, NULL_IDX); 12699 12700 /* set this flag so this opr is pulled off io lists */ 12701 io_item_must_flatten = TRUE; 12702 12703 COPY_OPND(IL_OPND(arg1), 12704 arg_info_list[info_idx1].ed.shape[i-1]); 12705 COPY_OPND(IL_OPND(arg2), base_opnd); 12706 12707 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, i); 12708 12709 eq_idx = gen_ir(IL_FLD(list_idx2), IL_IDX(list_idx2), 12710 Eq_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 12711 IR_COL_NUM(ir_idx), 12712 CN_Tbl_Idx, cn_idx); 12713 12714 IL_FLD(arg3) = IR_Tbl_Idx; 12715 IL_IDX(arg3) = eq_idx; 12716 IL_LINE_NUM(arg3) = IR_LINE_NUM(ir_idx); 12717 IL_COL_NUM(arg3) = IR_COL_NUM(ir_idx); 12718 12719 OPND_FLD(base_opnd) = IR_Tbl_Idx; 12720 OPND_IDX(base_opnd) = select; 12721 } 12722 12723 le_idx = gen_ir(IR_Tbl_Idx, select, 12724 Le_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 12725 IR_COL_NUM(ir_idx), 12726 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 12727 12728 IL_FLD(save_arg3) = IR_Tbl_Idx; 12729 IL_IDX(save_arg3) = le_idx; 12730 } 12731 else if (IL_FLD(list_idx1) == AT_Tbl_Idx || 12732 (IL_FLD(list_idx1) == IR_Tbl_Idx && 12733 IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 12734 IR_FLD_L(IL_IDX(list_idx1)) == AT_Tbl_Idx)) { 12735 12736 /* it is assumed size array */ 12737 /* and whole array reference */ 12738 12739 /* this case will still go to an external library call */ 12740 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 12741 } 12742 else if (arg_info_list[info_idx1].ed.section || 12743 ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 12744 (IR_OPR(IL_IDX(list_idx1)) != Whole_Subscript_Opr))) { 12745 /* lbound is always one for section */ 12746 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 12747 12748 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 12749 CN_INTEGER_ONE_IDX : 12750 C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 1); 12751 12752 OPND_IDX((*result_opnd)) = cn_idx; 12753 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 12754 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 12755 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 12756 res_exp_desc->constant = TRUE; 12757 res_exp_desc->foldable = TRUE; 12758 } 12759 } 12760 12761 #endif 12762 12763 } 12764 else { /* DIM is not present */ 12765 12766 # if 0 12767 12768 res_exp_desc->shape[0].fld = CN_Tbl_Idx; 12769 res_exp_desc->shape[0].idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 12770 res_exp_desc->rank); 12771 SHAPE_WILL_FOLD_LATER(res_exp_desc->shape[0]) = TRUE; 12772 SHAPE_FOLDABLE(res_exp_desc->shape[0]) = TRUE; 12773 12774 res_exp_desc->rank = 1; 12775 12776 if (IR_LIST_CNT_R(ir_idx) == 1) { 12777 IR_LIST_CNT_R(ir_idx) = 2; 12778 NTR_IR_LIST_TBL(new_idx); 12779 IL_INTRIN_PLACE_HOLDER(new_idx) = TRUE; 12780 IL_ARG_DESC_VARIANT(new_idx) = TRUE; 12781 IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)) = new_idx; 12782 } 12783 12784 12785 if ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 12786 (IR_OPR(IL_IDX(list_idx1)) == Whole_Subscript_Opr || 12787 (IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 12788 IR_FLD_L(IL_IDX(list_idx1)) == IR_Tbl_Idx && 12789 IR_OPR(IR_IDX_L(IL_IDX(list_idx1))) == Whole_Subscript_Opr))) { 12790 12791 12792 COPY_OPND(opnd, IL_OPND(list_idx1)); 12793 array_attr = find_base_attr(&opnd, &line, &col); 12794 12795 bd_idx = ATD_ARRAY_IDX(array_attr); 12796 12797 /* find the whole_subscript for lower bound info */ 12798 /* bounds entries don't have it for dope vectors */ 12799 12800 idx = IL_IDX(list_idx1); 12801 12802 if (IR_OPR(idx) == Whole_Substring_Opr) { 12803 idx = IR_IDX_L(idx); 12804 } 12805 12806 idx = IR_IDX_R(idx); /* first dim IL */ 12807 12808 res_exp_desc->will_fold_later = TRUE; 12809 12810 for (i = 0; i < BD_RANK(bd_idx); i++) { 12811 12812 idx2 = IL_IDX(idx); /* sitting at Triplet_Opr */ 12813 idx2 = IR_IDX_L(idx2); /* sitting at start value IL */ 12814 12815 if (arg_info_list[info_idx1].ed.shape[i].fld != CN_Tbl_Idx || 12816 IL_FLD(idx2) != CN_Tbl_Idx) { 12817 12818 NTR_IR_LIST_TBL(arg1); 12819 IL_ARG_DESC_VARIANT(arg1) = TRUE; 12820 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 12821 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 12822 IL_FLD(arg1) = CN_Tbl_Idx; 12823 12824 /* lbound of zero size dimension is 1 */ 12825 12826 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 12827 CN_INTEGER_ONE_IDX : 12828 C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 1); 12829 12830 IL_IDX(arg1) = cn_idx; 12831 12832 NTR_IR_LIST_TBL(arg2); 12833 IL_ARG_DESC_VARIANT(arg2) = TRUE; 12834 IL_LINE_NUM(arg2) = IR_LINE_NUM(ir_idx); 12835 IL_COL_NUM(arg2) = IR_COL_NUM(ir_idx); 12836 IL_FLD(arg2) = IL_FLD(idx2); 12837 IL_IDX(arg2) = IL_IDX(idx2); 12838 12839 NTR_IR_LIST_TBL(arg3); 12840 IL_ARG_DESC_VARIANT(arg3) = TRUE; 12841 12842 le_idx = gen_ir(OPND_FLD(arg_info_list[info_idx1].ed.shape[i]), 12843 OPND_IDX(arg_info_list[info_idx1].ed.shape[i]), 12844 Le_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 12845 IR_COL_NUM(ir_idx), 12846 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 12847 12848 IL_FLD(arg3) = IR_Tbl_Idx; 12849 IL_IDX(arg3) = le_idx; 12850 12851 /* link list together */ 12852 IL_NEXT_LIST_IDX(arg1) = arg2; 12853 IL_NEXT_LIST_IDX(arg2) = arg3; 12854 12855 select = gen_ir(IL_Tbl_Idx, arg1, 12856 Cvmgt_Opr, INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 12857 IR_COL_NUM(ir_idx), 12858 NO_Tbl_Idx, NULL_IDX); 12859 12860 /* set this flag so this opr is pulled off io lists */ 12861 io_item_must_flatten = TRUE; 12862 12863 expr_IDX[i] = select; 12864 expr_FLD[i] = IR_Tbl_Idx; 12865 host_array[i] = 0; 12866 } 12867 else if (compare_cn_and_value(arg_info_list[info_idx1].ed. 12868 shape[i].idx, 12869 0, 12870 Le_Opr)) { 12871 host_array[i] = 1; 12872 } 12873 else { 12874 host_array[i] = CN_INT_TO_C(IL_IDX(idx2)); 12875 } 12876 12877 idx = IL_NEXT_LIST_IDX(idx); 12878 } 12879 } 12880 else if (arg_info_list[info_idx1].ed.section || 12881 ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 12882 (IR_OPR(IL_IDX(list_idx1)) != Whole_Subscript_Opr))) { 12883 12884 res_exp_desc->will_fold_later = TRUE; 12885 12886 for (i = 0; i < arg_info_list[info_idx1].ed.rank; i++) { 12887 host_array[i] = 1; 12888 } 12889 } 12890 else if (IL_FLD(list_idx1) == AT_Tbl_Idx || 12891 (IL_FLD(list_idx1) == IR_Tbl_Idx && 12892 IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 12893 IR_FLD_L(IL_IDX(list_idx1)) == AT_Tbl_Idx)) { 12894 12895 /* it is assumed size array */ 12896 12897 if (IL_FLD(list_idx1) == AT_Tbl_Idx) { 12898 attr_idx = IL_IDX(list_idx1); 12899 } 12900 else { 12901 attr_idx = IR_IDX_L(IL_IDX(list_idx1)); 12902 } 12903 12904 bd_idx = ATD_ARRAY_IDX(attr_idx); 12905 12906 res_exp_desc->will_fold_later = TRUE; 12907 12908 for (i = 1; i < BD_RANK(bd_idx); i++) { 12909 12910 if (BD_LB_FLD(bd_idx, i) != CN_Tbl_Idx || 12911 BD_XT_FLD(bd_idx, i) != CN_Tbl_Idx) { 12912 12913 res_exp_desc->will_fold_later = FALSE; 12914 break; 12915 } 12916 else if (compare_cn_and_value(BD_XT_IDX(bd_idx, i), 0, Le_Opr)) { 12917 host_array[(i-1)] = 1; 12918 } 12919 else { 12920 host_array[(i-1)] = CN_INT_TO_C(BD_LB_IDX(bd_idx,i)); 12921 } 12922 } 12923 12924 if (BD_LB_FLD(bd_idx, BD_RANK(bd_idx)) != CN_Tbl_Idx) { 12925 res_exp_desc->will_fold_later = FALSE; 12926 } 12927 else { 12928 host_array[(BD_RANK(bd_idx)-1)] = CN_INT_TO_C( 12929 BD_LB_IDX(bd_idx, BD_RANK(bd_idx))); 12930 } 12931 } 12932 12933 if (res_exp_desc->will_fold_later) { 12934 make_const_tmp = TRUE; 12935 } 12936 12937 # endif 12938 12939 } 12940 12941 # if 0 12942 12943 if (make_const_tmp) { 12944 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 12945 bit_length = TARGET_BITS_PER_WORD * arg_info_list[info_idx1].ed.rank; 12946 # ifdef _WHIRL_HOST64_TARGET64 12947 bit_length >>= 1; 12948 # endif /* _WHIRL_HOST64_TARGET64 */ 12949 12950 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 12951 TYP_TYPE(TYP_WORK_IDX) = Typeless; 12952 TYP_BIT_LEN(TYP_WORK_IDX) = bit_length; 12953 constant_type_idx = ntr_type_tbl(); 12954 12955 for (i = 0; i < MAX_NUM_DIMS; i++) { 12956 12957 # if defined(_TARGET32) 12958 12959 /* Make sure that if Integer_8 is default that */ 12960 /* the values still fit in the long container. */ 12961 12962 if (INTEGER_DEFAULT_TYPE == Integer_8) { 12963 /* JEFFL - Need overflow check here for each array entry */ 12964 12965 } 12966 # endif 12967 /* JEFFL - This needs to be converted from host to */ 12968 /* target if we decide that is necessary. */ 12969 12970 const_array[i] = (long_type) host_array[i]; 12971 } 12972 12973 the_cn_idx = ntr_const_tbl(constant_type_idx, 12974 FALSE, 12975 const_array); 12976 12977 12978 tmp_idx = gen_compiler_tmp(IR_LINE_NUM(ir_idx), 12979 IR_COL_NUM(ir_idx), 12980 Shared, TRUE); 12981 12982 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 12983 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE; 12984 12985 loc_exp_desc = *res_exp_desc; 12986 loc_exp_desc.type_idx = CG_INTEGER_DEFAULT_TYPE; 12987 loc_exp_desc.type = Integer; 12988 loc_exp_desc.linear_type = CG_INTEGER_DEFAULT_TYPE; 12989 12990 ATD_ARRAY_IDX(tmp_idx) = create_bd_ntry_for_const(&loc_exp_desc, 12991 IR_LINE_NUM(ir_idx), 12992 IR_COL_NUM(ir_idx)); 12993 12994 ATD_SAVED(tmp_idx) = TRUE; 12995 ATD_DATA_INIT(tmp_idx) = TRUE; 12996 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 12997 ATD_FLD(tmp_idx) = CN_Tbl_Idx; 12998 ATD_TMP_IDX(tmp_idx) = the_cn_idx; 12999 ATD_TMP_INIT_NOT_DONE(tmp_idx) = TRUE; 13000 13001 OPND_IDX((*result_opnd)) = tmp_idx; 13002 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 13003 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 13004 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 13005 13006 ok = gen_whole_subscript(result_opnd, res_exp_desc); 13007 13008 if (CG_INTEGER_DEFAULT_TYPE != INTEGER_DEFAULT_TYPE) { 13009 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 13010 13011 ok = fold_aggragate_expression(result_opnd, 13012 res_exp_desc, 13013 FALSE); 13014 13015 if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx) { 13016 idx = OPND_IDX((*result_opnd)); 13017 if (IR_FLD_L(idx) == AT_Tbl_Idx) { 13018 tmp_idx = IR_IDX_L(idx); 13019 } 13020 } 13021 } 13022 13023 AT_REFERENCED(tmp_idx) = Referenced; 13024 AT_DEFINED(tmp_idx) = TRUE; 13025 13026 res_exp_desc->foldable = TRUE; 13027 res_exp_desc->tmp_reference = TRUE; 13028 } 13029 13030 /* This for loop generates individual assignment statements */ 13031 /* in the IR stream to update those elements of the result */ 13032 /* array that are runtime values. */ 13033 for (i = 0; i < MAX_NUM_DIMS; i++) { 13034 if (expr_IDX[i] != NULL_IDX) { 13035 res_exp_desc->foldable = FALSE; 13036 res_exp_desc->will_fold_later = FALSE; 13037 13038 NTR_IR_LIST_TBL(idx); 13039 IL_FLD(idx) = CN_Tbl_Idx; 13040 13041 IL_IDX(idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, i+1); 13042 IL_LINE_NUM(idx) = IR_LINE_NUM(ir_idx); 13043 IL_COL_NUM(idx) = IR_COL_NUM(ir_idx); 13044 13045 NTR_IR_TBL(subscript_idx); 13046 IR_TYPE_IDX(subscript_idx) = CG_INTEGER_DEFAULT_TYPE; 13047 IR_OPR(subscript_idx) = Subscript_Opr; 13048 IR_LINE_NUM(subscript_idx) = IR_LINE_NUM(ir_idx); 13049 IR_COL_NUM(subscript_idx) = IR_COL_NUM(ir_idx); 13050 IR_FLD_L(subscript_idx) = AT_Tbl_Idx; 13051 IR_IDX_L(subscript_idx) = tmp_idx; 13052 IR_LINE_NUM_L(subscript_idx) = IR_LINE_NUM(ir_idx); 13053 IR_COL_NUM_L(subscript_idx) = IR_COL_NUM(ir_idx); 13054 IR_FLD_R(subscript_idx) = IL_Tbl_Idx; 13055 IR_IDX_R(subscript_idx) = idx; 13056 IR_LINE_NUM_R(subscript_idx) = IR_LINE_NUM(ir_idx); 13057 IR_COL_NUM_R(subscript_idx) = IR_COL_NUM(ir_idx); 13058 IR_LIST_CNT_R(subscript_idx) = 1; 13059 13060 asg_idx = gen_ir(IR_Tbl_Idx, subscript_idx, 13061 Asg_Opr, INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13062 IR_COL_NUM(ir_idx), 13063 expr_FLD[i], expr_IDX[i]); 13064 13065 gen_sh(Before, 13066 Assignment_Stmt, 13067 IR_LINE_NUM(ir_idx), 13068 IR_COL_NUM(ir_idx), 13069 FALSE, 13070 FALSE, 13071 TRUE); 13072 13073 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 13074 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13075 } 13076 } 13077 13078 # endif 13079 13080 EXIT: 13081 13082 if (OPND_FLD((*result_opnd)) != IR_Tbl_Idx || 13083 IR_OPR(OPND_IDX((*result_opnd))) != Call_Opr) { 13084 13085 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 13086 } 13087 13088 IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE; 13089 IR_RANK(ir_idx) = res_exp_desc->rank; 13090 13091 res_exp_desc->foldable = FALSE; 13092 res_exp_desc->will_fold_later = FALSE; 13093 13094 TRACE (Func_Exit, "lbound_intrinsic", NULL); 13095 13096 } /* lbound_intrinsic */ 13097 13098 13099 /******************************************************************************\ 13100 |* *| 13101 |* Description: *| 13102 |* Function UBOUND(ARRAY, DIM) intrinsic. *| 13103 |* *| 13104 |* Input parameters: *| 13105 |* NONE *| 13106 |* *| 13107 |* Output parameters: *| 13108 |* NONE *| 13109 |* *| 13110 |* Returns: *| 13111 |* NOTHING *| 13112 |* *| 13113 \******************************************************************************/ 13114 void ubound_intrinsic(opnd_type *result_opnd, 13115 expr_arg_type *res_exp_desc, 13116 int *spec_idx) 13117 { 13118 int asg_idx; 13119 int attr_idx = NULL_IDX; 13120 int select; 13121 long64 bit_length; 13122 int constant_type_idx; 13123 long dim; 13124 int arg1; 13125 int arg2; 13126 int arg3; 13127 int ir_idx; 13128 int il_idx; 13129 int le_idx; 13130 int eq_idx; 13131 int array_attr; 13132 # ifdef _WHIRL_HOST64_TARGET64 13133 int const_array[MAX_NUM_DIMS]; 13134 # else 13135 long_type const_array[MAX_NUM_DIMS]; 13136 # endif /* _WHIRL_HOST64_TARGET64 */ 13137 long64 host_array[MAX_NUM_DIMS]; 13138 int expr_IDX[MAX_NUM_DIMS]; 13139 fld_type expr_FLD[MAX_NUM_DIMS]; 13140 boolean ok; 13141 int idx; 13142 int idx2; 13143 int i; 13144 int bd_idx; 13145 int new_idx; 13146 int cn_idx; 13147 opnd_type opnd; 13148 opnd_type base_opnd; 13149 int info_idx1; 13150 int info_idx2; 13151 int list_idx1; 13152 int list_idx2; 13153 int line; 13154 int col; 13155 boolean make_const_tmp = FALSE; 13156 int the_cn_idx; 13157 int tmp_idx; 13158 int subscript_idx; 13159 expr_arg_type loc_exp_desc; 13160 int save_arg3; 13161 13162 13163 TRACE (Func_Entry, "ubound_intrinsic", NULL); 13164 13165 for (i = 0; i < MAX_NUM_DIMS; i++) { 13166 expr_IDX[i] = NULL_IDX; 13167 expr_FLD[i] = NO_Tbl_Idx; 13168 host_array[i] = 0; 13169 } 13170 13171 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 13172 13173 ir_idx = OPND_IDX((*result_opnd)); 13174 list_idx1 = IR_IDX_R(ir_idx); 13175 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 13176 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 13177 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 13178 13179 if (arg_info_list[info_idx1].ed.reference) { 13180 attr_idx = find_base_attr(&IL_OPND(list_idx1), &line, &col); 13181 } 13182 13183 conform_check(0, 13184 ir_idx, 13185 res_exp_desc, 13186 spec_idx, 13187 TRUE); 13188 13189 /* assume these for now */ 13190 res_exp_desc->foldable = FALSE; 13191 res_exp_desc->will_fold_later = FALSE; 13192 13193 if (arg_info_list[info_idx1].ed.rank == 0) { 13194 PRINTMSG(arg_info_list[info_idx1].line, 640, Error, 13195 arg_info_list[info_idx1].col); 13196 } 13197 13198 if (list_idx2 != NULL_IDX && IL_IDX(list_idx2) != NULL_IDX) { 13199 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 13200 13201 if (IL_FLD(list_idx2) == CN_Tbl_Idx && 13202 (compare_cn_and_value(IL_IDX(list_idx2), 1, Lt_Opr) || 13203 compare_cn_and_value(IL_IDX(list_idx2), 13204 (long) arg_info_list[info_idx1].ed.rank, 13205 Gt_Opr))) { 13206 13207 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx2), 13208 &line, 13209 &col); 13210 PRINTMSG(line, 1012, Error, col); 13211 goto EXIT; 13212 } 13213 13214 13215 if (arg_info_list[info_idx2].ed.rank != 0) { 13216 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 13217 arg_info_list[info_idx2].col); 13218 goto EXIT; 13219 } 13220 13221 res_exp_desc->rank = 0; 13222 13223 if (arg_info_list[info_idx2].ed.reference) { 13224 attr_idx = find_base_attr(&IL_OPND(list_idx2), &line, &col); 13225 13226 if (AT_OPTIONAL(attr_idx)) { 13227 PRINTMSG(arg_info_list[info_idx2].line, 875, Error, 13228 arg_info_list[info_idx2].col); 13229 } 13230 } 13231 13232 # if 0 13233 13234 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { /* DIM is a constant */ 13235 dim = (long) CN_INT_TO_C(IL_IDX(list_idx2)); 13236 13237 if ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 13238 (IR_OPR(IL_IDX(list_idx1)) == Whole_Subscript_Opr || 13239 (IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 13240 IR_FLD_L(IL_IDX(list_idx1)) == IR_Tbl_Idx && 13241 IR_OPR(IR_IDX_L(IL_IDX(list_idx1))) == Whole_Subscript_Opr))) { 13242 13243 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 13244 13245 idx = IL_IDX(list_idx1); /* sitting at Whole_Subscript_Opr */ 13246 13247 if (IR_OPR(idx) == Whole_Substring_Opr) { 13248 idx = IR_IDX_L(idx); 13249 } 13250 13251 bd_idx = idx; 13252 idx = IR_IDX_R(idx); /* sitting at first IL */ 13253 13254 COPY_OPND(opnd, IR_OPND_L(bd_idx)); 13255 array_attr = find_base_attr(&opnd, &line, &col); 13256 13257 bd_idx = ATD_ARRAY_IDX(array_attr); 13258 13259 for (i = 1; i < dim; i++) { 13260 idx = IL_NEXT_LIST_IDX(idx); 13261 } 13262 idx = IL_IDX(idx); /* sitting at Triplet_Opr */ 13263 idx = IR_IDX_L(idx); /* sitting at start IL */ 13264 idx = IL_NEXT_LIST_IDX(idx); /* sitting at finish IL */ 13265 13266 if (arg_info_list[info_idx1].ed.shape[dim-1].fld == CN_Tbl_Idx) { 13267 13268 if (compare_cn_and_value( 13269 arg_info_list[info_idx1].ed.shape[dim-1].idx, 0, Le_Opr)) { 13270 /* ubound of zero size dim is 0 */ 13271 13272 OPND_IDX((*result_opnd)) = (CG_INTEGER_DEFAULT_TYPE == 13273 INTEGER_DEFAULT_TYPE) ? 13274 CN_INTEGER_ZERO_IDX : 13275 C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 0); 13276 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 13277 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 13278 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 13279 } 13280 else { 13281 /* copy ubound from triplet */ 13282 COPY_OPND((*result_opnd), IL_OPND(idx)); 13283 } 13284 13285 if (OPND_FLD((*result_opnd)) == CN_Tbl_Idx) { 13286 res_exp_desc->constant = TRUE; 13287 res_exp_desc->foldable = TRUE; 13288 } 13289 } 13290 else { 13291 13292 NTR_IR_LIST_TBL(arg1); 13293 IL_ARG_DESC_VARIANT(arg1) = TRUE; 13294 13295 NTR_IR_LIST_TBL(arg2); 13296 IL_ARG_DESC_VARIANT(arg2) = TRUE; 13297 13298 NTR_IR_LIST_TBL(arg3); 13299 IL_ARG_DESC_VARIANT(arg3) = TRUE; 13300 13301 /* link list together */ 13302 IL_NEXT_LIST_IDX(arg1) = arg2; 13303 IL_NEXT_LIST_IDX(arg2) = arg3; 13304 13305 IR_OPR(ir_idx) = Cvmgt_Opr; 13306 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 13307 IR_IDX_L(ir_idx) = arg1; 13308 IR_LIST_CNT_L(ir_idx) = 3; 13309 13310 /* set this flag so this opr is pulled off io lists */ 13311 io_item_must_flatten = TRUE; 13312 13313 /* clear out right side, used to be arg list */ 13314 IR_OPND_R(ir_idx) = null_opnd; 13315 13316 IL_FLD(arg1) = CN_Tbl_Idx; 13317 IL_IDX(arg1) = CN_INTEGER_ZERO_IDX; 13318 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 13319 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 13320 13321 COPY_OPND(IL_OPND(arg2), IL_OPND(idx)); 13322 13323 le_idx=gen_ir(OPND_FLD(arg_info_list[info_idx1].ed.shape[dim-1]), 13324 OPND_IDX(arg_info_list[info_idx1].ed.shape[dim-1]), 13325 Le_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13326 IR_COL_NUM(ir_idx), 13327 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 13328 13329 IL_FLD(arg3) = IR_Tbl_Idx; 13330 IL_IDX(arg3) = le_idx; 13331 13332 13333 } 13334 } 13335 else if (IL_FLD(list_idx1) == AT_Tbl_Idx || 13336 (IL_FLD(list_idx1) == IR_Tbl_Idx && 13337 IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 13338 IR_FLD_L(IL_IDX(list_idx1)) == AT_Tbl_Idx)) { 13339 13340 /* it is assumed size array */ 13341 13342 if (IL_FLD(list_idx1) == AT_Tbl_Idx) { 13343 attr_idx = IL_IDX(list_idx1); 13344 } 13345 else { 13346 attr_idx = IR_IDX_L(IL_IDX(list_idx1)); 13347 } 13348 13349 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 13350 bd_idx = ATD_ARRAY_IDX(attr_idx); 13351 13352 if (compare_cn_and_value(IL_IDX(list_idx2), 13353 (long) BD_RANK(bd_idx), 13354 Eq_Opr)) { 13355 13356 PRINTMSG(arg_info_list[info_idx1].line, 889, Error, 13357 arg_info_list[info_idx1].col); 13358 } 13359 else if (BD_XT_FLD(bd_idx, dim) == CN_Tbl_Idx) { 13360 13361 if (compare_cn_and_value(BD_XT_IDX(bd_idx, dim), 0, Le_Opr)) { 13362 /* ubound of zero size dimension is 0 */ 13363 OPND_IDX((*result_opnd)) = CN_INTEGER_ZERO_IDX; 13364 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 13365 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 13366 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 13367 } 13368 else { 13369 OPND_IDX((*result_opnd)) = BD_UB_IDX(bd_idx, dim); 13370 OPND_FLD((*result_opnd)) = BD_UB_FLD(bd_idx, dim); 13371 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 13372 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 13373 } 13374 13375 if (OPND_FLD((*result_opnd)) == CN_Tbl_Idx) { 13376 res_exp_desc->constant = TRUE; 13377 res_exp_desc->foldable = TRUE; 13378 } 13379 } 13380 else { 13381 13382 /* set up switch on the extent */ 13383 13384 NTR_IR_LIST_TBL(arg1); 13385 IL_ARG_DESC_VARIANT(arg1) = TRUE; 13386 13387 NTR_IR_LIST_TBL(arg2); 13388 IL_ARG_DESC_VARIANT(arg2) = TRUE; 13389 13390 NTR_IR_LIST_TBL(arg3); 13391 IL_ARG_DESC_VARIANT(arg3) = TRUE; 13392 13393 /* link list together */ 13394 IL_NEXT_LIST_IDX(arg1) = arg2; 13395 IL_NEXT_LIST_IDX(arg2) = arg3; 13396 13397 IR_OPR(ir_idx) = Cvmgt_Opr; 13398 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 13399 IR_IDX_L(ir_idx) = arg1; 13400 IR_LIST_CNT_L(ir_idx) = 3; 13401 13402 /* set this flag so this opr is pulled off io lists */ 13403 io_item_must_flatten = TRUE; 13404 13405 /* clear out right side, used to be arg list */ 13406 IR_OPND_R(ir_idx) = null_opnd; 13407 13408 IL_FLD(arg1) = CN_Tbl_Idx; 13409 IL_IDX(arg1) = CN_INTEGER_ONE_IDX; 13410 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 13411 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 13412 13413 IL_FLD(arg2) = BD_UB_FLD(bd_idx, dim); 13414 IL_IDX(arg2) = BD_UB_IDX(bd_idx, dim); 13415 IL_LINE_NUM(arg2) = IR_LINE_NUM(ir_idx); 13416 IL_COL_NUM(arg2) = IR_COL_NUM(ir_idx); 13417 13418 le_idx = gen_ir(BD_XT_FLD(bd_idx, dim), BD_XT_IDX(bd_idx, dim), 13419 Le_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13420 IR_COL_NUM(ir_idx), 13421 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 13422 13423 IL_FLD(arg3) = IR_Tbl_Idx; 13424 IL_IDX(arg3) = le_idx; 13425 } 13426 } 13427 else if (arg_info_list[info_idx1].ed.section || 13428 ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 13429 (IR_OPR(IL_IDX(list_idx1)) != Whole_Subscript_Opr))) { 13430 13431 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 13432 COPY_OPND((*result_opnd), 13433 arg_info_list[info_idx1].ed.shape[dim-1]); 13434 13435 cast_opnd_to_type_idx(result_opnd, res_exp_desc->type_idx); 13436 13437 if (OPND_FLD((*result_opnd)) == CN_Tbl_Idx) { 13438 res_exp_desc->constant = TRUE; 13439 res_exp_desc->foldable = TRUE; 13440 } 13441 else if (SHAPE_WILL_FOLD_LATER((*result_opnd)) || 13442 SHAPE_FOLDABLE((*result_opnd))) { 13443 13444 res_exp_desc->will_fold_later = TRUE; 13445 } 13446 13447 /* clear the two shape flags on the result opnd */ 13448 SHAPE_FOLDABLE((*result_opnd)) = FALSE; 13449 SHAPE_WILL_FOLD_LATER((*result_opnd)) = FALSE; 13450 } 13451 } 13452 else { 13453 /* dim is present, but not constant */ 13454 13455 COPY_OPND(opnd, IL_OPND(list_idx2)); 13456 cast_to_cg_default(&opnd, &(arg_info_list[info_idx2].ed)); 13457 COPY_OPND(IL_OPND(list_idx2), opnd); 13458 13459 if ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 13460 (IR_OPR(IL_IDX(list_idx1)) == Whole_Subscript_Opr || 13461 (IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 13462 IR_FLD_L(IL_IDX(list_idx1)) == IR_Tbl_Idx && 13463 IR_OPR(IR_IDX_L(IL_IDX(list_idx1))) == Whole_Subscript_Opr))) { 13464 13465 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 13466 13467 idx = IL_IDX(list_idx1); /* sitting at Whole_Subscript_Opr */ 13468 13469 if (IR_OPR(idx) == Whole_Substring_Opr) { 13470 idx = IR_IDX_L(idx); 13471 } 13472 13473 bd_idx = idx; 13474 il_idx = IR_IDX_R(idx); /* sitting at first IL */ 13475 13476 COPY_OPND(opnd, IR_OPND_L(bd_idx)); 13477 array_attr = find_base_attr(&opnd, &line, &col); 13478 13479 bd_idx = ATD_ARRAY_IDX(array_attr); 13480 13481 idx = IL_IDX(il_idx); /* sitting at Triplet_Opr */ 13482 idx = IR_IDX_L(idx); /* sitting at start IL */ 13483 idx = IL_NEXT_LIST_IDX(idx); /* sitting at finish IL */ 13484 13485 OPND_IDX(base_opnd) = CN_INTEGER_ZERO_IDX; 13486 OPND_FLD(base_opnd) = CN_Tbl_Idx; 13487 OPND_LINE_NUM(base_opnd) = IR_LINE_NUM(ir_idx); 13488 OPND_COL_NUM(base_opnd) = IR_COL_NUM(ir_idx); 13489 13490 for (i = 1; i <= arg_info_list[info_idx1].ed.rank; i++) { 13491 13492 NTR_IR_LIST_TBL(arg1); 13493 IL_ARG_DESC_VARIANT(arg1) = TRUE; 13494 NTR_IR_LIST_TBL(arg2); 13495 IL_ARG_DESC_VARIANT(arg2) = TRUE; 13496 NTR_IR_LIST_TBL(arg3); 13497 IL_ARG_DESC_VARIANT(arg3) = TRUE; 13498 13499 /* link list together */ 13500 IL_NEXT_LIST_IDX(arg1) = arg2; 13501 IL_NEXT_LIST_IDX(arg2) = arg3; 13502 13503 select = gen_ir(IL_Tbl_Idx, arg1, 13504 Cvmgt_Opr, INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13505 IR_COL_NUM(ir_idx), 13506 NO_Tbl_Idx, NULL_IDX); 13507 13508 /* set this flag so this opr is pulled off io lists */ 13509 io_item_must_flatten = TRUE; 13510 13511 COPY_OPND(IL_OPND(arg1), IL_OPND(idx)); 13512 il_idx = IL_NEXT_LIST_IDX(il_idx); 13513 idx = IL_IDX(il_idx); /* sitting at Triplet_Opr */ 13514 idx = IR_IDX_L(idx); /* sitting at start IL */ 13515 idx = IL_NEXT_LIST_IDX(idx); /* sitting at finish IL */ 13516 13517 COPY_OPND(IL_OPND(arg2), base_opnd); 13518 13519 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, i); 13520 13521 eq_idx = gen_ir(IL_FLD(list_idx2), IL_IDX(list_idx2), 13522 Eq_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13523 IR_COL_NUM(ir_idx), 13524 CN_Tbl_Idx, cn_idx); 13525 13526 IL_FLD(arg3) = IR_Tbl_Idx; 13527 IL_IDX(arg3) = eq_idx; 13528 13529 OPND_FLD(base_opnd) = IR_Tbl_Idx; 13530 OPND_IDX(base_opnd) = select; 13531 } 13532 13533 13534 NTR_IR_LIST_TBL(arg1); 13535 IL_ARG_DESC_VARIANT(arg1) = TRUE; 13536 NTR_IR_LIST_TBL(arg2); 13537 IL_ARG_DESC_VARIANT(arg2) = TRUE; 13538 NTR_IR_LIST_TBL(arg3); 13539 IL_ARG_DESC_VARIANT(arg3) = TRUE; 13540 13541 /* link list together */ 13542 IL_NEXT_LIST_IDX(arg1) = arg2; 13543 IL_NEXT_LIST_IDX(arg2) = arg3; 13544 13545 IR_OPR(ir_idx) = Cvmgt_Opr; 13546 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 13547 IR_IDX_L(ir_idx) = arg1; 13548 IR_LIST_CNT_L(ir_idx) = 3; 13549 13550 /* set this flag so this opr is pulled off io lists */ 13551 io_item_must_flatten = TRUE; 13552 13553 /* clear out right side, used to be arg list */ 13554 IR_OPND_R(ir_idx) = null_opnd; 13555 13556 IL_FLD(arg1) = CN_Tbl_Idx; 13557 IL_IDX(arg1) = CN_INTEGER_ZERO_IDX; 13558 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 13559 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 13560 13561 IL_FLD(arg2) = IR_Tbl_Idx; 13562 IL_IDX(arg2) = select; 13563 13564 save_arg3 = arg3; 13565 13566 OPND_IDX(base_opnd) = CN_INTEGER_ZERO_IDX; 13567 OPND_FLD(base_opnd) = CN_Tbl_Idx; 13568 OPND_LINE_NUM(base_opnd) = IR_LINE_NUM(ir_idx); 13569 OPND_COL_NUM(base_opnd) = IR_COL_NUM(ir_idx); 13570 13571 for (i = 1; i <= arg_info_list[info_idx1].ed.rank; i++) { 13572 13573 NTR_IR_LIST_TBL(arg1); 13574 IL_ARG_DESC_VARIANT(arg1) = TRUE; 13575 NTR_IR_LIST_TBL(arg2); 13576 IL_ARG_DESC_VARIANT(arg2) = TRUE; 13577 NTR_IR_LIST_TBL(arg3); 13578 IL_ARG_DESC_VARIANT(arg3) = TRUE; 13579 13580 /* link list together */ 13581 IL_NEXT_LIST_IDX(arg1) = arg2; 13582 IL_NEXT_LIST_IDX(arg2) = arg3; 13583 13584 select = gen_ir(IL_Tbl_Idx, arg1, 13585 Cvmgt_Opr, INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13586 IR_COL_NUM(ir_idx), 13587 NO_Tbl_Idx, NULL_IDX); 13588 13589 /* set this flag so this opr is pulled off io lists */ 13590 io_item_must_flatten = TRUE; 13591 13592 COPY_OPND(IL_OPND(arg1), 13593 arg_info_list[info_idx1].ed.shape[i-1]); 13594 COPY_OPND(IL_OPND(arg2), base_opnd); 13595 13596 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, i); 13597 13598 eq_idx = gen_ir(IL_FLD(list_idx2), IL_IDX(list_idx2), 13599 Eq_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13600 IR_COL_NUM(ir_idx), 13601 CN_Tbl_Idx, cn_idx); 13602 13603 IL_FLD(arg3) = IR_Tbl_Idx; 13604 IL_IDX(arg3) = eq_idx; 13605 13606 OPND_FLD(base_opnd) = IR_Tbl_Idx; 13607 OPND_IDX(base_opnd) = select; 13608 } 13609 13610 le_idx = gen_ir(IR_Tbl_Idx, select, 13611 Le_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13612 IR_COL_NUM(ir_idx), 13613 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 13614 13615 IL_FLD(save_arg3) = IR_Tbl_Idx; 13616 IL_IDX(save_arg3) = le_idx; 13617 } 13618 else if (IL_FLD(list_idx1) == AT_Tbl_Idx || 13619 (IL_FLD(list_idx1) == IR_Tbl_Idx && 13620 IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 13621 IR_FLD_L(IL_IDX(list_idx1)) == AT_Tbl_Idx)) { 13622 13623 /* it is assumed size array */ 13624 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 13625 } 13626 else if (arg_info_list[info_idx1].ed.section || 13627 ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 13628 (IR_OPR(IL_IDX(list_idx1)) != Whole_Subscript_Opr))) { 13629 13630 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 13631 } 13632 } 13633 13634 # endif 13635 13636 } 13637 else { /* DIM is not present */ 13638 13639 # if 0 13640 13641 res_exp_desc->shape[0].fld = CN_Tbl_Idx; 13642 res_exp_desc->shape[0].idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 13643 res_exp_desc->rank); 13644 SHAPE_WILL_FOLD_LATER(res_exp_desc->shape[0]) = TRUE; 13645 SHAPE_FOLDABLE(res_exp_desc->shape[0]) = TRUE; 13646 13647 res_exp_desc->rank = 1; 13648 13649 if (IR_LIST_CNT_R(ir_idx) == 1) { 13650 IR_LIST_CNT_R(ir_idx) = 2; 13651 NTR_IR_LIST_TBL(new_idx); 13652 IL_INTRIN_PLACE_HOLDER(new_idx) = TRUE; 13653 IL_ARG_DESC_VARIANT(new_idx) = TRUE; 13654 IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)) = new_idx; 13655 } 13656 13657 # endif 13658 13659 /* UBOUND, one arg */ 13660 13661 if ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 13662 (IR_OPR(IL_IDX(list_idx1)) == Whole_Subscript_Opr || 13663 (IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 13664 IR_FLD_L(IL_IDX(list_idx1)) == IR_Tbl_Idx && 13665 IR_OPR(IR_IDX_L(IL_IDX(list_idx1))) == Whole_Subscript_Opr))) { 13666 13667 # if 0 13668 13669 COPY_OPND(opnd, IL_OPND(list_idx1)); 13670 array_attr = find_base_attr(&opnd, &line, &col); 13671 13672 bd_idx = ATD_ARRAY_IDX(array_attr); 13673 13674 /* find the whole_subscript for lower bound info */ 13675 /* bounds entries don't have it for dope vectors */ 13676 13677 idx = IL_IDX(list_idx1); 13678 13679 if (IR_OPR(idx) == Whole_Substring_Opr) { 13680 idx = IR_IDX_L(idx); 13681 } 13682 13683 idx = IR_IDX_R(idx); /* first dim IL */ 13684 13685 res_exp_desc->will_fold_later = TRUE; 13686 13687 for (i = 0; i < BD_RANK(bd_idx); i++) { 13688 idx2 = IL_IDX(idx); /* sitting at Triplet_Opr */ 13689 idx2 = IR_IDX_L(idx2); /* sitting at start value IL */ 13690 idx2 = IL_NEXT_LIST_IDX(idx2);/* at finish value IL */ 13691 13692 if (arg_info_list[info_idx1].ed.shape[i].fld != CN_Tbl_Idx || 13693 IL_FLD(idx2) != CN_Tbl_Idx) { 13694 13695 NTR_IR_LIST_TBL(arg1); 13696 IL_ARG_DESC_VARIANT(arg1) = TRUE; 13697 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 13698 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 13699 IL_FLD(arg1) = CN_Tbl_Idx; 13700 13701 /* lbound of zero size dimension is 1 */ 13702 13703 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 0); 13704 13705 IL_IDX(arg1) = cn_idx; 13706 13707 NTR_IR_LIST_TBL(arg2); 13708 IL_ARG_DESC_VARIANT(arg2) = TRUE; 13709 IL_LINE_NUM(arg2) = IR_LINE_NUM(ir_idx); 13710 IL_COL_NUM(arg2) = IR_COL_NUM(ir_idx); 13711 IL_FLD(arg2) = IL_FLD(idx2); 13712 IL_IDX(arg2) = IL_IDX(idx2); 13713 13714 NTR_IR_LIST_TBL(arg3); 13715 IL_ARG_DESC_VARIANT(arg3) = TRUE; 13716 13717 le_idx = gen_ir(OPND_FLD(arg_info_list[info_idx1].ed.shape[i]), 13718 OPND_IDX(arg_info_list[info_idx1].ed.shape[i]), 13719 Le_Opr, LOGICAL_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13720 IR_COL_NUM(ir_idx), 13721 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 13722 13723 IL_FLD(arg3) = IR_Tbl_Idx; 13724 IL_IDX(arg3) = le_idx; 13725 13726 /* link list together */ 13727 IL_NEXT_LIST_IDX(arg1) = arg2; 13728 IL_NEXT_LIST_IDX(arg2) = arg3; 13729 13730 select = gen_ir(IL_Tbl_Idx, arg1, 13731 Cvmgt_Opr, INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13732 IR_COL_NUM(ir_idx), 13733 NO_Tbl_Idx, NULL_IDX); 13734 13735 /* set this flag so this opr is pulled off io lists */ 13736 io_item_must_flatten = TRUE; 13737 13738 expr_IDX[i] = select; 13739 expr_FLD[i] = IR_Tbl_Idx; 13740 host_array[i] = 0; 13741 } 13742 else if (compare_cn_and_value( 13743 arg_info_list[info_idx1].ed.shape[i].idx, 0, Le_Opr)) { 13744 host_array[i] = 0; 13745 } 13746 else { 13747 host_array[i] = (long_type) CN_INT_TO_C(IL_IDX(idx2)); 13748 } 13749 13750 idx = IL_NEXT_LIST_IDX(idx); 13751 } 13752 13753 if (res_exp_desc->will_fold_later) { 13754 make_const_tmp = TRUE; 13755 } 13756 13757 # endif 13758 13759 } 13760 else if (arg_info_list[info_idx1].ed.section || 13761 ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 13762 (IR_OPR(IL_IDX(list_idx1)) != Whole_Subscript_Opr))) { 13763 13764 # if 0 13765 13766 res_exp_desc->will_fold_later = TRUE; 13767 res_exp_desc->foldable = TRUE; 13768 13769 for (i = 0; i < arg_info_list[info_idx1].ed.rank; i++) { 13770 if (arg_info_list[info_idx1].ed.shape[i].fld != CN_Tbl_Idx) { 13771 res_exp_desc->foldable = FALSE; 13772 } 13773 else { 13774 host_array[i] = (long_type) 13775 CN_INT_TO_C(arg_info_list[info_idx1].ed.shape[i].idx); 13776 } 13777 13778 if (! SHAPE_WILL_FOLD_LATER(arg_info_list[info_idx1].ed.shape[i])) { 13779 res_exp_desc->will_fold_later = FALSE; 13780 } 13781 } 13782 13783 if (res_exp_desc->foldable) { 13784 make_const_tmp = TRUE; 13785 } 13786 # endif 13787 } 13788 else if (IL_FLD(list_idx1) == AT_Tbl_Idx || 13789 (IL_FLD(list_idx1) == IR_Tbl_Idx && 13790 IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 13791 IR_FLD_L(IL_IDX(list_idx1)) == AT_Tbl_Idx)) { 13792 13793 /* it is assumed size array */ 13794 PRINTMSG(arg_info_list[info_idx1].line, 889, Error, 13795 arg_info_list[info_idx1].col); 13796 } 13797 } 13798 13799 # if 0 13800 13801 if (make_const_tmp) { 13802 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 13803 bit_length = TARGET_BITS_PER_WORD* (long)arg_info_list[info_idx1].ed.rank; 13804 # ifdef _WHIRL_HOST64_TARGET64 13805 bit_length >>= 1; 13806 # endif /* _WHIRL_HOST64_TARGET64 */ 13807 13808 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 13809 TYP_TYPE(TYP_WORK_IDX) = Typeless; 13810 TYP_BIT_LEN(TYP_WORK_IDX) = bit_length; 13811 constant_type_idx = ntr_type_tbl(); 13812 13813 for (i = 0; i < MAX_NUM_DIMS; i++) { 13814 13815 # if defined(_TARGET32) 13816 13817 /* Make sure that if Integer_8 is default that */ 13818 /* the values still fit in the long container. */ 13819 13820 if (INTEGER_DEFAULT_TYPE == Integer_8) { 13821 /* JEFFL - Need overflow check here for each array entry */ 13822 13823 } 13824 # endif 13825 /* JEFFL - This needs to be converted from host to */ 13826 /* target if we decide that is necessary. */ 13827 13828 const_array[i] = (long_type) host_array[i]; 13829 } 13830 13831 the_cn_idx = ntr_const_tbl(constant_type_idx, 13832 FALSE, 13833 const_array); 13834 13835 tmp_idx = gen_compiler_tmp(IR_LINE_NUM(ir_idx), 13836 IR_COL_NUM(ir_idx), 13837 Shared, TRUE); 13838 13839 AT_SEMANTICS_DONE(tmp_idx)= TRUE; 13840 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE; 13841 13842 loc_exp_desc = *res_exp_desc; 13843 loc_exp_desc.type_idx = CG_INTEGER_DEFAULT_TYPE; 13844 loc_exp_desc.type = Integer; 13845 loc_exp_desc.linear_type = CG_INTEGER_DEFAULT_TYPE; 13846 13847 ATD_ARRAY_IDX(tmp_idx) = create_bd_ntry_for_const(&loc_exp_desc, 13848 IR_LINE_NUM(ir_idx), 13849 IR_COL_NUM(ir_idx)); 13850 13851 ATD_SAVED(tmp_idx) = TRUE; 13852 ATD_DATA_INIT(tmp_idx) = TRUE; 13853 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 13854 ATD_FLD(tmp_idx) = CN_Tbl_Idx; 13855 ATD_TMP_IDX(tmp_idx) = the_cn_idx; 13856 ATD_TMP_INIT_NOT_DONE(tmp_idx) = TRUE; 13857 13858 OPND_IDX((*result_opnd)) = tmp_idx; 13859 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 13860 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 13861 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 13862 13863 ok = gen_whole_subscript(result_opnd, res_exp_desc); 13864 13865 if (CG_INTEGER_DEFAULT_TYPE != INTEGER_DEFAULT_TYPE) { 13866 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 13867 13868 ok = fold_aggragate_expression(result_opnd, 13869 res_exp_desc, 13870 FALSE); 13871 13872 if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx) { 13873 idx = OPND_IDX((*result_opnd)); 13874 if (IR_FLD_L(idx) == AT_Tbl_Idx) { 13875 tmp_idx = IR_IDX_L(idx); 13876 } 13877 } 13878 } 13879 13880 AT_REFERENCED(tmp_idx) = Referenced; 13881 AT_DEFINED(tmp_idx) = TRUE; 13882 13883 res_exp_desc->foldable = TRUE; 13884 res_exp_desc->tmp_reference = TRUE; 13885 } 13886 13887 /* This for loop generates individual assignment statements */ 13888 /* in the IR stream to update those elements of the result */ 13889 /* array that are runtime values. */ 13890 for (i = 0; i < MAX_NUM_DIMS; i++) { 13891 if (expr_IDX[i] != NULL_IDX) { 13892 res_exp_desc->foldable = FALSE; 13893 res_exp_desc->will_fold_later = FALSE; 13894 13895 NTR_IR_LIST_TBL(idx); 13896 IL_FLD(idx) = CN_Tbl_Idx; 13897 13898 IL_IDX(idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, i+1); 13899 13900 IL_LINE_NUM(idx) = IR_LINE_NUM(ir_idx); 13901 IL_COL_NUM(idx) = IR_COL_NUM(ir_idx); 13902 13903 NTR_IR_TBL(subscript_idx); 13904 IR_TYPE_IDX(subscript_idx) = CG_INTEGER_DEFAULT_TYPE; 13905 IR_OPR(subscript_idx) = Subscript_Opr; 13906 IR_LINE_NUM(subscript_idx) = IR_LINE_NUM(ir_idx); 13907 IR_COL_NUM(subscript_idx) = IR_COL_NUM(ir_idx); 13908 IR_FLD_L(subscript_idx) = AT_Tbl_Idx; 13909 IR_IDX_L(subscript_idx) = tmp_idx; 13910 IR_LINE_NUM_L(subscript_idx) = IR_LINE_NUM(ir_idx); 13911 IR_COL_NUM_L(subscript_idx) = IR_COL_NUM(ir_idx); 13912 IR_FLD_R(subscript_idx) = IL_Tbl_Idx; 13913 IR_IDX_R(subscript_idx) = idx; 13914 IR_LINE_NUM_R(subscript_idx) = IR_LINE_NUM(ir_idx); 13915 IR_COL_NUM_R(subscript_idx) = IR_COL_NUM(ir_idx); 13916 IR_LIST_CNT_R(subscript_idx) = 1; 13917 13918 asg_idx = gen_ir(IR_Tbl_Idx, subscript_idx, 13919 Asg_Opr, INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 13920 IR_COL_NUM(ir_idx), 13921 expr_FLD[i], expr_IDX[i]); 13922 13923 gen_sh(Before, 13924 Assignment_Stmt, 13925 IR_LINE_NUM(ir_idx), 13926 IR_COL_NUM(ir_idx), 13927 FALSE, 13928 FALSE, 13929 TRUE); 13930 13931 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 13932 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 13933 } 13934 } 13935 13936 # endif 13937 13938 13939 EXIT: 13940 13941 if (OPND_FLD((*result_opnd)) != IR_Tbl_Idx || 13942 IR_OPR(OPND_IDX((*result_opnd))) != Call_Opr) { 13943 13944 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 13945 } 13946 13947 IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE; 13948 IR_RANK(ir_idx) = res_exp_desc->rank; 13949 13950 res_exp_desc->foldable = FALSE; 13951 res_exp_desc->will_fold_later = FALSE; 13952 13953 TRACE (Func_Exit, "ubound_intrinsic", NULL); 13954 13955 } /* ubound_intrinsic */ 13956 13957 13958 13959 /******************************************************************************\ 13960 |* *| 13961 |* Description: *| 13962 |* Function SIZE(ARRAY, DIM) intrinsic. *| 13963 |* *| 13964 |* Input parameters: *| 13965 |* NONE *| 13966 |* *| 13967 |* Output parameters: *| 13968 |* NONE *| 13969 |* *| 13970 |* Returns: *| 13971 |* NOTHING *| 13972 |* *| 13973 \******************************************************************************/ 13974 13975 void size_intrinsic(opnd_type *result_opnd, 13976 expr_arg_type *res_exp_desc, 13977 int *spec_idx) 13978 { 13979 long dim; 13980 int ir_idx; 13981 int array_attr; 13982 int attr_idx = NULL_IDX; 13983 boolean constant_result; 13984 int idx1; 13985 int idx2; 13986 int i; 13987 int bd_idx; 13988 int cn_idx; 13989 int new_idx; 13990 opnd_type opnd; 13991 int info_idx1; 13992 int info_idx2; 13993 int list_idx1; 13994 int list_idx2; 13995 int line; 13996 int col; 13997 boolean result_will_fold; 13998 long64 num; 13999 14000 14001 TRACE (Func_Entry, "size_intrinsic", NULL); 14002 14003 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 14004 14005 ir_idx = OPND_IDX((*result_opnd)); 14006 list_idx1 = IR_IDX_R(ir_idx); 14007 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 14008 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 14009 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 14010 14011 if (arg_info_list[info_idx1].ed.reference) { 14012 attr_idx = find_base_attr(&IL_OPND(list_idx1), &line, &col); 14013 } 14014 14015 conform_check(0, 14016 ir_idx, 14017 res_exp_desc, 14018 spec_idx, 14019 TRUE); 14020 14021 14022 /* assume these for now */ 14023 res_exp_desc->foldable = FALSE; 14024 res_exp_desc->will_fold_later = FALSE; 14025 14026 /* size result is scalar */ 14027 res_exp_desc->rank = 0; 14028 14029 if (arg_info_list[info_idx1].ed.rank == 0) { 14030 PRINTMSG(arg_info_list[info_idx1].line, 640, Error, 14031 arg_info_list[info_idx1].col); 14032 } 14033 14034 if (list_idx2 != NULL_IDX && 14035 IL_FLD(list_idx2) == CN_Tbl_Idx && 14036 (compare_cn_and_value(IL_IDX(list_idx2), 1, Lt_Opr) || 14037 compare_cn_and_value(IL_IDX(list_idx2), 14038 (long) arg_info_list[info_idx1].ed.rank, 14039 Gt_Opr))) { 14040 14041 find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx2), 14042 &line, 14043 &col); 14044 PRINTMSG(line, 1012, Error, col); 14045 goto EXIT; 14046 } 14047 14048 if (list_idx2 != NULL_IDX && IL_IDX(list_idx2) != NULL_IDX) { 14049 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 14050 14051 if (arg_info_list[info_idx2].ed.rank != 0) { 14052 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 14053 arg_info_list[info_idx2].col); 14054 goto EXIT; 14055 } 14056 14057 res_exp_desc->rank = 0; 14058 14059 if (arg_info_list[info_idx2].ed.reference) { 14060 attr_idx = find_base_attr(&IL_OPND(list_idx2), &line, &col); 14061 14062 if (AT_OPTIONAL(attr_idx)) { 14063 PRINTMSG(arg_info_list[info_idx2].line, 875, Error, 14064 arg_info_list[info_idx2].col); 14065 } 14066 } 14067 14068 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { /* DIM is a constant */ 14069 14070 goto EXIT; /* FEb */ 14071 14072 dim = (long) CN_INT_TO_C(IL_IDX(list_idx2)); 14073 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 14074 14075 if ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 14076 (IR_OPR(IL_IDX(list_idx1)) == Whole_Subscript_Opr || 14077 (IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 14078 IR_FLD_L(IL_IDX(list_idx1)) == IR_Tbl_Idx && 14079 IR_OPR(IR_IDX_L(IL_IDX(list_idx1))) == Whole_Subscript_Opr))) { 14080 14081 COPY_OPND((*result_opnd), 14082 arg_info_list[info_idx1].ed.shape[dim-1]); 14083 14084 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 14085 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 14086 res_exp_desc->linear_type = 14087 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 14088 14089 if (SHAPE_WILL_FOLD_LATER((*result_opnd)) || 14090 SHAPE_FOLDABLE((*result_opnd))) { 14091 res_exp_desc->will_fold_later = TRUE; 14092 } 14093 14094 /* clear the two shape flags on the result opnd */ 14095 SHAPE_FOLDABLE((*result_opnd)) = FALSE; 14096 SHAPE_WILL_FOLD_LATER((*result_opnd)) = FALSE; 14097 14098 if (OPND_FLD((*result_opnd)) == CN_Tbl_Idx) { 14099 res_exp_desc->constant = TRUE; 14100 res_exp_desc->foldable = TRUE; 14101 } 14102 } 14103 else if (IL_FLD(list_idx1) == AT_Tbl_Idx || 14104 (IL_FLD(list_idx1) == IR_Tbl_Idx && 14105 IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 14106 IR_FLD_L(IL_IDX(list_idx1)) == AT_Tbl_Idx)) { 14107 14108 /* it is assumed size array */ 14109 14110 if (IL_FLD(list_idx1) == AT_Tbl_Idx) { 14111 attr_idx = IL_IDX(list_idx1); 14112 } 14113 else { 14114 attr_idx = IR_IDX_L(IL_IDX(list_idx1)); 14115 } 14116 14117 if (dim == arg_info_list[info_idx1].ed.rank) { 14118 PRINTMSG(arg_info_list[info_idx1].line, 889, Error, 14119 arg_info_list[info_idx1].col); 14120 } 14121 else { 14122 OPND_FLD((*result_opnd)) = 14123 BD_XT_FLD(ATD_ARRAY_IDX(attr_idx), dim); 14124 OPND_IDX((*result_opnd)) = 14125 BD_XT_IDX(ATD_ARRAY_IDX(attr_idx), dim); 14126 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 14127 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 14128 14129 if (OPND_FLD((*result_opnd)) == CN_Tbl_Idx) { 14130 res_exp_desc->constant = TRUE; 14131 res_exp_desc->foldable = TRUE; 14132 } 14133 } 14134 } 14135 else if (arg_info_list[info_idx1].ed.section || 14136 ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 14137 (IR_OPR(IL_IDX(list_idx1)) != Whole_Subscript_Opr))) { 14138 NTR_IR_LIST_TBL(idx1); 14139 COPY_OPND(IL_OPND(idx1), 14140 arg_info_list[info_idx1].ed.shape[dim-1]); 14141 14142 NTR_IR_LIST_TBL(idx2); 14143 IL_NEXT_LIST_IDX(idx1) = idx2; 14144 IL_IDX(idx2) = CN_INTEGER_ZERO_IDX; 14145 IL_FLD(idx2) = CN_Tbl_Idx; 14146 IL_LINE_NUM(idx2) = IR_LINE_NUM(ir_idx); 14147 IL_COL_NUM(idx2) = IR_COL_NUM(ir_idx); 14148 14149 goto EXIT; /* Feb */ 14150 14151 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 14152 IR_OPR(ir_idx) = Max_Opr; 14153 14154 IR_IDX_L(ir_idx) = idx1; 14155 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 14156 IR_LIST_CNT_L(ir_idx) = 2; 14157 IR_OPND_R(ir_idx) = null_opnd; 14158 14159 if (OPND_FLD((*result_opnd)) == CN_Tbl_Idx) { 14160 res_exp_desc->constant = TRUE; 14161 res_exp_desc->foldable = TRUE; 14162 } 14163 else if (SHAPE_WILL_FOLD_LATER((*result_opnd)) || 14164 SHAPE_FOLDABLE((*result_opnd))) { 14165 14166 res_exp_desc->will_fold_later = TRUE; 14167 } 14168 14169 /* clear the two shape flags on the result opnd */ 14170 SHAPE_FOLDABLE((*result_opnd)) = FALSE; 14171 SHAPE_WILL_FOLD_LATER((*result_opnd)) = FALSE; 14172 } 14173 } 14174 else { 14175 /* dim is present, but not constant */ 14176 14177 goto EXIT; /* Feb */ 14178 14179 COPY_OPND(opnd, IL_OPND(list_idx2)); 14180 cast_to_cg_default(&opnd, &(arg_info_list[info_idx2].ed)); 14181 COPY_OPND(IL_OPND(list_idx2), opnd); 14182 } 14183 } 14184 else { /* second arg not present */ 14185 goto EXIT; 14186 if (IR_LIST_CNT_R(ir_idx) == 1) { 14187 IR_LIST_CNT_R(ir_idx) = 2; 14188 NTR_IR_LIST_TBL(new_idx); 14189 IL_INTRIN_PLACE_HOLDER(new_idx) = TRUE; 14190 IL_ARG_DESC_VARIANT(new_idx) = TRUE; 14191 IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)) = new_idx; 14192 } 14193 14194 14195 if ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 14196 (IR_OPR(IL_IDX(list_idx1)) == Whole_Subscript_Opr || 14197 (IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 14198 IR_FLD_L(IL_IDX(list_idx1)) == IR_Tbl_Idx && 14199 IR_OPR(IR_IDX_L(IL_IDX(list_idx1))) == Whole_Subscript_Opr))) { 14200 14201 COPY_OPND(opnd, IL_OPND(list_idx1)); 14202 array_attr = find_base_attr(&opnd, &line, &col); 14203 14204 bd_idx = ATD_ARRAY_IDX(array_attr); 14205 14206 constant_result = TRUE; 14207 14208 num = 1; 14209 14210 for (i = 0; i < BD_RANK(bd_idx); i++) { 14211 14212 if (arg_info_list[info_idx1].ed.shape[i].fld != CN_Tbl_Idx) { 14213 constant_result = FALSE; 14214 break; 14215 } 14216 else { 14217 num *= CN_INT_TO_C(arg_info_list[info_idx1].ed.shape[i].idx); 14218 } 14219 } 14220 14221 if (constant_result) { 14222 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 14223 res_exp_desc->constant = TRUE; 14224 res_exp_desc->foldable = TRUE; 14225 14226 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 14227 14228 OPND_IDX((*result_opnd)) = cn_idx; 14229 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 14230 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 14231 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 14232 } 14233 } 14234 else if (arg_info_list[info_idx1].ed.section || 14235 ((IL_FLD(list_idx1) == IR_Tbl_Idx) && 14236 (IR_OPR(IL_IDX(list_idx1)) != Whole_Subscript_Opr))) { 14237 goto EXIT; /* Feb */ 14238 14239 constant_result = TRUE; 14240 result_will_fold = TRUE; 14241 num = 1; 14242 for (i = 0; i < arg_info_list[info_idx1].ed.rank; i++) { 14243 14244 if (arg_info_list[info_idx1].ed.shape[i].fld != CN_Tbl_Idx) { 14245 constant_result = FALSE; 14246 14247 if (! SHAPE_FOLDABLE(arg_info_list[info_idx1].ed.shape[i]) && 14248 ! SHAPE_WILL_FOLD_LATER(arg_info_list[info_idx1].ed.shape[i])) { 14249 14250 result_will_fold = FALSE; 14251 } 14252 } 14253 else { 14254 num *= CN_INT_TO_C(arg_info_list[info_idx1].ed.shape[i].idx); 14255 } 14256 } 14257 14258 if (constant_result) { 14259 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 14260 res_exp_desc->constant = TRUE; 14261 res_exp_desc->foldable = TRUE; 14262 14263 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 14264 14265 OPND_IDX((*result_opnd)) = cn_idx; 14266 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 14267 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 14268 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 14269 } 14270 else if (result_will_fold) { 14271 res_exp_desc->will_fold_later = TRUE; 14272 } 14273 } 14274 else if (IL_FLD(list_idx1) == AT_Tbl_Idx || 14275 (IL_FLD(list_idx1) == IR_Tbl_Idx && 14276 IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr && 14277 IR_FLD_L(IL_IDX(list_idx1)) == AT_Tbl_Idx)) { 14278 14279 /* it is assumed size array */ 14280 PRINTMSG(arg_info_list[info_idx1].line, 889, Error, 14281 arg_info_list[info_idx1].col); 14282 } 14283 } 14284 14285 14286 EXIT: 14287 if (OPND_FLD((*result_opnd)) != IR_Tbl_Idx || 14288 IR_OPR(OPND_IDX((*result_opnd))) != Call_Opr) { 14289 14290 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 14291 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 14292 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 14293 } 14294 14295 IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE; 14296 IR_RANK(ir_idx) = res_exp_desc->rank; 14297 14298 res_exp_desc->foldable = FALSE; 14299 res_exp_desc->will_fold_later = FALSE; 14300 14301 TRACE (Func_Exit, "size_intrinsic", NULL); 14302 14303 } /* size_intrinsic */ 14304 14305 14306 /******************************************************************************\ 14307 |* *| 14308 |* Description: *| 14309 |* Function SHAPE(SOURCE) intrinsic. *| 14310 |* *| 14311 |* Input parameters: *| 14312 |* NONE *| 14313 |* *| 14314 |* Output parameters: *| 14315 |* NONE *| 14316 |* *| 14317 |* Returns: *| 14318 |* NOTHING *| 14319 |* *| 14320 \******************************************************************************/ 14321 14322 void shape_intrinsic(opnd_type *result_opnd, 14323 expr_arg_type *res_exp_desc, 14324 int *spec_idx) 14325 { 14326 int asg_idx; 14327 int subscript_idx; 14328 int triplet_idx; 14329 long64 bit_length; 14330 int constant_type_idx; 14331 # ifdef _WHIRL_HOST64_TARGET64 14332 int const_array[MAX_NUM_DIMS]; 14333 # else 14334 long_type const_array[MAX_NUM_DIMS]; 14335 # endif /* _WHIRL_HOST64_TARGET64 */ 14336 long64 host_array[MAX_NUM_DIMS]; 14337 int ir_idx; 14338 int cn_idx; 14339 int info_idx1; 14340 int i; 14341 boolean ok; 14342 int list_idx1; 14343 int list_idx; 14344 int the_cn_idx; 14345 int tmp_idx; 14346 expr_arg_type loc_exp_desc; 14347 14348 14349 TRACE (Func_Entry, "shape_intrinsic", NULL); 14350 14351 for (i = 0; i < MAX_NUM_DIMS; i++) { 14352 host_array[i] = 0; 14353 } 14354 14355 ir_idx = OPND_IDX((*result_opnd)); 14356 list_idx1 = IR_IDX_R(ir_idx); 14357 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 14358 14359 conform_check(0, 14360 ir_idx, 14361 res_exp_desc, 14362 spec_idx, 14363 FALSE); 14364 14365 # if 0 14366 14367 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 14368 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 14369 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 14370 14371 res_exp_desc->rank = 1; 14372 IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE; 14373 IR_RANK(ir_idx) = res_exp_desc->rank; 14374 14375 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 14376 14377 res_exp_desc->shape[0].fld = CN_Tbl_Idx; 14378 res_exp_desc->shape[0].idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 14379 arg_info_list[info_idx1].ed.rank); 14380 14381 SHAPE_WILL_FOLD_LATER(res_exp_desc->shape[0]) = TRUE; 14382 SHAPE_FOLDABLE(res_exp_desc->shape[0]) = TRUE; 14383 14384 res_exp_desc->foldable = TRUE; 14385 res_exp_desc->will_fold_later = TRUE; 14386 14387 for (i = 0; i < arg_info_list[info_idx1].ed.rank; i++) { 14388 14389 if (arg_info_list[info_idx1].ed.shape[i].fld != CN_Tbl_Idx) { 14390 res_exp_desc->foldable = FALSE; 14391 } 14392 else { 14393 host_array[i] = CN_CONST(arg_info_list[info_idx1].ed.shape[i].idx); 14394 } 14395 14396 if (! SHAPE_FOLDABLE(arg_info_list[info_idx1].ed.shape[i]) && 14397 ! SHAPE_WILL_FOLD_LATER(arg_info_list[info_idx1].ed.shape[i])) { 14398 res_exp_desc->will_fold_later = FALSE; 14399 } 14400 } 14401 14402 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 14403 14404 if (res_exp_desc->foldable) { 14405 bit_length = TARGET_BITS_PER_WORD* (long)arg_info_list[info_idx1].ed.rank; 14406 # ifdef _WHIRL_HOST64_TARGET64 14407 bit_length >>= 1; 14408 # endif /* _WHIRL_HOST64_TARGET64 */ 14409 14410 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 14411 TYP_TYPE(TYP_WORK_IDX) = Typeless; 14412 TYP_BIT_LEN(TYP_WORK_IDX) = bit_length; 14413 constant_type_idx = ntr_type_tbl(); 14414 14415 for (i = 0; i < MAX_NUM_DIMS; i++) { 14416 14417 # if defined(_TARGET32) 14418 14419 /* Make sure that if Integer_8 is default that */ 14420 /* the values still fit in the long container. */ 14421 14422 if (INTEGER_DEFAULT_TYPE == Integer_8) { 14423 /* JEFFL - Need overflow check here for each array entry */ 14424 14425 } 14426 # endif 14427 /* JEFFL - This needs to be converted from host to */ 14428 /* target if we decide that is necessary. */ 14429 14430 const_array[i] = (long_type) host_array[i]; 14431 } 14432 14433 the_cn_idx = ntr_const_tbl(constant_type_idx, 14434 FALSE, 14435 const_array); 14436 14437 tmp_idx = gen_compiler_tmp(IR_LINE_NUM(ir_idx), 14438 IR_COL_NUM(ir_idx), 14439 Shared, TRUE); 14440 14441 ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE; 14442 AT_SEMANTICS_DONE(tmp_idx)= TRUE; 14443 14444 loc_exp_desc = *res_exp_desc; 14445 loc_exp_desc.type_idx = CG_INTEGER_DEFAULT_TYPE; 14446 loc_exp_desc.type = Integer; 14447 loc_exp_desc.linear_type = CG_INTEGER_DEFAULT_TYPE; 14448 14449 ATD_ARRAY_IDX(tmp_idx) = create_bd_ntry_for_const(&loc_exp_desc, 14450 IR_LINE_NUM(ir_idx), 14451 IR_COL_NUM(ir_idx)); 14452 14453 ATD_SAVED(tmp_idx) = TRUE; 14454 ATD_DATA_INIT(tmp_idx) = TRUE; 14455 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 14456 ATD_FLD(tmp_idx) = CN_Tbl_Idx; 14457 ATD_TMP_IDX(tmp_idx) = the_cn_idx; 14458 ATD_TMP_INIT_NOT_DONE(tmp_idx) = TRUE; 14459 14460 OPND_IDX((*result_opnd)) = tmp_idx; 14461 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 14462 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 14463 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 14464 14465 ok = gen_whole_subscript(result_opnd, res_exp_desc); 14466 14467 if (CG_INTEGER_DEFAULT_TYPE != INTEGER_DEFAULT_TYPE) { 14468 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 14469 14470 ok = fold_aggragate_expression(result_opnd, 14471 res_exp_desc, 14472 FALSE); 14473 } 14474 14475 14476 AT_REFERENCED(tmp_idx) = Referenced; 14477 AT_DEFINED(tmp_idx) = TRUE; 14478 14479 res_exp_desc->foldable = TRUE; 14480 res_exp_desc->tmp_reference = TRUE; 14481 } 14482 else { 14483 io_item_must_flatten = TRUE; 14484 tmp_idx = gen_compiler_tmp(IR_LINE_NUM(ir_idx), 14485 IR_COL_NUM(ir_idx), 14486 Priv, TRUE); 14487 14488 ATD_TYPE_IDX(tmp_idx) = INTEGER_DEFAULT_TYPE; 14489 AT_SEMANTICS_DONE(tmp_idx) = TRUE; 14490 14491 loc_exp_desc = *res_exp_desc; 14492 loc_exp_desc.type_idx = INTEGER_DEFAULT_TYPE; 14493 loc_exp_desc.type = Integer; 14494 loc_exp_desc.linear_type = TYP_LINEAR(INTEGER_DEFAULT_TYPE); 14495 14496 ATD_ARRAY_IDX(tmp_idx) = create_bd_ntry_for_const(&loc_exp_desc, 14497 IR_LINE_NUM(ir_idx), 14498 IR_COL_NUM(ir_idx)); 14499 14500 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 14501 14502 for (i = 0; i < arg_info_list[info_idx1].ed.rank; i++) { 14503 /* create data init stmt */ 14504 NTR_IR_TBL(subscript_idx); 14505 IR_TYPE_IDX(subscript_idx) = INTEGER_DEFAULT_TYPE; 14506 IR_OPR(subscript_idx) = Subscript_Opr; 14507 IR_LINE_NUM(subscript_idx) = IR_LINE_NUM(ir_idx); 14508 IR_COL_NUM(subscript_idx) = IR_COL_NUM(ir_idx); 14509 14510 asg_idx = gen_ir(IR_Tbl_Idx, subscript_idx, 14511 Asg_Opr, 14512 INTEGER_DEFAULT_TYPE, 14513 IR_LINE_NUM(ir_idx), 14514 IR_COL_NUM(ir_idx), 14515 OPND_FLD(arg_info_list[info_idx1].ed.shape[i]), 14516 OPND_IDX(arg_info_list[info_idx1].ed.shape[i])); 14517 14518 IR_FLD_L(subscript_idx) = AT_Tbl_Idx; 14519 IR_IDX_L(subscript_idx) = tmp_idx; 14520 IR_LINE_NUM_L(subscript_idx) = IR_LINE_NUM(ir_idx); 14521 IR_COL_NUM_L(subscript_idx) = IR_COL_NUM(ir_idx); 14522 14523 NTR_IR_LIST_TBL(list_idx); 14524 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, i+1); 14525 14526 IL_FLD(list_idx) = CN_Tbl_Idx; 14527 IL_IDX(list_idx) = cn_idx; 14528 IL_LINE_NUM(list_idx) = IR_LINE_NUM(ir_idx); 14529 IL_COL_NUM(list_idx) = IR_COL_NUM(ir_idx); 14530 14531 IR_LIST_CNT_R(subscript_idx) = 1; 14532 IR_FLD_R(subscript_idx) = IL_Tbl_Idx; 14533 IR_IDX_R(subscript_idx) = list_idx; 14534 14535 gen_sh(Before, 14536 Assignment_Stmt, 14537 IR_LINE_NUM(ir_idx), 14538 IR_COL_NUM(ir_idx), 14539 FALSE, 14540 FALSE, 14541 TRUE); 14542 14543 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 14544 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 14545 } 14546 14547 IR_OPR(ir_idx) = Whole_Subscript_Opr; 14548 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 14549 IR_IDX_L(ir_idx) = tmp_idx; 14550 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 14551 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 14552 14553 NTR_IR_LIST_TBL(list_idx); 14554 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 14555 IR_IDX_R(ir_idx) = list_idx; 14556 IR_LIST_CNT_R(ir_idx) = 1; 14557 14558 NTR_IR_TBL(triplet_idx); 14559 IR_TYPE_IDX(triplet_idx) = CG_INTEGER_DEFAULT_TYPE; 14560 IR_OPR(triplet_idx) = Triplet_Opr; 14561 IR_LINE_NUM(triplet_idx) = IR_LINE_NUM(ir_idx); 14562 IR_COL_NUM(triplet_idx) = IR_COL_NUM(ir_idx); 14563 14564 IL_FLD(list_idx) = IR_Tbl_Idx; 14565 IL_IDX(list_idx) = triplet_idx; 14566 14567 NTR_IR_LIST_TBL(list_idx); 14568 IR_FLD_L(triplet_idx) = IL_Tbl_Idx; 14569 IR_IDX_L(triplet_idx) = list_idx; 14570 IR_LIST_CNT_L(triplet_idx) = 3; 14571 14572 cn_idx = CN_INTEGER_ONE_IDX; 14573 14574 IL_FLD(list_idx) = CN_Tbl_Idx; 14575 IL_IDX(list_idx) = cn_idx; 14576 IL_LINE_NUM(list_idx) = IR_LINE_NUM(ir_idx); 14577 IL_COL_NUM(list_idx) = IR_COL_NUM(ir_idx); 14578 14579 NTR_IR_LIST_TBL(tmp_idx); 14580 IL_NEXT_LIST_IDX(list_idx) = tmp_idx; 14581 14582 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, i); 14583 14584 IL_FLD(tmp_idx) = CN_Tbl_Idx; 14585 IL_IDX(tmp_idx) = cn_idx; 14586 IL_LINE_NUM(tmp_idx) = IR_LINE_NUM(ir_idx); 14587 IL_COL_NUM(tmp_idx) = IR_COL_NUM(ir_idx); 14588 14589 NTR_IR_LIST_TBL(list_idx); 14590 IL_NEXT_LIST_IDX(tmp_idx) = list_idx; 14591 14592 cn_idx = CN_INTEGER_ONE_IDX; 14593 14594 IL_FLD(list_idx) = CN_Tbl_Idx; 14595 IL_IDX(list_idx) = cn_idx; 14596 IL_LINE_NUM(list_idx) = IR_LINE_NUM(ir_idx); 14597 IL_COL_NUM(list_idx) = IR_COL_NUM(ir_idx); 14598 14599 14600 /* must reset foldable and will_fold_later because there is no */ 14601 /* folder for this intrinsic in constructors. */ 14602 14603 res_exp_desc->foldable = FALSE; 14604 res_exp_desc->will_fold_later = FALSE; 14605 } 14606 14607 # endif 14608 14609 if (OPND_FLD((*result_opnd)) != IR_Tbl_Idx || 14610 IR_OPR(OPND_IDX((*result_opnd))) != Call_Opr) { 14611 14612 cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE); 14613 } 14614 14615 res_exp_desc->foldable = FALSE; 14616 res_exp_desc->will_fold_later = FALSE; 14617 14618 TRACE (Func_Exit, "shape_intrinsic", NULL); 14619 14620 } /* shape_intrinsic */ 14621 14622 14623 /******************************************************************************\ 14624 |* *| 14625 |* Description: *| 14626 |* Function PRESENT(A) intrinsic. *| 14627 |* *| 14628 |* Input parameters: *| 14629 |* NONE *| 14630 |* *| 14631 |* Output parameters: *| 14632 |* NONE *| 14633 |* *| 14634 |* Returns: *| 14635 |* NOTHING *| 14636 |* *| 14637 \******************************************************************************/ 14638 14639 void present_intrinsic(opnd_type *result_opnd, 14640 expr_arg_type *res_exp_desc, 14641 int *spec_idx) 14642 { 14643 int attr_idx; 14644 int info_idx1; 14645 int ir_idx; 14646 int list_idx; 14647 opnd_type opnd; 14648 14649 14650 TRACE (Func_Entry, "present_intrinsic", NULL); 14651 14652 has_present_opr = TRUE; 14653 14654 ir_idx = OPND_IDX((*result_opnd)); 14655 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 14656 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 14657 14658 conform_check(0, 14659 ir_idx, 14660 res_exp_desc, 14661 spec_idx, 14662 TRUE); 14663 14664 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 14665 res_exp_desc->type = Logical; 14666 res_exp_desc->linear_type = 14667 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 14668 res_exp_desc->rank = 0; 14669 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 14670 IR_RANK(ir_idx) = res_exp_desc->rank; 14671 # if 0 14672 list_idx = IR_IDX_R(ir_idx); 14673 14674 /* Verify that the actual argument passed to PRESENT is actually */ 14675 /* a dummy argument. */ 14676 14677 COPY_OPND(opnd, IL_OPND(list_idx)); 14678 14679 if (IL_FLD(list_idx) == AT_Tbl_Idx) { 14680 14681 attr_idx = IL_IDX(list_idx); 14682 14683 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 14684 ATD_CLASS(attr_idx) == Compiler_Tmp && 14685 ATD_COPY_ASSUMED_SHAPE(attr_idx) && 14686 ATD_TMP_IDX(attr_idx) != NULL_IDX) { 14687 14688 attr_idx = ATD_TMP_IDX(attr_idx); 14689 } 14690 14691 if ((!AT_IS_DARG(attr_idx)) || (!AT_OPTIONAL(attr_idx))) { 14692 PRINTMSG(arg_info_list[info_idx1].line, 777, Error, 14693 arg_info_list[info_idx1].col); 14694 } 14695 } 14696 else { /* not AT */ 14697 14698 if (OPND_FLD(opnd) == IR_Tbl_Idx) { 14699 14700 while (OPND_FLD(opnd) == IR_Tbl_Idx && 14701 (IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr || 14702 IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr || 14703 IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr)) { 14704 14705 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 14706 } 14707 14708 if (OPND_FLD(opnd) != AT_Tbl_Idx) { 14709 PRINTMSG(arg_info_list[info_idx1].line, 1080, Error, 14710 arg_info_list[info_idx1].col); 14711 } 14712 } 14713 14714 while (OPND_FLD(opnd) == IR_Tbl_Idx) { 14715 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 14716 } 14717 14718 attr_idx = OPND_IDX(opnd); 14719 14720 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 14721 ATD_CLASS(attr_idx) == Compiler_Tmp && 14722 ATD_COPY_ASSUMED_SHAPE(attr_idx) && 14723 ATD_TMP_IDX(attr_idx) != NULL_IDX) { 14724 14725 attr_idx = ATD_TMP_IDX(attr_idx); 14726 OPND_IDX(opnd) = attr_idx; 14727 } 14728 14729 if ((OPND_FLD(opnd) != AT_Tbl_Idx) || 14730 (!AT_IS_DARG(OPND_IDX(opnd))) || 14731 (!AT_OPTIONAL(OPND_IDX(opnd)))) { 14732 PRINTMSG(arg_info_list[info_idx1].line, 777, Error, 14733 arg_info_list[info_idx1].col); 14734 } 14735 } 14736 14737 14738 IR_OPR(ir_idx) = Present_Opr; 14739 IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE; 14740 14741 14742 IR_IDX_L(ir_idx) = attr_idx; 14743 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 14744 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 14745 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 14746 IR_OPND_R(ir_idx) = null_opnd; 14747 14748 # endif 14749 14750 /* must reset foldable and will_fold_later because there is no */ 14751 /* folder for this intrinsic in constructors. */ 14752 14753 res_exp_desc->foldable = FALSE; 14754 res_exp_desc->will_fold_later = FALSE; 14755 14756 TRACE (Func_Exit, "present_intrinsic", NULL); 14757 14758 } /* present_intrinsic */ 14759 14760 14761 /******************************************************************************\ 14762 |* *| 14763 |* Description: *| 14764 |* Function LOGICAL(L, KIND) intrinsic. *| 14765 |* *| 14766 |* Input parameters: *| 14767 |* NONE *| 14768 |* *| 14769 |* Output parameters: *| 14770 |* NONE *| 14771 |* *| 14772 |* Returns: *| 14773 |* NOTHING *| 14774 |* *| 14775 \******************************************************************************/ 14776 14777 void logical_intrinsic(opnd_type *result_opnd, 14778 expr_arg_type *res_exp_desc, 14779 int *spec_idx) 14780 { 14781 int info_idx2; 14782 int ir_idx; 14783 int list_idx1; 14784 int list_idx2; 14785 14786 14787 TRACE (Func_Entry, "logical_intrinsic", NULL); 14788 14789 ir_idx = OPND_IDX((*result_opnd)); 14790 list_idx1 = IR_IDX_R(ir_idx); 14791 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 14792 14793 if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) { 14794 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 14795 kind_to_linear_type(&((IL_OPND(list_idx2))), 14796 ATP_RSLT_IDX(*spec_idx), 14797 arg_info_list[info_idx2].ed.kind0seen, 14798 arg_info_list[info_idx2].ed.kind0E0seen, 14799 arg_info_list[info_idx2].ed.kind0D0seen, 14800 ! arg_info_list[info_idx2].ed.kindnotconst); 14801 } 14802 else { 14803 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 14804 } 14805 14806 conform_check(0, 14807 ir_idx, 14808 res_exp_desc, 14809 spec_idx, 14810 FALSE); 14811 14812 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 14813 IR_RANK(ir_idx) = res_exp_desc->rank; 14814 14815 # if 0 14816 14817 IR_OPR(ir_idx) = Logical_Opr; 14818 14819 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 14820 IR_OPND_R(ir_idx) = null_opnd; 14821 IR_LIST_CNT_L(ir_idx) = 1; 14822 IL_NEXT_LIST_IDX(list_idx1) = NULL_IDX; 14823 14824 # endif 14825 14826 /* must reset foldable and will_fold_later because there is no */ 14827 /* folder for this intrinsic in constructors. */ 14828 14829 res_exp_desc->foldable = FALSE; 14830 res_exp_desc->will_fold_later = FALSE; 14831 14832 14833 TRACE (Func_Exit, "logical_intrinsic", NULL); 14834 14835 } /* logical_intrinsic */ 14836 14837 14838 /******************************************************************************\ 14839 |* *| 14840 |* Description: *| 14841 |* Function LEN_TRIM(STRING) intrinsic. *| 14842 |* *| 14843 |* Input parameters: *| 14844 |* NONE *| 14845 |* *| 14846 |* Output parameters: *| 14847 |* NONE *| 14848 |* *| 14849 |* Returns: *| 14850 |* NOTHING *| 14851 |* *| 14852 \******************************************************************************/ 14853 14854 void len_trim_intrinsic(opnd_type *result_opnd, 14855 expr_arg_type *res_exp_desc, 14856 int *spec_idx) 14857 { 14858 int ir_idx; 14859 int list_idx1; 14860 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 14861 int type_idx; 14862 int info_idx1; 14863 14864 14865 TRACE (Func_Entry, "len_trim_intrinsic", NULL); 14866 14867 ir_idx = OPND_IDX((*result_opnd)); 14868 list_idx1 = IR_IDX_R(ir_idx); 14869 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 14870 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 14871 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 14872 14873 conform_check(0, 14874 ir_idx, 14875 res_exp_desc, 14876 spec_idx, 14877 FALSE); 14878 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 14879 IR_RANK(ir_idx) = res_exp_desc->rank; 14880 14881 # if 0 14882 14883 res_exp_desc->type_idx = type_idx; 14884 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 14885 if ( IL_FLD(list_idx1) == CN_Tbl_Idx && 14886 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 14887 arg_info_list[info_idx1].ed.type_idx, 14888 NULL, 14889 NULL_IDX, 14890 folded_const, 14891 &type_idx, 14892 IR_LINE_NUM(ir_idx), 14893 IR_COL_NUM(ir_idx), 14894 1, 14895 Len_Trim_Opr)) { 14896 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 14897 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 14898 FALSE, 14899 folded_const); 14900 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 14901 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 14902 res_exp_desc->constant = TRUE; 14903 res_exp_desc->foldable = TRUE; 14904 } 14905 else { 14906 IR_OPR(ir_idx) = Len_Trim_Opr; 14907 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 14908 IR_OPND_R(ir_idx) = null_opnd; 14909 } 14910 14911 # endif 14912 14913 res_exp_desc->foldable = FALSE; 14914 res_exp_desc->will_fold_later = FALSE; 14915 14916 TRACE (Func_Exit, "len_trim_intrinsic", NULL); 14917 14918 } /* len_trim_intrinsic */ 14919 14920 14921 /******************************************************************************\ 14922 |* *| 14923 |* Description: *| 14924 |* Function NEAREST(X,S) intrinsic. *| 14925 |* *| 14926 |* Input parameters: *| 14927 |* NONE *| 14928 |* *| 14929 |* Output parameters: *| 14930 |* NONE *| 14931 |* *| 14932 |* Returns: *| 14933 |* NOTHING *| 14934 |* *| 14935 \******************************************************************************/ 14936 14937 void nearest_intrinsic(opnd_type *result_opnd, 14938 expr_arg_type *res_exp_desc, 14939 int *spec_idx) 14940 { 14941 int ir_idx; 14942 int cn_idx; 14943 int list_idx1; 14944 int list_idx2; 14945 int list_idx3; 14946 int info_idx1; 14947 int num; 14948 14949 14950 TRACE (Func_Entry, "nearest_intrinsic", NULL); 14951 14952 ir_idx = OPND_IDX((*result_opnd)); 14953 list_idx1 = IR_IDX_R(ir_idx); 14954 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 14955 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 14956 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 14957 14958 conform_check(0, 14959 ir_idx, 14960 res_exp_desc, 14961 spec_idx, 14962 FALSE); 14963 14964 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 14965 IR_RANK(ir_idx) = res_exp_desc->rank; 14966 14967 # if 0 14968 14969 IR_OPR(ir_idx) = Nearest_Opr; 14970 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 14971 IR_LIST_CNT_L(ir_idx) = 3; 14972 14973 switch (arg_info_list[info_idx1].ed.linear_type) { 14974 case Real_4: 14975 num = DIGITS_REAL4_F90; 14976 break; 14977 14978 case Real_8: 14979 num = DIGITS_REAL8_F90; 14980 break; 14981 14982 case Real_16: 14983 num = DIGITS_REAL16_F90; 14984 break; 14985 } 14986 14987 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 14988 14989 NTR_IR_LIST_TBL(list_idx3); 14990 IL_ARG_DESC_VARIANT(list_idx3) = TRUE; 14991 14992 /* link list together */ 14993 IL_NEXT_LIST_IDX(list_idx2) = list_idx3; 14994 14995 IL_IDX(list_idx3) = cn_idx; 14996 IL_FLD(list_idx3) = CN_Tbl_Idx; 14997 IL_LINE_NUM(list_idx3) = IR_LINE_NUM(ir_idx); 14998 IL_COL_NUM(list_idx3) = IR_COL_NUM(ir_idx); 14999 15000 IL_LINE_NUM(list_idx3) = IL_LINE_NUM(list_idx1); 15001 IL_COL_NUM(list_idx3) = IL_COL_NUM(list_idx1); 15002 15003 IR_OPND_R(ir_idx) = null_opnd; 15004 15005 15006 /* must reset foldable and will_fold_later because there is no */ 15007 /* folder for this intrinsic in constructors. */ 15008 15009 # endif 15010 15011 res_exp_desc->foldable = FALSE; 15012 res_exp_desc->will_fold_later = FALSE; 15013 15014 TRACE (Func_Exit, "nearest_intrinsic", NULL); 15015 15016 } /* nearest_intrinsic */ 15017 15018 15019 /******************************************************************************\ 15020 |* *| 15021 |* Description: *| 15022 |* Function RRSPACING(X) intrinsic. *| 15023 |* *| 15024 |* Input parameters: *| 15025 |* NONE *| 15026 |* *| 15027 |* Output parameters: *| 15028 |* NONE *| 15029 |* *| 15030 |* Returns: *| 15031 |* NOTHING *| 15032 |* *| 15033 \******************************************************************************/ 15034 15035 void rrspacing_intrinsic(opnd_type *result_opnd, 15036 expr_arg_type *res_exp_desc, 15037 int *spec_idx) 15038 { 15039 int ir_idx; 15040 int cn_idx; 15041 int info_idx1; 15042 int list_idx1; 15043 int list_idx2; 15044 int num; 15045 15046 15047 TRACE (Func_Entry, "rrspacing_intrinsic", NULL); 15048 15049 ir_idx = OPND_IDX((*result_opnd)); 15050 list_idx1 = IR_IDX_R(ir_idx); 15051 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 15052 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 15053 15054 conform_check(0, 15055 ir_idx, 15056 res_exp_desc, 15057 spec_idx, 15058 FALSE); 15059 15060 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 15061 IR_RANK(ir_idx) = res_exp_desc->rank; 15062 15063 # if 0 15064 15065 IR_OPR(ir_idx) = Rrspacing_Opr; 15066 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 15067 IR_LIST_CNT_L(ir_idx) = 2; 15068 15069 switch (arg_info_list[info_idx1].ed.linear_type) { 15070 case Real_4: 15071 num = DIGITS_REAL4_F90; 15072 break; 15073 15074 case Real_8: 15075 num = DIGITS_REAL8_F90; 15076 break; 15077 15078 case Real_16: 15079 num = DIGITS_REAL16_F90; 15080 break; 15081 } 15082 15083 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 15084 15085 NTR_IR_LIST_TBL(list_idx2); 15086 IL_ARG_DESC_VARIANT(list_idx2) = TRUE; 15087 15088 /* link list together */ 15089 IL_NEXT_LIST_IDX(list_idx1) = list_idx2; 15090 15091 IL_IDX(list_idx2) = cn_idx; 15092 IL_FLD(list_idx2) = CN_Tbl_Idx; 15093 15094 IL_LINE_NUM(list_idx2) = IR_LINE_NUM(ir_idx); 15095 IL_COL_NUM(list_idx2) = IR_COL_NUM(ir_idx); 15096 15097 IR_OPND_R(ir_idx) = null_opnd; 15098 15099 /* must reset foldable and will_fold_later because there is no */ 15100 /* folder for this intrinsic in constructors. */ 15101 15102 # endif 15103 15104 res_exp_desc->foldable = FALSE; 15105 res_exp_desc->will_fold_later = FALSE; 15106 15107 TRACE (Func_Exit, "rrspacing_intrinsic", NULL); 15108 15109 } /* rrspacing_intrinsic */ 15110 15111 15112 /******************************************************************************\ 15113 |* *| 15114 |* Description: *| 15115 |* Function SCALE(X,I) intrinsic. *| 15116 |* *| 15117 |* Input parameters: *| 15118 |* NONE *| 15119 |* *| 15120 |* Output parameters: *| 15121 |* NONE *| 15122 |* *| 15123 |* Returns: *| 15124 |* NOTHING *| 15125 |* *| 15126 \******************************************************************************/ 15127 15128 void scale_intrinsic(opnd_type *result_opnd, 15129 expr_arg_type *res_exp_desc, 15130 int *spec_idx) 15131 { 15132 int ir_idx; 15133 int info_idx1; 15134 15135 15136 TRACE (Func_Entry, "scale_intrinsic", NULL); 15137 15138 ir_idx = OPND_IDX((*result_opnd)); 15139 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 15140 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 15141 15142 conform_check(0, 15143 ir_idx, 15144 res_exp_desc, 15145 spec_idx, 15146 FALSE); 15147 15148 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 15149 IR_RANK(ir_idx) = res_exp_desc->rank; 15150 15151 # if 0 15152 15153 IR_OPR(ir_idx) = Scale_Opr; 15154 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 15155 IR_OPND_R(ir_idx) = null_opnd; 15156 15157 /* must reset foldable and will_fold_later because there is no */ 15158 /* folder for this intrinsic in constructors. */ 15159 # endif 15160 15161 res_exp_desc->foldable = FALSE; 15162 res_exp_desc->will_fold_later = FALSE; 15163 15164 TRACE (Func_Exit, "scale_intrinsic", NULL); 15165 15166 } /* scale_intrinsic */ 15167 15168 15169 /******************************************************************************\ 15170 |* *| 15171 |* Description: *| 15172 |* Function SET_EXPONENT(X,I) intrinsic. *| 15173 |* *| 15174 |* Input parameters: *| 15175 |* NONE *| 15176 |* *| 15177 |* Output parameters: *| 15178 |* NONE *| 15179 |* *| 15180 |* Returns: *| 15181 |* NOTHING *| 15182 |* *| 15183 \******************************************************************************/ 15184 15185 void set_exponent_intrinsic(opnd_type *result_opnd, 15186 expr_arg_type *res_exp_desc, 15187 int *spec_idx) 15188 { 15189 int ir_idx; 15190 int info_idx1; 15191 15192 15193 TRACE (Func_Entry, "set_exponent_intrinsic", NULL); 15194 15195 ir_idx = OPND_IDX((*result_opnd)); 15196 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 15197 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 15198 15199 conform_check(0, 15200 ir_idx, 15201 res_exp_desc, 15202 spec_idx, 15203 FALSE); 15204 15205 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 15206 IR_RANK(ir_idx) = res_exp_desc->rank; 15207 15208 # if 0 15209 15210 IR_OPR(ir_idx) = Set_Exponent_Opr; 15211 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 15212 IR_OPND_R(ir_idx) = null_opnd; 15213 15214 #endif 15215 15216 /* must reset foldable and will_fold_later because there is no */ 15217 /* folder for this intrinsic in constructors. */ 15218 res_exp_desc->foldable = FALSE; 15219 res_exp_desc->will_fold_later = FALSE; 15220 15221 TRACE (Func_Exit, "set_exponent_intrinsic", NULL); 15222 15223 } /* set_exponent_intrinsic */ 15224 15225 15226 /******************************************************************************\ 15227 |* *| 15228 |* Description: *| 15229 |* Function DSHIFTL(I, J, K) intrinsic. *| 15230 |* Function DSHIFTR(I, J, K) intrinsic. *| 15231 |* *| 15232 |* Input parameters: *| 15233 |* NONE *| 15234 |* *| 15235 |* Output parameters: *| 15236 |* NONE *| 15237 |* *| 15238 |* Returns: *| 15239 |* NOTHING *| 15240 |* *| 15241 \******************************************************************************/ 15242 15243 void dshiftl_intrinsic(opnd_type *result_opnd, 15244 expr_arg_type *res_exp_desc, 15245 int *spec_idx) 15246 { 15247 int ir_idx; 15248 int cn_idx; 15249 int info_idx1; 15250 int info_idx2; 15251 int list_idx1; 15252 int list_idx2; 15253 int list_idx3; 15254 int minus_idx; 15255 int mask_idx; 15256 int shiftl_idx; 15257 int shiftr_idx; 15258 int first_idx; 15259 int second_idx; 15260 int band_idx; 15261 int typeless_idx; 15262 opnd_type opnd; 15263 int line; 15264 long num; 15265 int column; 15266 15267 15268 TRACE (Func_Entry, "dshiftl_intrinsic", NULL); 15269 15270 ir_idx = OPND_IDX((*result_opnd)); 15271 list_idx1 = IR_IDX_R(ir_idx); 15272 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 15273 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 15274 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 15275 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 15276 15277 line = IR_LINE_NUM(ir_idx); 15278 column = IR_COL_NUM(ir_idx); 15279 15280 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 15281 15282 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_8) { 15283 typeless_idx = Typeless_8; 15284 } 15285 else { 15286 typeless_idx = TYPELESS_DEFAULT_TYPE; 15287 } 15288 15289 # ifdef _TARGET_OS_MAX 15290 if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_1 || 15291 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_2 || 15292 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_4) { 15293 typeless_idx = Typeless_4; 15294 } 15295 # endif 15296 15297 conform_check(0, 15298 ir_idx, 15299 res_exp_desc, 15300 spec_idx, 15301 FALSE); 15302 15303 if (arg_info_list[info_idx1].ed.linear_type != 15304 arg_info_list[info_idx2].ed.linear_type) { 15305 PRINTMSG(arg_info_list[info_idx2].line, 774, Error, 15306 arg_info_list[info_idx2].col); 15307 } 15308 15309 15310 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 15311 IR_RANK(ir_idx) = res_exp_desc->rank; 15312 15313 # if 0 15314 15315 if (ATP_INTRIN_ENUM(*spec_idx) == Dshiftl_Intrinsic) { 15316 mask_idx = gen_ir(IL_FLD(list_idx3), IL_IDX(list_idx3), 15317 Mask_Opr, typeless_idx, line, column, 15318 NO_Tbl_Idx, NULL_IDX); 15319 15320 COPY_OPND(opnd, IL_OPND(list_idx2)); 15321 cast_opnd_to_type_idx(&opnd, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 15322 COPY_OPND(IL_OPND(list_idx2), opnd); 15323 15324 band_idx = gen_ir(IR_Tbl_Idx, mask_idx, 15325 Band_Opr, typeless_idx, line, column, 15326 IL_FLD(list_idx2), IL_IDX(list_idx2)); 15327 15328 15329 num = storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX( 15330 ATP_RSLT_IDX(*spec_idx)))]; 15331 15332 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 15333 15334 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 15335 Minus_Opr,ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 15336 IL_FLD(list_idx3), IL_IDX(list_idx3)); 15337 15338 15339 NTR_IR_LIST_TBL(first_idx); 15340 IL_FLD(first_idx) = IR_Tbl_Idx; 15341 IL_IDX(first_idx) = band_idx; 15342 15343 15344 NTR_IR_LIST_TBL(second_idx); 15345 IL_FLD(second_idx) = IR_Tbl_Idx; 15346 IL_IDX(second_idx) = minus_idx; 15347 15348 IL_NEXT_LIST_IDX(first_idx) = second_idx; 15349 15350 15351 shiftr_idx = gen_ir(IL_Tbl_Idx, first_idx, 15352 Shiftr_Opr, typeless_idx, line, column, 15353 NO_Tbl_Idx, NULL_IDX); 15354 15355 NTR_IR_LIST_TBL(first_idx); 15356 COPY_OPND(IL_OPND(first_idx), IL_OPND(list_idx1)); 15357 NTR_IR_LIST_TBL(second_idx); 15358 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx3)); 15359 IL_NEXT_LIST_IDX(first_idx) = second_idx; 15360 15361 15362 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 15363 Shiftl_Opr, typeless_idx, line, column, 15364 NO_Tbl_Idx, NULL_IDX); 15365 15366 IR_OPR(ir_idx) = Bor_Opr; 15367 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 15368 IR_IDX_L(ir_idx) = shiftr_idx; 15369 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 15370 IR_IDX_R(ir_idx) = shiftl_idx; 15371 } 15372 else { 15373 15374 num = storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX( 15375 ATP_RSLT_IDX(*spec_idx)))]*2; 15376 15377 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 15378 15379 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 15380 Minus_Opr,ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 15381 IL_FLD(list_idx3), IL_IDX(list_idx3)); 15382 15383 mask_idx = gen_ir(IR_Tbl_Idx, minus_idx, 15384 Mask_Opr, typeless_idx, line, column, 15385 NO_Tbl_Idx, NULL_IDX); 15386 15387 COPY_OPND(opnd, IL_OPND(list_idx1)); 15388 cast_opnd_to_type_idx(&opnd, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 15389 COPY_OPND(IL_OPND(list_idx1), opnd); 15390 15391 band_idx = gen_ir(IR_Tbl_Idx, mask_idx, 15392 Band_Opr, typeless_idx, line, column, 15393 IL_FLD(list_idx1), IL_IDX(list_idx1)); 15394 15395 15396 num = storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX( 15397 ATP_RSLT_IDX(*spec_idx)))]; 15398 15399 cn_idx = C_INT_TO_CN(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)), num); 15400 15401 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 15402 Minus_Opr,ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)),line,column, 15403 IL_FLD(list_idx3), IL_IDX(list_idx3)); 15404 15405 15406 NTR_IR_LIST_TBL(first_idx); 15407 IL_FLD(first_idx) = IR_Tbl_Idx; 15408 IL_IDX(first_idx) = band_idx; 15409 15410 NTR_IR_LIST_TBL(second_idx); 15411 IL_FLD(second_idx) = IR_Tbl_Idx; 15412 IL_IDX(second_idx) = minus_idx; 15413 15414 IL_NEXT_LIST_IDX(first_idx) = second_idx; 15415 15416 15417 shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx, 15418 Shiftl_Opr, typeless_idx, line, column, 15419 NO_Tbl_Idx, NULL_IDX); 15420 15421 NTR_IR_LIST_TBL(first_idx); 15422 COPY_OPND(IL_OPND(first_idx), IL_OPND(list_idx2)); 15423 NTR_IR_LIST_TBL(second_idx); 15424 COPY_OPND(IL_OPND(second_idx), IL_OPND(list_idx3)); 15425 IL_NEXT_LIST_IDX(first_idx) = second_idx; 15426 15427 15428 shiftr_idx = gen_ir(IL_Tbl_Idx, first_idx, 15429 Shiftr_Opr, typeless_idx, line, column, 15430 NO_Tbl_Idx, NULL_IDX); 15431 15432 IR_OPR(ir_idx) = Bor_Opr; 15433 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 15434 IR_IDX_L(ir_idx) = shiftl_idx; 15435 IR_FLD_R(ir_idx) = IR_Tbl_Idx; 15436 IR_IDX_R(ir_idx) = shiftr_idx; 15437 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 15438 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 15439 IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx); 15440 IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx); 15441 } 15442 15443 # endif 15444 15445 /* must reset foldable and will_fold_later because there is no */ 15446 /* folder for this intrinsic in constructors. */ 15447 15448 res_exp_desc->foldable = FALSE; 15449 res_exp_desc->will_fold_later = FALSE; 15450 15451 TRACE (Func_Exit, "dshiftl_intrinsic", NULL); 15452 15453 } /* dshiftl_intrinsic */ 15454 15455 15456 15457 /******************************************************************************\ 15458 |* *| 15459 |* Description: *| 15460 |* Function MINVAL(ARRAY, DIM, MASK) intrinsic. *| 15461 |* Function MINLOC(ARRAY, DIM, MASK) intrinsic. *| 15462 |* Function MAXVAL(ARRAY, DIM, MASK) intrinsic. *| 15463 |* Function MAXLOC(ARRAY, DIM, MASK) intrinsic. *| 15464 |* Function PRODUCT(ARRAY, DIM, MASK) intrinsic. *| 15465 |* Function SUM(ARRAY, DIM, MASK) intrinsic. *| 15466 |* *| 15467 |* Input parameters: *| 15468 |* NONE *| 15469 |* *| 15470 |* Output parameters: *| 15471 |* NONE *| 15472 |* *| 15473 |* Returns: *| 15474 |* NOTHING *| 15475 |* *| 15476 \******************************************************************************/ 15477 15478 void minval_intrinsic(opnd_type *result_opnd, 15479 expr_arg_type *res_exp_desc, 15480 int *spec_idx) 15481 { 15482 int i; 15483 int j; 15484 int ir_idx; 15485 int attr_idx; 15486 int info_idx1; 15487 int info_idx2; 15488 int info_idx3; 15489 int list_idx1; 15490 int list_idx2; 15491 int list_idx3 = NULL_IDX; 15492 int tmp_idx; 15493 int line; 15494 int col; 15495 15496 # ifdef _TARGET_HAS_FAST_INTEGER 15497 int name_idx; 15498 char *name_ptr; 15499 token_type ext_token; 15500 # endif 15501 15502 15503 TRACE (Func_Entry, "minval_intrinsic", NULL); 15504 15505 ir_idx = OPND_IDX((*result_opnd)); 15506 list_idx1 = IR_IDX_R(ir_idx); 15507 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 15508 15509 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 15510 if (list_idx2 != NULL_IDX) { 15511 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 15512 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 15513 } 15514 15515 if (list_idx3 != NULL_IDX) { 15516 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 15517 } 15518 15519 15520 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 15521 15522 if (ATP_INTRIN_ENUM(*spec_idx) == Minloc_Intrinsic || 15523 ATP_INTRIN_ENUM(*spec_idx) == Maxloc_Intrinsic) { 15524 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 15525 } 15526 15527 if (arg_info_list[info_idx1].ed.rank < 1) { 15528 PRINTMSG(arg_info_list[info_idx1].line, 640, Error, 15529 arg_info_list[info_idx1].col); 15530 } 15531 15532 15533 # ifdef _INLINE_INTRINSICS 15534 if (list_idx2 != NULL_IDX) { 15535 if (arg_info_list[info_idx2].ed.type == Integer && 15536 IL_FLD(list_idx2) == CN_Tbl_Idx) { 15537 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; /* DIM constant */ 15538 } 15539 else if (arg_info_list[info_idx2].ed.type == Logical) { 15540 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; /* just ARRAY and MASK */ 15541 } 15542 } 15543 else { 15544 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 15545 } 15546 # endif 15547 15548 # ifdef _TARGET_HAS_FAST_INTEGER 15549 if ((opt_flags.set_fastint_option && 15550 arg_info_list[info_idx1].ed.linear_type == Integer_8 && 15551 ATP_EXTERNAL_INTRIN(*spec_idx) && 15552 TYP_DESC(arg_info_list[info_idx1].ed.type_idx) == Default_Typed) || 15553 (opt_flags.set_allfastint_option && 15554 arg_info_list[info_idx1].ed.linear_type == Integer_8 && 15555 ATP_EXTERNAL_INTRIN(*spec_idx))) { 15556 name_ptr = &name_pool[AT_NAME_IDX(*spec_idx)].name_char; 15557 15558 j = -1; 15559 if (name_ptr[6] == 'J') { 15560 j = 6; 15561 } 15562 else if (name_ptr[7] == 'J') { 15563 j = 7; 15564 } 15565 else if (name_ptr[8] == 'J') { 15566 j = 8; 15567 } 15568 else if (name_ptr[9] == 'J') { 15569 j = 9; 15570 } 15571 else if (name_ptr[10] == 'J') { 15572 j = 10; 15573 } 15574 15575 NTR_ATTR_TBL(tmp_idx); 15576 COPY_COMMON_ATTR_INFO(*spec_idx, 15577 tmp_idx, 15578 Pgm_Unit); 15579 15580 COPY_VARIANT_ATTR_INFO(*spec_idx, 15581 tmp_idx, 15582 Pgm_Unit); 15583 15584 15585 for (i = 0; i < AT_NAME_LEN(*spec_idx); i++) { 15586 if (j == i) { 15587 TOKEN_STR(ext_token)[i] = 'I'; 15588 } 15589 else { 15590 TOKEN_STR(ext_token)[i] = name_ptr[i]; 15591 } 15592 } 15593 15594 TOKEN_STR(ext_token)[i] = '\0'; 15595 15596 NTR_NAME_POOL(TOKEN_ID(ext_token).words, 15597 AT_NAME_LEN(*spec_idx), 15598 name_idx); 15599 15600 AT_NAME_IDX(tmp_idx) = name_idx; 15601 ATP_EXT_NAME_IDX(tmp_idx) = name_idx; 15602 *spec_idx = tmp_idx; 15603 } 15604 # endif 15605 15606 conform_check(0, 15607 ir_idx, 15608 res_exp_desc, 15609 spec_idx, 15610 FALSE); 15611 15612 # if 0 15613 15614 if (list_idx2 == NULL_IDX) { /* only one thing was in the list */ 15615 if (ATP_INTRIN_ENUM(*spec_idx) == Minloc_Intrinsic || 15616 ATP_INTRIN_ENUM(*spec_idx) == Maxloc_Intrinsic) { 15617 res_exp_desc->rank = 1; 15618 res_exp_desc->shape[0].fld = CN_Tbl_Idx; 15619 res_exp_desc->shape[0].idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 15620 arg_info_list[info_idx1].ed.rank); 15621 } 15622 else { 15623 res_exp_desc->rank = 0; 15624 } 15625 15626 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 15627 NTR_IR_LIST_TBL(list_idx2); 15628 IL_ARG_DESC_VARIANT(list_idx2) = TRUE; 15629 IL_INTRIN_PLACE_HOLDER(list_idx2) = TRUE; 15630 NTR_IR_LIST_TBL(list_idx3); 15631 IL_ARG_DESC_VARIANT(list_idx3) = TRUE; 15632 IL_INTRIN_PLACE_HOLDER(list_idx3) = TRUE; 15633 IL_NEXT_LIST_IDX(list_idx1) = list_idx2; 15634 IL_NEXT_LIST_IDX(list_idx2) = list_idx3; 15635 IR_LIST_CNT_R(ir_idx) = 3; 15636 } 15637 } 15638 else { 15639 if (arg_info_list[info_idx2].ed.type == Logical) { /* MASK present */ 15640 if (cmd_line_flags.runtime_conformance) { 15641 gen_runtime_conformance(&IL_OPND(list_idx1), 15642 &(arg_info_list[info_idx1].ed), 15643 &IL_OPND(list_idx2), 15644 &(arg_info_list[info_idx2].ed)); 15645 } 15646 15647 if (ATP_INTRIN_ENUM(*spec_idx) == Minloc_Intrinsic || 15648 ATP_INTRIN_ENUM(*spec_idx) == Maxloc_Intrinsic) { 15649 res_exp_desc->rank = 1; 15650 res_exp_desc->shape[0].fld = CN_Tbl_Idx; 15651 res_exp_desc->shape[0].idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 15652 arg_info_list[info_idx1].ed.rank); 15653 } 15654 else { 15655 res_exp_desc->rank = 0; 15656 } 15657 15658 if (arg_info_list[info_idx2].ed.rank > 0) { 15659 if (arg_info_list[info_idx1].ed.rank != 15660 arg_info_list[info_idx2].ed.rank) { 15661 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 15662 arg_info_list[info_idx2].col); 15663 } 15664 } 15665 15666 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 15667 NTR_IR_LIST_TBL(tmp_idx); 15668 IL_ARG_DESC_VARIANT(tmp_idx) = TRUE; 15669 IL_INTRIN_PLACE_HOLDER(tmp_idx) = TRUE; 15670 IL_NEXT_LIST_IDX(list_idx1) = tmp_idx; 15671 IL_NEXT_LIST_IDX(tmp_idx) = list_idx2; 15672 IR_LIST_CNT_R(ir_idx) = 3; 15673 } 15674 } 15675 else if (arg_info_list[info_idx2].ed.type == Integer) { /* DIM present */ 15676 if (arg_info_list[info_idx2].ed.rank != 0) { 15677 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 15678 arg_info_list[info_idx2].col); 15679 } 15680 15681 if (arg_info_list[info_idx2].ed.reference) { 15682 attr_idx = find_base_attr(&IL_OPND(list_idx2), &line, &col); 15683 15684 if (AT_OPTIONAL(attr_idx)) { 15685 PRINTMSG(arg_info_list[info_idx2].line, 875, Error, 15686 arg_info_list[info_idx2].col); 15687 } 15688 } 15689 15690 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { 15691 j = 1; 15692 for (i = 1; i < 8; i++) { /* KAY - Use compare_cn_and_value */ 15693 if (i == (long) CN_INT_TO_C(IL_IDX(list_idx2))) { 15694 j = j + 1; 15695 } 15696 15697 COPY_OPND(res_exp_desc->shape[i-1], 15698 arg_info_list[info_idx1].ed.shape[j-1]); 15699 j = j + 1; 15700 } 15701 15702 if (compare_cn_and_value(IL_IDX(list_idx2), 15703 (long) arg_info_list[info_idx1].ed.rank, 15704 Gt_Opr) || 15705 compare_cn_and_value(IL_IDX(list_idx2), 1, Lt_Opr)) { 15706 15707 PRINTMSG(arg_info_list[info_idx2].line, 540, Error, 15708 arg_info_list[info_idx2].col); 15709 } 15710 } 15711 15712 res_exp_desc->rank = res_exp_desc->rank - 1; 15713 15714 if (list_idx3 == NULL_IDX) { 15715 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 15716 NTR_IR_LIST_TBL(tmp_idx); 15717 IL_ARG_DESC_VARIANT(tmp_idx) = TRUE; 15718 IL_INTRIN_PLACE_HOLDER(tmp_idx) = TRUE; 15719 IL_NEXT_LIST_IDX(list_idx2) = tmp_idx; 15720 IR_LIST_CNT_R(ir_idx) = 3; 15721 } 15722 } 15723 else { 15724 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 15725 if (arg_info_list[info_idx3].ed.rank > 0) { 15726 if (arg_info_list[info_idx1].ed.rank != 15727 arg_info_list[info_idx3].ed.rank) { 15728 PRINTMSG(arg_info_list[info_idx3].line, 654, Error, 15729 arg_info_list[info_idx3].col); 15730 } 15731 } 15732 15733 if (cmd_line_flags.runtime_conformance) { 15734 gen_runtime_conformance(&IL_OPND(list_idx1), 15735 &(arg_info_list[info_idx1].ed), 15736 &IL_OPND(list_idx3), 15737 &(arg_info_list[info_idx3].ed)); 15738 } 15739 } 15740 } 15741 } 15742 15743 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 15744 io_item_must_flatten = TRUE; 15745 if (ATP_INTRIN_ENUM(*spec_idx) == Sum_Intrinsic) { 15746 IR_OPR(ir_idx) = Sum_Opr; 15747 } 15748 else if (ATP_INTRIN_ENUM(*spec_idx) == Product_Intrinsic) { 15749 IR_OPR(ir_idx) = Product_Opr; 15750 } 15751 else if (ATP_INTRIN_ENUM(*spec_idx) == Minval_Intrinsic) { 15752 IR_OPR(ir_idx) = Minval_Opr; 15753 } 15754 else if (ATP_INTRIN_ENUM(*spec_idx) == Minloc_Intrinsic) { 15755 IR_OPR(ir_idx) = Minloc_Opr; 15756 } 15757 else if (ATP_INTRIN_ENUM(*spec_idx) == Maxloc_Intrinsic) { 15758 IR_OPR(ir_idx) = Maxloc_Opr; 15759 } 15760 else { 15761 IR_OPR(ir_idx) = Maxval_Opr; 15762 } 15763 15764 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 15765 IR_IDX_R(ir_idx) = NULL_IDX; 15766 } 15767 else { 15768 if (list_idx2 == NULL_IDX) { 15769 NTR_IR_LIST_TBL(list_idx2); 15770 IL_ARG_DESC_VARIANT(list_idx2) = TRUE; 15771 IL_INTRIN_PLACE_HOLDER(list_idx2) = TRUE; 15772 IL_NEXT_LIST_IDX(list_idx1) = list_idx2; 15773 IR_LIST_CNT_R(ir_idx) = 3; 15774 } 15775 15776 if (list_idx3 == NULL_IDX) { 15777 NTR_IR_LIST_TBL(list_idx3); 15778 IL_ARG_DESC_VARIANT(list_idx3) = TRUE; 15779 IL_INTRIN_PLACE_HOLDER(list_idx3) = TRUE; 15780 IL_NEXT_LIST_IDX(list_idx2) = list_idx3; 15781 IR_LIST_CNT_R(ir_idx) = 3; 15782 } 15783 } 15784 15785 # endif 15786 15787 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 15788 IR_RANK(ir_idx) = 0; 15789 /* IR_RANK(ir_idx) = res_exp_desc->rank; */ 15790 15791 /* must reset foldable and will_fold_later because there is no */ 15792 /* folder for this intrinsic in constructors. */ 15793 15794 res_exp_desc->foldable = FALSE; 15795 res_exp_desc->will_fold_later = FALSE; 15796 15797 TRACE (Func_Exit, "minval_intrinsic", NULL); 15798 15799 } /* minval_intrinsic */ 15800 15801 15802 15803 /******************************************************************************\ 15804 |* *| 15805 |* Description: *| 15806 |* Function DSM_CHUNKSIZE() intrinsic. *| 15807 |* Function DSM_DISTRIBUTION_BLOCK() intrinsic. *| 15808 |* Function DSM_DISTRIBUTION_CYCLIC() intrinsic. *| 15809 |* Function DSM_DISTRIBUTION_STAR() intrinsic. *| 15810 |* Function DSM_ISDISTRIBUTED() intrinsic. *| 15811 |* Function DSM_ISRESHAPED() intrinsic. *| 15812 |* Function DSM_NUMTHREADS() intrinsic. *| 15813 |* Function DSM_NUMCHUNKS() intrinsic. *| 15814 |* Function DSM_REM_CHUNKSIZE() intrinsic. *| 15815 |* Function DSM_THIS_CHUNKSIZE() intrinsic. *| 15816 |* Function DSM_THIS_STARTINGINDEX() intrinsic. *| 15817 |* Function DSM_THIS_THREADNUM() intrinsic. *| 15818 |* *| 15819 |* Input parameters: *| 15820 |* NONE *| 15821 |* *| 15822 |* Output parameters: *| 15823 |* NONE *| 15824 |* *| 15825 |* Returns: *| 15826 |* NOTHING *| 15827 |* *| 15828 \******************************************************************************/ 15829 15830 void dsm_numthreads_intrinsic(opnd_type *result_opnd, 15831 expr_arg_type *res_exp_desc, 15832 int *spec_idx) 15833 15834 { 15835 int cn_idx; 15836 int ir_idx; 15837 int list_idx; 15838 int info_idx; 15839 int info_idx1; 15840 int list_idx1; 15841 int list_idx2; 15842 int minus_idx; 15843 opnd_type new_opnd; 15844 15845 15846 TRACE (Func_Entry, "dsm_numthreads_intrinsic", NULL); 15847 15848 ir_idx = OPND_IDX((*result_opnd)); 15849 list_idx1 = IR_IDX_R(ir_idx); 15850 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 15851 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 15852 15853 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8; 15854 15855 conform_check(0, 15856 ir_idx, 15857 res_exp_desc, 15858 spec_idx, 15859 FALSE); 15860 15861 # if 0 15862 15863 if (list_idx2 != NULL_IDX) { 15864 cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 15865 arg_info_list[info_idx1].ed.rank); 15866 minus_idx = gen_ir(CN_Tbl_Idx, cn_idx, 15867 Minus_Opr, CG_INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 15868 IR_COL_NUM(ir_idx), 15869 IL_FLD(list_idx2), IL_IDX(list_idx2)); 15870 15871 IL_IDX(list_idx2) = minus_idx; 15872 IL_FLD(list_idx2) = IR_Tbl_Idx; 15873 } 15874 15875 list_idx = IR_IDX_R(ir_idx); 15876 list_idx = IL_NEXT_LIST_IDX(list_idx); 15877 while (list_idx != NULL_IDX) { 15878 info_idx = IL_ARG_DESC_IDX(list_idx); 15879 COPY_OPND(new_opnd, IL_OPND(list_idx)); 15880 cast_to_type_idx(&new_opnd, &arg_info_list[info_idx].ed, Integer_8); 15881 COPY_OPND(IL_OPND(list_idx), new_opnd); 15882 list_idx = IL_NEXT_LIST_IDX(list_idx); 15883 } 15884 15885 list_idx = IR_IDX_R(ir_idx); 15886 list_idx = IL_NEXT_LIST_IDX(list_idx); 15887 while (list_idx != NULL_IDX) { 15888 info_idx = IL_ARG_DESC_IDX(list_idx); 15889 arg_info_list[info_idx].ed.percent_val_arg = TRUE; 15890 list_idx = IL_NEXT_LIST_IDX(list_idx); 15891 } 15892 15893 # endif 15894 15895 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 15896 IR_RANK(ir_idx) = res_exp_desc->rank; 15897 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 15898 res_exp_desc->linear_type = 15899 TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))); 15900 15901 /* must reset foldable and will_fold_later because there is no */ 15902 /* folder for this intrinsic in constructors. */ 15903 15904 res_exp_desc->foldable = FALSE; 15905 res_exp_desc->will_fold_later = FALSE; 15906 15907 TRACE (Func_Exit, "dsm_numthreads_intrinsic", NULL); 15908 15909 } /* dsm_numthreads_intrinsic */ 15910 15911 /******************************************************************************\ 15912 |* *| 15913 |* Description: *| 15914 |* Function OMP_GET_MAX_THREADS() intrinsic. *| 15915 |* Function OMP_GET_NUM_PROCS() intrinsic. *| 15916 |* Function OMP_GET_NUM_THREADS() intrinsic. *| 15917 |* Function OMP_GET_THREAD_NUM() intrinsic. *| 15918 |* Function OMP_GET_DYNAMIC() intrinsic. *| 15919 |* Function OMP_GET_NESTED() intrinsic. *| 15920 |* Function OMP_IN_PARALLEL() intrinsic. *| 15921 |* *| 15922 |* Input parameters: *| 15923 |* NONE *| 15924 |* *| 15925 |* Output parameters: *| 15926 |* NONE *| 15927 |* *| 15928 |* Returns: *| 15929 |* NOTHING *| 15930 |* *| 15931 \******************************************************************************/ 15932 15933 void omp_get_max_threads_intrinsic(opnd_type *result_opnd, 15934 expr_arg_type *res_exp_desc, 15935 int *spec_idx) 15936 15937 { 15938 int ir_idx; 15939 int type_idx; 15940 15941 15942 TRACE (Func_Entry, "omp_get_max_threads", NULL); 15943 15944 ir_idx = OPND_IDX((*result_opnd)); 15945 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 15946 15947 if (ATP_INTRIN_ENUM(*spec_idx) == Omp_Get_Max_Threads_Intrinsic || 15948 ATP_INTRIN_ENUM(*spec_idx) == Omp_Get_Num_Procs_Intrinsic || 15949 ATP_INTRIN_ENUM(*spec_idx) == Omp_Get_Num_Threads_Intrinsic || 15950 ATP_INTRIN_ENUM(*spec_idx) == Omp_Get_Thread_Num_Intrinsic) { 15951 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 15952 } 15953 15954 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 15955 15956 conform_check(0, 15957 ir_idx, 15958 res_exp_desc, 15959 spec_idx, 15960 FALSE); 15961 15962 15963 IR_TYPE_IDX(ir_idx) = type_idx; 15964 15965 # if 0 15966 15967 IR_RANK(ir_idx) = res_exp_desc->rank; 15968 res_exp_desc->type_idx = type_idx; 15969 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 15970 15971 /* must reset foldable and will_fold_later because there is no */ 15972 /* folder for this intrinsic in constructors. */ 15973 15974 res_exp_desc->foldable = FALSE; 15975 res_exp_desc->will_fold_later = FALSE; 15976 15977 # endif 15978 15979 TRACE (Func_Exit, "omp_get_max_threads", NULL); 15980 15981 } /* omp_get_max_threads_intrinsic */ 15982 15983 15984 15985 /******************************************************************************\ 15986 |* *| 15987 |* Description: *| 15988 |* Subroutine OMP_SET_LOCK(LOCK) intrinsic. *| 15989 |* Function OMP_TEST_LOCK(LOCK) intrinsic. *| 15990 |* Subroutine OMP_UNSET_LOCK(LOCK) intrinsic. *| 15991 |* *| 15992 |* Input parameters: *| 15993 |* NONE *| 15994 |* *| 15995 |* Output parameters: *| 15996 |* NONE *| 15997 |* *| 15998 |* Returns: *| 15999 |* NOTHING *| 16000 |* *| 16001 \******************************************************************************/ 16002 16003 void omp_set_lock_intrinsic(opnd_type *result_opnd, 16004 expr_arg_type *res_exp_desc, 16005 int *spec_idx) 16006 16007 { 16008 int ir_idx; 16009 int type_idx; 16010 int info_idx1; 16011 int list_idx1; 16012 16013 16014 TRACE (Func_Entry, "omp_set_lock_intrinsic", NULL); 16015 16016 ir_idx = OPND_IDX((*result_opnd)); 16017 16018 list_idx1 = IR_IDX_R(ir_idx); 16019 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 16020 16021 conform_check(0, 16022 ir_idx, 16023 res_exp_desc, 16024 spec_idx, 16025 FALSE); 16026 16027 if (cmd_line_flags.s_pointer8 && 16028 arg_info_list[info_idx1].ed.linear_type == Integer_4) { 16029 PRINTMSG(arg_info_list[info_idx1].line, 16030 1664, 16031 Error, 16032 arg_info_list[info_idx1].col); 16033 } 16034 16035 # if 0 16036 16037 if (ATP_INTRIN_ENUM(*spec_idx) == Omp_Test_Lock_Intrinsic) { 16038 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 16039 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 16040 IR_TYPE_IDX(ir_idx) = type_idx; 16041 IR_RANK(ir_idx) = res_exp_desc->rank; 16042 res_exp_desc->type_idx = type_idx; 16043 res_exp_desc->type = TYP_TYPE(type_idx); 16044 res_exp_desc->linear_type = TYP_LINEAR(type_idx); 16045 } 16046 16047 io_item_must_flatten = TRUE; 16048 16049 if (ATP_INTRIN_ENUM(*spec_idx) == Omp_Set_Lock_Intrinsic) { 16050 IR_OPR(ir_idx) = Omp_Set_Lock_Opr; 16051 } 16052 else if (ATP_INTRIN_ENUM(*spec_idx) == Omp_Unset_Lock_Intrinsic) { 16053 IR_OPR(ir_idx) = Omp_Unset_Lock_Opr; 16054 } 16055 else { 16056 IR_OPR(ir_idx) = Omp_Test_Lock_Opr; 16057 } 16058 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 16059 IR_OPND_R(ir_idx) = null_opnd; 16060 16061 /* must reset foldable and will_fold_later because there is no */ 16062 /* folder for this intrinsic in constructors. */ 16063 16064 # endif 16065 16066 res_exp_desc->foldable = FALSE; 16067 res_exp_desc->will_fold_later = FALSE; 16068 16069 TRACE (Func_Exit, "omp_set_lock_intrinsic", NULL); 16070 16071 } /* omp_set_lock_intrinsic */ 16072 16073 16074 16075 /******************************************************************************\ 16076 |* *| 16077 |* Description: *| 16078 |* Function DATE() intrinsic. *| 16079 |* Function JDATE() intrinsic. *| 16080 |* Function CLOCK() intrinsic. *| 16081 |* *| 16082 |* Input parameters: *| 16083 |* NONE *| 16084 |* *| 16085 |* Output parameters: *| 16086 |* NONE *| 16087 |* *| 16088 |* Returns: *| 16089 |* NOTHING *| 16090 |* *| 16091 \******************************************************************************/ 16092 16093 void clock_intrinsic(opnd_type *result_opnd, 16094 expr_arg_type *res_exp_desc, 16095 int *spec_idx) 16096 16097 { 16098 int type_idx; 16099 int info_idx1; 16100 int ir_idx; 16101 int list_idx1; 16102 16103 16104 TRACE (Func_Entry, "clock_intrinsic", NULL); 16105 16106 16107 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 16108 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 16109 TYP_TYPE(TYP_WORK_IDX) = Character; 16110 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 16111 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 16112 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 16113 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8); 16114 type_idx = ntr_type_tbl(); 16115 16116 res_exp_desc->type_idx = type_idx; 16117 res_exp_desc->char_len.fld = TYP_FLD(type_idx); 16118 res_exp_desc->char_len.idx = TYP_IDX(type_idx); 16119 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 16120 # endif 16121 16122 # ifdef _TARGET_OS_MAX 16123 ir_idx = OPND_IDX((*result_opnd)); 16124 list_idx1 = IR_IDX_R(ir_idx); 16125 16126 if (list_idx1 != NULL_IDX) { 16127 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 16128 if ((arg_info_list[info_idx1].ed.linear_type == Integer_1) || 16129 (arg_info_list[info_idx1].ed.linear_type == Integer_2) || 16130 (arg_info_list[info_idx1].ed.linear_type == Integer_4)) { 16131 PRINTMSG(arg_info_list[info_idx1].line, 1054, Error, 16132 arg_info_list[info_idx1].col); 16133 } 16134 } 16135 # endif 16136 16137 16138 /* must reset foldable and will_fold_later because there is no */ 16139 /* folder for this intrinsic in constructors. */ 16140 16141 res_exp_desc->foldable = FALSE; 16142 res_exp_desc->will_fold_later = FALSE; 16143 16144 TRACE (Func_Exit, "clock_intrinsic", NULL); 16145 16146 } /* clock_intrinsic */ 16147 16148 16149 /******************************************************************************\ 16150 |* *| 16151 |* Description: *| 16152 |* Function PACK(ARRAY, MASK, VECTOR) intrinsic. *| 16153 |* *| 16154 |* Input parameters: *| 16155 |* NONE *| 16156 |* *| 16157 |* Output parameters: *| 16158 |* NONE *| 16159 |* *| 16160 |* Returns: *| 16161 |* NOTHING *| 16162 |* *| 16163 \******************************************************************************/ 16164 16165 void pack_intrinsic(opnd_type *result_opnd, 16166 expr_arg_type *res_exp_desc, 16167 int *spec_idx) 16168 { 16169 int list_idx1; 16170 int list_idx2; 16171 int list_idx3; 16172 int info_idx1; 16173 int info_idx2; 16174 int info_idx3; 16175 int ir_idx; 16176 int i; 16177 16178 16179 TRACE (Func_Entry, "pack_intrinsic", NULL); 16180 16181 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 16182 16183 ir_idx = OPND_IDX((*result_opnd)); 16184 list_idx1 = IR_IDX_R(ir_idx); 16185 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 16186 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 16187 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 16188 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 16189 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 16190 16191 io_item_must_flatten = TRUE; 16192 16193 if (arg_info_list[info_idx1].ed.rank < 1) { 16194 PRINTMSG(arg_info_list[info_idx1].line, 640, Error, 16195 arg_info_list[info_idx1].col); 16196 } 16197 16198 for (i = 0; i < arg_info_list[info_idx1].ed.rank; i++) { 16199 if (OPND_FLD(arg_info_list[info_idx1].ed.shape[i]) == CN_Tbl_Idx && 16200 OPND_FLD(arg_info_list[info_idx2].ed.shape[i]) == CN_Tbl_Idx) { 16201 if (CN_INT_TO_C(OPND_IDX(arg_info_list[info_idx1].ed.shape[i])) != 16202 CN_INT_TO_C(OPND_IDX(arg_info_list[info_idx2].ed.shape[i]))) { 16203 PRINTMSG(arg_info_list[info_idx2].line, 1155, Error, 16204 arg_info_list[info_idx2].col); 16205 } 16206 } 16207 } 16208 16209 if (list_idx3 != NULL_IDX && IL_IDX(list_idx3) != NULL_IDX) { 16210 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 16211 COPY_OPND(res_exp_desc->shape[0],arg_info_list[info_idx3].ed.shape[0]); 16212 COPY_OPND(res_exp_desc->char_len,arg_info_list[info_idx3].ed.char_len); 16213 16214 # ifdef _INLINE_INTRINSICS 16215 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 16216 # endif 16217 16218 if ((TYP_CHAR_CLASS(arg_info_list[info_idx1].ed.type_idx) == 16219 Const_Len_Char) && 16220 (TYP_CHAR_CLASS(arg_info_list[info_idx3].ed.type_idx) == 16221 Const_Len_Char)) { 16222 if (CN_INT_TO_C(TYP_IDX(arg_info_list[info_idx1].ed.type_idx)) != 16223 CN_INT_TO_C(TYP_IDX(arg_info_list[info_idx3].ed.type_idx))) { 16224 PRINTMSG(arg_info_list[info_idx3].line, 1153, Error, 16225 arg_info_list[info_idx3].col); 16226 } 16227 } 16228 16229 if ((arg_info_list[info_idx1].ed.linear_type != 16230 arg_info_list[info_idx3].ed.linear_type) || 16231 (arg_info_list[info_idx3].ed.rank != 1)) { 16232 PRINTMSG(arg_info_list[info_idx3].line, 1153, Error, 16233 arg_info_list[info_idx3].col); 16234 } 16235 16236 if (cmd_line_flags.runtime_conformance) { 16237 gen_runtime_conformance(&IL_OPND(list_idx1), 16238 &(arg_info_list[info_idx1].ed), 16239 &IL_OPND(list_idx3), 16240 &(arg_info_list[info_idx3].ed)); 16241 } 16242 } 16243 16244 conform_check(0, 16245 ir_idx, 16246 res_exp_desc, 16247 spec_idx, 16248 FALSE); 16249 16250 # if 0 16251 16252 if (cmd_line_flags.runtime_conformance) { 16253 gen_runtime_conformance(&IL_OPND(list_idx1), 16254 &(arg_info_list[info_idx1].ed), 16255 &IL_OPND(list_idx2), 16256 &(arg_info_list[info_idx2].ed)); 16257 } 16258 16259 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 16260 IR_OPR(ir_idx) = Pack_Opr; 16261 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 16262 IR_OPND_R(ir_idx) = null_opnd; 16263 } 16264 16265 res_exp_desc->rank = 1; 16266 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 16267 IR_RANK(ir_idx) = res_exp_desc->rank; 16268 16269 /* must reset foldable and will_fold_later because there is no */ 16270 /* folder for this intrinsic in constructors. */ 16271 16272 # endif 16273 16274 res_exp_desc->foldable = FALSE; 16275 res_exp_desc->will_fold_later = FALSE; 16276 16277 TRACE (Func_Exit, "pack_intrinsic", NULL); 16278 16279 } /* pack_intrinsic */ 16280 16281 16282 /******************************************************************************\ 16283 |* *| 16284 |* Description: *| 16285 |* Function UNPACK(VECTOR, MASK, FIELD) intrinsic. *| 16286 |* *| 16287 |* Input parameters: *| 16288 |* NONE *| 16289 |* *| 16290 |* Output parameters: *| 16291 |* NONE *| 16292 |* *| 16293 |* Returns: *| 16294 |* NOTHING *| 16295 |* *| 16296 \******************************************************************************/ 16297 16298 void unpack_intrinsic(opnd_type *result_opnd, 16299 expr_arg_type *res_exp_desc, 16300 int *spec_idx) 16301 { 16302 int info_idx1; 16303 int info_idx2; 16304 int info_idx3; 16305 int list_idx1; 16306 int list_idx2; 16307 int list_idx3; 16308 int i; 16309 int ir_idx; 16310 16311 16312 TRACE (Func_Entry, "unpack_intrinsic", NULL); 16313 16314 ir_idx = OPND_IDX((*result_opnd)); 16315 list_idx1 = IR_IDX_R(ir_idx); 16316 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 16317 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 16318 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 16319 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 16320 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 16321 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx; 16322 16323 io_item_must_flatten = TRUE; 16324 # ifdef _INLINE_INTRINSICS 16325 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 16326 # endif 16327 16328 if (arg_info_list[info_idx1].ed.rank != 1) { 16329 PRINTMSG(arg_info_list[info_idx1].line, 654, Error, 16330 arg_info_list[info_idx1].col); 16331 } 16332 16333 if ((TYP_CHAR_CLASS(arg_info_list[info_idx1].ed.type_idx) == 16334 Const_Len_Char) && 16335 (TYP_CHAR_CLASS(arg_info_list[info_idx3].ed.type_idx) == 16336 Const_Len_Char)) { 16337 if (CN_INT_TO_C(TYP_IDX(arg_info_list[info_idx1].ed.type_idx)) != 16338 CN_INT_TO_C(TYP_IDX(arg_info_list[info_idx3].ed.type_idx))) { 16339 PRINTMSG(arg_info_list[info_idx3].line, 1154, Error, 16340 arg_info_list[info_idx3].col); 16341 } 16342 } 16343 16344 if ((arg_info_list[info_idx1].ed.linear_type != Short_Char_Const) && 16345 (arg_info_list[info_idx3].ed.linear_type != Short_Char_Const)) { 16346 if (arg_info_list[info_idx1].ed.linear_type != 16347 arg_info_list[info_idx3].ed.linear_type) { 16348 PRINTMSG(arg_info_list[info_idx3].line, 1154, Error, 16349 arg_info_list[info_idx3].col); 16350 } 16351 } 16352 16353 if (arg_info_list[info_idx2].ed.rank !=arg_info_list[info_idx3].ed.rank) { 16354 if (arg_info_list[info_idx3].ed.rank != 0) { 16355 PRINTMSG(arg_info_list[info_idx3].line, 1222, Error, 16356 arg_info_list[info_idx3].col); 16357 } 16358 } 16359 else { 16360 for (i = 1; i <= arg_info_list[info_idx2].ed.rank; i++) { 16361 if (OPND_FLD(arg_info_list[info_idx2].ed.shape[i-1])== CN_Tbl_Idx && 16362 OPND_FLD(arg_info_list[info_idx3].ed.shape[i-1])== CN_Tbl_Idx && 16363 CN_INT_TO_C(OPND_IDX(arg_info_list[info_idx2].ed.shape[i-1])) != 16364 CN_INT_TO_C(OPND_IDX(arg_info_list[info_idx3].ed.shape[i-1]))) { 16365 PRINTMSG(arg_info_list[info_idx3].line, 1222, Error, 16366 arg_info_list[info_idx3].col); 16367 break; 16368 } 16369 } 16370 } 16371 16372 conform_check(0, 16373 ir_idx, 16374 res_exp_desc, 16375 spec_idx, 16376 FALSE); 16377 16378 # if 0 16379 16380 if (cmd_line_flags.runtime_conformance) { 16381 gen_runtime_conformance(&IL_OPND(list_idx2), 16382 &(arg_info_list[info_idx2].ed), 16383 &IL_OPND(list_idx3), 16384 &(arg_info_list[info_idx3].ed)); 16385 } 16386 16387 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 16388 IR_OPR(ir_idx) = Unpack_Opr; 16389 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 16390 IR_OPND_R(ir_idx) = null_opnd; 16391 } 16392 16393 res_exp_desc->rank = arg_info_list[info_idx2].ed.rank; 16394 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 16395 IR_RANK(ir_idx) = res_exp_desc->rank; 16396 16397 COPY_OPND(res_exp_desc->shape[0], arg_info_list[info_idx2].ed.shape[0]); 16398 COPY_OPND(res_exp_desc->shape[1], arg_info_list[info_idx2].ed.shape[1]); 16399 COPY_OPND(res_exp_desc->shape[2], arg_info_list[info_idx2].ed.shape[2]); 16400 COPY_OPND(res_exp_desc->shape[3], arg_info_list[info_idx2].ed.shape[3]); 16401 COPY_OPND(res_exp_desc->shape[4], arg_info_list[info_idx2].ed.shape[4]); 16402 COPY_OPND(res_exp_desc->shape[5], arg_info_list[info_idx2].ed.shape[5]); 16403 COPY_OPND(res_exp_desc->shape[6], arg_info_list[info_idx2].ed.shape[6]); 16404 COPY_OPND(res_exp_desc->char_len, arg_info_list[info_idx1].ed.char_len); 16405 16406 # endif 16407 16408 /* must reset foldable and will_fold_later because there is no */ 16409 /* folder for this intrinsic in constructors. */ 16410 16411 res_exp_desc->foldable = FALSE; 16412 res_exp_desc->will_fold_later = FALSE; 16413 16414 TRACE (Func_Exit, "unpack_intrinsic", NULL); 16415 16416 } /* unpack_intrinsic */ 16417 16418 16419 /******************************************************************************\ 16420 |* *| 16421 |* Description: *| 16422 |* Function TRIM(STRING) intrinsic. *| 16423 |* *| 16424 |* Input parameters: *| 16425 |* NONE *| 16426 |* *| 16427 |* Output parameters: *| 16428 |* NONE *| 16429 |* *| 16430 |* Returns: *| 16431 |* NOTHING *| 16432 |* *| 16433 \******************************************************************************/ 16434 void trim_intrinsic(opnd_type *result_opnd, 16435 expr_arg_type *res_exp_desc, 16436 int *spec_idx) 16437 16438 { 16439 long_type folded_const[MAX_WORDS_FOR_INTEGER]; 16440 int info_idx1; 16441 int ir_idx; 16442 int len_idx; 16443 int list_idx1; 16444 opnd_type opnd; 16445 int type_idx; 16446 16447 16448 TRACE (Func_Entry, "trim_intrinsic", NULL); 16449 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 16450 16451 ir_idx = OPND_IDX((*result_opnd)); 16452 list_idx1 = IR_IDX_R(ir_idx); 16453 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 16454 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Character_1; 16455 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 16456 16457 if (arg_info_list[info_idx1].ed.rank != 0) { 16458 PRINTMSG(arg_info_list[info_idx1].line, 654, Error, 16459 arg_info_list[info_idx1].col); 16460 } 16461 16462 conform_check(0, 16463 ir_idx, 16464 res_exp_desc, 16465 spec_idx, 16466 FALSE); 16467 /* # if 0 */ 16468 16469 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 16470 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 16471 arg_info_list[info_idx1].ed.type_idx, 16472 NULL, 16473 NULL_IDX, 16474 folded_const, 16475 &type_idx, 16476 IR_LINE_NUM(ir_idx), 16477 IR_COL_NUM(ir_idx), 16478 1, 16479 Trim_Opr)) { 16480 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 16481 16482 /* folder_driver returns a CN_Tbl_Idx in result for Trim */ 16483 16484 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 16485 OPND_IDX((*result_opnd)) = (int) F_INT_TO_C(folded_const, type_idx); 16486 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 16487 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 16488 16489 res_exp_desc->char_len.fld = TYP_FLD(type_idx); 16490 res_exp_desc->char_len.idx = TYP_IDX(type_idx); 16491 res_exp_desc->constant = TRUE; 16492 res_exp_desc->foldable = TRUE; 16493 } 16494 else { 16495 copy_subtree(&IR_OPND_R(ir_idx), &opnd); 16496 16497 len_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 16498 Len_Trim_Opr, 16499 INTEGER_DEFAULT_TYPE, 16500 IR_LINE_NUM(ir_idx), 16501 IR_COL_NUM(ir_idx), 16502 NO_Tbl_Idx, NULL_IDX); 16503 16504 res_exp_desc->char_len.fld = IR_Tbl_Idx; 16505 res_exp_desc->char_len.idx = len_idx; 16506 16507 ATD_CHAR_LEN_IN_DV(ATP_RSLT_IDX(*spec_idx)) = TRUE; 16508 } 16509 16510 /* # endif */ 16511 16512 res_exp_desc->type_idx = type_idx; 16513 IR_TYPE_IDX(ir_idx) = type_idx; 16514 IR_RANK(ir_idx) = res_exp_desc->rank; 16515 16516 res_exp_desc->foldable = FALSE; 16517 res_exp_desc->will_fold_later = FALSE; 16518 16519 TRACE (Func_Exit, "trim_intrinsic", NULL); 16520 16521 } /* trim_intrinsic */ 16522 16523 16524 /******************************************************************************\ 16525 |* *| 16526 |* Description: *| 16527 |* Function TRANSPOSE(MATRIX) intrinsic. *| 16528 |* *| 16529 |* Input parameters: *| 16530 |* NONE *| 16531 |* *| 16532 |* Output parameters: *| 16533 |* NONE *| 16534 |* *| 16535 |* Returns: *| 16536 |* NOTHING *| 16537 |* *| 16538 \******************************************************************************/ 16539 16540 void transpose_intrinsic(opnd_type *result_opnd, 16541 expr_arg_type *res_exp_desc, 16542 int *spec_idx) 16543 { 16544 int info_idx1; 16545 int list_idx1; 16546 int ir_idx; 16547 int type_idx; 16548 16549 16550 TRACE (Func_Entry, "transpose_intrinsic", NULL); 16551 16552 # ifdef _INLINE_INTRINSICS 16553 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 16554 # endif 16555 16556 ir_idx = OPND_IDX((*result_opnd)); 16557 list_idx1 = IR_IDX_R(ir_idx); 16558 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 16559 type_idx = arg_info_list[info_idx1].ed.type_idx; 16560 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 16561 16562 if (arg_info_list[info_idx1].ed.rank != 2) { 16563 PRINTMSG(arg_info_list[info_idx1].line, 654, Error, 16564 arg_info_list[info_idx1].col); 16565 } 16566 16567 conform_check(0, 16568 ir_idx, 16569 res_exp_desc, 16570 spec_idx, 16571 FALSE); 16572 # if 0 16573 16574 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 16575 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 16576 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 16577 COPY_OPND(res_exp_desc->shape[0], arg_info_list[info_idx1].ed.shape[1]); 16578 COPY_OPND(res_exp_desc->shape[1], arg_info_list[info_idx1].ed.shape[0]); 16579 COPY_OPND(res_exp_desc->char_len, arg_info_list[info_idx1].ed.char_len); 16580 16581 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 16582 io_item_must_flatten = TRUE; 16583 IR_OPR(ir_idx) = Transpose_Opr; 16584 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 16585 IR_OPND_R(ir_idx) = null_opnd; 16586 } 16587 16588 #endif 16589 16590 IR_TYPE_IDX(ir_idx) = type_idx; 16591 IR_RANK(ir_idx) = res_exp_desc->rank; 16592 16593 /* must reset foldable and will_fold_later because there is no */ 16594 /* folder for this intrinsic in constructors. */ 16595 16596 res_exp_desc->foldable = FALSE; 16597 res_exp_desc->will_fold_later = FALSE; 16598 16599 16600 TRACE (Func_Exit, "transpose_intrinsic", NULL); 16601 16602 } /* transpose_intrinsic */ 16603 16604 16605 /******************************************************************************\ 16606 |* *| 16607 |* Description: *| 16608 |* Function SPREAD(SOURCE, DIM, NCOPIES) intrinsic. *| 16609 |* *| 16610 |* Input parameters: *| 16611 |* NONE *| 16612 |* *| 16613 |* Output parameters: *| 16614 |* NONE *| 16615 |* *| 16616 |* Returns: *| 16617 |* NOTHING *| 16618 |* *| 16619 \******************************************************************************/ 16620 16621 void spread_intrinsic(opnd_type *result_opnd, 16622 expr_arg_type *res_exp_desc, 16623 int *spec_idx) 16624 { 16625 int list_idx1; 16626 int list_idx2; 16627 int list_idx3; 16628 int info_idx1; 16629 int info_idx2; 16630 int info_idx3; 16631 int idx; 16632 int idx1; 16633 int idx2; 16634 int ir_idx; 16635 int i; 16636 int j; 16637 int type_idx; 16638 opnd_type opnd; 16639 opnd_type shape_opnd; 16640 16641 16642 TRACE (Func_Entry, "spread_intrinsic", NULL); 16643 16644 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 16645 16646 ir_idx = OPND_IDX((*result_opnd)); 16647 list_idx1 = IR_IDX_R(ir_idx); 16648 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 16649 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 16650 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 16651 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 16652 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 16653 type_idx = arg_info_list[info_idx1].ed.type_idx; 16654 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 16655 16656 conform_check(0, 16657 ir_idx, 16658 res_exp_desc, 16659 spec_idx, 16660 FALSE); 16661 16662 COPY_OPND(res_exp_desc->char_len, arg_info_list[info_idx1].ed.char_len); 16663 res_exp_desc->rank = arg_info_list[info_idx1].ed.rank + 1; 16664 16665 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { 16666 if ((compare_cn_and_value(IL_IDX(list_idx2), 16667 (long) arg_info_list[info_idx1].ed.rank+1, 16668 Gt_Opr) || 16669 compare_cn_and_value(IL_IDX(list_idx2), 1, Lt_Opr))) { 16670 16671 PRINTMSG(arg_info_list[info_idx2].line, 1120, Error, 16672 arg_info_list[info_idx2].col); 16673 } 16674 16675 # if 0 16676 16677 j = 1; 16678 for (i = 1; i <= res_exp_desc->rank; i++) { 16679 if (compare_cn_and_value(IL_IDX(list_idx2), 16680 i, 16681 Eq_Opr)) { 16682 OPND_LINE_NUM(shape_opnd) = IR_LINE_NUM(ir_idx); 16683 OPND_COL_NUM(shape_opnd) = IR_COL_NUM(ir_idx); 16684 16685 NTR_IR_LIST_TBL(idx1); 16686 NTR_IR_LIST_TBL(idx2); 16687 IL_NEXT_LIST_IDX(idx1) = idx2; 16688 IL_IDX(idx2) = CN_INTEGER_ZERO_IDX; 16689 IL_FLD(idx2) = CN_Tbl_Idx; 16690 IL_LINE_NUM(idx2) = IR_LINE_NUM(ir_idx); 16691 IL_COL_NUM(idx2) = IR_COL_NUM(ir_idx); 16692 16693 IL_IDX(idx1) = IL_IDX(list_idx3); 16694 IL_FLD(idx1) = IL_FLD(list_idx3); 16695 IL_LINE_NUM(idx1) = IR_LINE_NUM(ir_idx); 16696 IL_COL_NUM(idx1) = IR_COL_NUM(ir_idx); 16697 16698 idx = gen_ir(IL_Tbl_Idx, idx1, 16699 Max_Opr, INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 16700 IR_COL_NUM(ir_idx), 16701 NO_Tbl_Idx, NULL_IDX); 16702 16703 OPND_FLD(shape_opnd) = IR_Tbl_Idx; 16704 OPND_IDX(shape_opnd) = idx; 16705 16706 COPY_OPND(res_exp_desc->shape[i-1], shape_opnd); 16707 } 16708 else { 16709 COPY_OPND(res_exp_desc->shape[i-1], 16710 arg_info_list[info_idx1].ed.shape[j-1]); 16711 j = j + 1; 16712 } 16713 } 16714 16715 # ifdef _INLINE_INTRINSICS 16716 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 16717 # endif 16718 16719 # endif 16720 } 16721 # if 0 16722 16723 COPY_OPND(opnd, IL_OPND(list_idx2)); 16724 cast_to_cg_default(&opnd, &(arg_info_list[info_idx2].ed)); 16725 COPY_OPND(IL_OPND(list_idx2), opnd); 16726 16727 COPY_OPND(opnd, IL_OPND(list_idx3)); 16728 cast_to_cg_default(&opnd, &(arg_info_list[info_idx3].ed)); 16729 COPY_OPND(IL_OPND(list_idx3), opnd); 16730 16731 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 16732 io_item_must_flatten = TRUE; 16733 IR_OPR(ir_idx) = Spread_Opr; 16734 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 16735 IR_OPND_R(ir_idx) = null_opnd; 16736 IR_LIST_CNT_L(ir_idx) = IR_LIST_CNT_R(ir_idx); 16737 } 16738 16739 #endif 16740 16741 IR_TYPE_IDX(ir_idx) = type_idx; 16742 IR_RANK(ir_idx) = res_exp_desc->rank; 16743 16744 /* must reset foldable and will_fold_later because there is no */ 16745 /* folder for this intrinsic in constructors. */ 16746 16747 res_exp_desc->foldable = FALSE; 16748 res_exp_desc->will_fold_later = FALSE; 16749 16750 TRACE (Func_Exit, "spread_intrinsic", NULL); 16751 16752 } /* spread_intrinsic */ 16753 16754 16755 /******************************************************************************\ 16756 |* *| 16757 |* Description: *| 16758 |* Function SELECTED_INT_KIND(R) intrinsic. *| 16759 |* *| 16760 |* Input parameters: *| 16761 |* NONE *| 16762 |* *| 16763 |* Output parameters: *| 16764 |* NONE *| 16765 |* *| 16766 |* Returns: *| 16767 |* NOTHING *| 16768 |* *| 16769 \******************************************************************************/ 16770 16771 void selected_int_kind_intrinsic(opnd_type *result_opnd, 16772 expr_arg_type *res_exp_desc, 16773 int *spec_idx) 16774 { 16775 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 16776 int info_idx1; 16777 int ir_idx; 16778 int type_idx; 16779 int list_idx1; 16780 int fifth_select; 16781 int fourth_select; 16782 int third_select; 16783 int second_select; 16784 int arg1; 16785 int arg2; 16786 int arg3; 16787 int le_idx; 16788 int cn_idx; 16789 16790 16791 TRACE (Func_Entry, "selected_int_kind_intrinsic", NULL); 16792 16793 ir_idx = OPND_IDX((*result_opnd)); 16794 list_idx1 = IR_IDX_R(ir_idx); 16795 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 16796 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 16797 if (arg_info_list[info_idx1].ed.rank != 0) { 16798 PRINTMSG(arg_info_list[info_idx1].line, 654, Error, 16799 arg_info_list[info_idx1].col); 16800 } 16801 16802 conform_check(0, 16803 ir_idx, 16804 res_exp_desc, 16805 spec_idx, 16806 FALSE); 16807 16808 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 16809 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 16810 res_exp_desc->type = Integer; 16811 res_exp_desc->linear_type = INTEGER_DEFAULT_TYPE; 16812 type_idx = INTEGER_DEFAULT_TYPE; 16813 16814 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 16815 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 16816 arg_info_list[info_idx1].ed.type_idx, 16817 NULL, 16818 NULL_IDX, 16819 folded_const, 16820 &type_idx, 16821 IR_LINE_NUM(ir_idx), 16822 IR_COL_NUM(ir_idx), 16823 1, 16824 SIK_Opr)) { 16825 16826 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 16827 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 16828 FALSE, 16829 folded_const); 16830 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 16831 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 16832 res_exp_desc->constant = TRUE; 16833 res_exp_desc->foldable = TRUE; 16834 } 16835 else { 16836 NTR_IR_LIST_TBL(arg1); 16837 IL_ARG_DESC_VARIANT(arg1) = TRUE; 16838 16839 NTR_IR_LIST_TBL(arg2); 16840 IL_ARG_DESC_VARIANT(arg2) = TRUE; 16841 16842 NTR_IR_LIST_TBL(arg3); 16843 IL_ARG_DESC_VARIANT(arg3) = TRUE; 16844 16845 /* link list together */ 16846 IL_NEXT_LIST_IDX(arg1) = arg2; 16847 IL_NEXT_LIST_IDX(arg2) = arg3; 16848 16849 fifth_select = gen_ir(IL_Tbl_Idx, arg1, 16850 Cvmgt_Opr, 16851 INTEGER_DEFAULT_TYPE, 16852 IR_LINE_NUM(ir_idx), 16853 IR_COL_NUM(ir_idx), 16854 NO_Tbl_Idx, NULL_IDX); 16855 16856 /* set this flag so this opr is pulled off io lists */ 16857 io_item_must_flatten = TRUE; 16858 16859 16860 16861 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 8); 16862 IL_FLD(arg1) = CN_Tbl_Idx; 16863 IL_IDX(arg1) = cn_idx; 16864 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 16865 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 16866 16867 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 16868 CN_INTEGER_NEG_ONE_IDX : C_INT_TO_CN(INTEGER_DEFAULT_TYPE, -1); 16869 IL_FLD(arg2) = CN_Tbl_Idx; 16870 IL_IDX(arg2) = cn_idx; 16871 IL_LINE_NUM(arg2) = IR_LINE_NUM(ir_idx); 16872 IL_COL_NUM(arg2) = IR_COL_NUM(ir_idx); 16873 16874 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, RANGE_INT8_F90); 16875 16876 le_idx = gen_ir(IL_FLD(IR_IDX_R(ir_idx)), IL_IDX(IR_IDX_R(ir_idx)), 16877 Le_Opr, 16878 LOGICAL_DEFAULT_TYPE, 16879 IR_LINE_NUM(ir_idx), 16880 IR_COL_NUM(ir_idx), 16881 CN_Tbl_Idx, cn_idx); 16882 16883 IL_FLD(arg3) = IR_Tbl_Idx; 16884 IL_IDX(arg3) = le_idx; 16885 16886 16887 NTR_IR_LIST_TBL(arg1); 16888 IL_ARG_DESC_VARIANT(arg1) = TRUE; 16889 16890 NTR_IR_LIST_TBL(arg2); 16891 IL_ARG_DESC_VARIANT(arg2) = TRUE; 16892 16893 NTR_IR_LIST_TBL(arg3); 16894 IL_ARG_DESC_VARIANT(arg3) = TRUE; 16895 16896 /* link list together */ 16897 IL_NEXT_LIST_IDX(arg1) = arg2; 16898 IL_NEXT_LIST_IDX(arg2) = arg3; 16899 16900 fourth_select = gen_ir(IL_Tbl_Idx, arg1, 16901 Cvmgt_Opr, 16902 INTEGER_DEFAULT_TYPE, 16903 IR_LINE_NUM(ir_idx), 16904 IR_COL_NUM(ir_idx), 16905 NO_Tbl_Idx, NULL_IDX); 16906 16907 /* set this flag so this opr is pulled off io lists */ 16908 io_item_must_flatten = TRUE; 16909 16910 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 4); 16911 IL_FLD(arg1) = CN_Tbl_Idx; 16912 IL_IDX(arg1) = cn_idx; 16913 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 16914 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 16915 16916 IL_FLD(arg2) = IR_Tbl_Idx; 16917 IL_IDX(arg2) = fifth_select; 16918 16919 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, RANGE_INT4_F90); 16920 16921 le_idx = gen_ir(IL_FLD(IR_IDX_R(ir_idx)), IL_IDX(IR_IDX_R(ir_idx)), 16922 Le_Opr, 16923 LOGICAL_DEFAULT_TYPE, 16924 IR_LINE_NUM(ir_idx), 16925 IR_COL_NUM(ir_idx), 16926 CN_Tbl_Idx, cn_idx); 16927 16928 IL_FLD(arg3) = IR_Tbl_Idx; 16929 IL_IDX(arg3) = le_idx; 16930 16931 16932 16933 16934 16935 16936 NTR_IR_LIST_TBL(arg1); 16937 IL_ARG_DESC_VARIANT(arg1) = TRUE; 16938 16939 NTR_IR_LIST_TBL(arg2); 16940 IL_ARG_DESC_VARIANT(arg2) = TRUE; 16941 16942 NTR_IR_LIST_TBL(arg3); 16943 IL_ARG_DESC_VARIANT(arg3) = TRUE; 16944 16945 /* link list together */ 16946 IL_NEXT_LIST_IDX(arg1) = arg2; 16947 IL_NEXT_LIST_IDX(arg2) = arg3; 16948 16949 third_select = gen_ir(IL_Tbl_Idx, arg1, 16950 Cvmgt_Opr, 16951 INTEGER_DEFAULT_TYPE, 16952 IR_LINE_NUM(ir_idx), 16953 IR_COL_NUM(ir_idx), 16954 NO_Tbl_Idx, NULL_IDX); 16955 16956 /* set this flag so this opr is pulled off io lists */ 16957 io_item_must_flatten = TRUE; 16958 16959 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 16960 CN_INTEGER_TWO_IDX : C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 2); 16961 IL_FLD(arg1) = CN_Tbl_Idx; 16962 IL_IDX(arg1) = cn_idx; 16963 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 16964 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 16965 16966 IL_FLD(arg2) = IR_Tbl_Idx; 16967 IL_IDX(arg2) = fourth_select; 16968 16969 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, RANGE_INT2_F90); 16970 16971 le_idx = gen_ir(IL_FLD(IR_IDX_R(ir_idx)), IL_IDX(IR_IDX_R(ir_idx)), 16972 Le_Opr,LOGICAL_DEFAULT_TYPE,IR_LINE_NUM(ir_idx), 16973 IR_COL_NUM(ir_idx), 16974 CN_Tbl_Idx, cn_idx); 16975 16976 IL_FLD(arg3) = IR_Tbl_Idx; 16977 IL_IDX(arg3) = le_idx; 16978 16979 16980 16981 NTR_IR_LIST_TBL(arg1); 16982 IL_ARG_DESC_VARIANT(arg1) = TRUE; 16983 16984 NTR_IR_LIST_TBL(arg2); 16985 IL_ARG_DESC_VARIANT(arg2) = TRUE; 16986 16987 NTR_IR_LIST_TBL(arg3); 16988 IL_ARG_DESC_VARIANT(arg3) = TRUE; 16989 16990 /* link list together */ 16991 IL_NEXT_LIST_IDX(arg1) = arg2; 16992 IL_NEXT_LIST_IDX(arg2) = arg3; 16993 16994 second_select = gen_ir(IL_Tbl_Idx, arg1, 16995 Cvmgt_Opr, 16996 INTEGER_DEFAULT_TYPE, 16997 IR_LINE_NUM(ir_idx), 16998 IR_COL_NUM(ir_idx), 16999 NO_Tbl_Idx, NULL_IDX); 17000 17001 /* set this flag so this opr is pulled off io lists */ 17002 io_item_must_flatten = TRUE; 17003 17004 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 17005 CN_INTEGER_ONE_IDX : C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 1); 17006 IL_FLD(arg1) = CN_Tbl_Idx; 17007 IL_IDX(arg1) = cn_idx; 17008 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 17009 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 17010 17011 IL_FLD(arg2) = IR_Tbl_Idx; 17012 IL_IDX(arg2) = third_select; 17013 17014 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, RANGE_INT1_F90); 17015 17016 le_idx = gen_ir(IL_FLD(IR_IDX_R(ir_idx)), IL_IDX(IR_IDX_R(ir_idx)), 17017 Le_Opr, 17018 LOGICAL_DEFAULT_TYPE, 17019 IR_LINE_NUM(ir_idx), 17020 IR_COL_NUM(ir_idx), 17021 CN_Tbl_Idx, cn_idx); 17022 17023 IL_FLD(arg3) = IR_Tbl_Idx; 17024 IL_IDX(arg3) = le_idx; 17025 17026 17027 17028 17029 17030 17031 NTR_IR_LIST_TBL(arg1); 17032 IL_ARG_DESC_VARIANT(arg1) = TRUE; 17033 17034 NTR_IR_LIST_TBL(arg2); 17035 IL_ARG_DESC_VARIANT(arg2) = TRUE; 17036 17037 NTR_IR_LIST_TBL(arg3); 17038 IL_ARG_DESC_VARIANT(arg3) = TRUE; 17039 17040 /* link list together */ 17041 IL_NEXT_LIST_IDX(arg1) = arg2; 17042 IL_NEXT_LIST_IDX(arg2) = arg3; 17043 17044 IR_OPR(ir_idx) = Cvmgt_Opr; 17045 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 17046 IR_IDX_L(ir_idx) = arg1; 17047 IR_LIST_CNT_L(ir_idx) = 3; 17048 17049 /* set this flag so this opr is pulled off io lists */ 17050 io_item_must_flatten = TRUE; 17051 17052 cn_idx = (CG_INTEGER_DEFAULT_TYPE == INTEGER_DEFAULT_TYPE) ? 17053 CN_INTEGER_ONE_IDX : C_INT_TO_CN(INTEGER_DEFAULT_TYPE, 1); 17054 IL_FLD(arg1) = CN_Tbl_Idx; 17055 IL_IDX(arg1) = cn_idx; 17056 IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx); 17057 IL_COL_NUM(arg1) = IR_COL_NUM(ir_idx); 17058 17059 IL_FLD(arg2) = IR_Tbl_Idx; 17060 IL_IDX(arg2) = second_select; 17061 17062 le_idx = gen_ir(IL_FLD(IR_IDX_R(ir_idx)), IL_IDX(IR_IDX_R(ir_idx)), 17063 Le_Opr, 17064 LOGICAL_DEFAULT_TYPE, 17065 IR_LINE_NUM(ir_idx), 17066 IR_COL_NUM(ir_idx), 17067 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 17068 17069 IL_FLD(arg3) = IR_Tbl_Idx; 17070 IL_IDX(arg3) = le_idx; 17071 17072 17073 IR_OPND_R(ir_idx) = null_opnd; 17074 IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE; 17075 IR_RANK(ir_idx) = res_exp_desc->rank; 17076 17077 /* must reset foldable and will_fold_later because there is no */ 17078 /* folder for this intrinsic in constructors. */ 17079 17080 res_exp_desc->foldable = FALSE; 17081 res_exp_desc->will_fold_later = FALSE; 17082 } 17083 17084 17085 TRACE (Func_Exit, "selected_int_kind_intrinsic", NULL); 17086 17087 } /* selected_int_kind_intrinsic */ 17088 17089 17090 /******************************************************************************\ 17091 |* *| 17092 |* Description: *| 17093 |* Function SELECTED_REAL_KIND(P,R) intrinsic. *| 17094 |* *| 17095 |* Input parameters: *| 17096 |* NONE *| 17097 |* *| 17098 |* Output parameters: *| 17099 |* NONE *| 17100 |* *| 17101 |* Returns: *| 17102 |* NOTHING *| 17103 |* *| 17104 \******************************************************************************/ 17105 17106 void selected_real_kind_intrinsic(opnd_type *result_opnd, 17107 expr_arg_type *res_exp_desc, 17108 int *spec_idx) 17109 { 17110 int ir_idx; 17111 int type_idx; 17112 int info_idx1; 17113 int info_idx2; 17114 int list_idx1; 17115 int list_idx2; 17116 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 17117 opnd_type opnd; 17118 int i; 17119 17120 TRACE (Func_Entry, "selected_real_kind_intrinsic", NULL); 17121 for (i=0; i<=MAX_WORDS_FOR_NUMERIC-1;i++) 17122 folded_const[i]=0; 17123 17124 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 17125 ir_idx = OPND_IDX((*result_opnd)); 17126 list_idx1 = IR_IDX_R(ir_idx); 17127 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 17128 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 17129 17130 conform_check(0, 17131 ir_idx, 17132 res_exp_desc, 17133 spec_idx, 17134 FALSE); 17135 17136 if (list_idx1 != NULL_IDX && IL_IDX(list_idx1) != NULL_IDX) { 17137 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 17138 17139 if (arg_info_list[IL_ARG_DESC_IDX(list_idx1)].ed.rank != 0) { 17140 PRINTMSG(arg_info_list[IL_ARG_DESC_IDX(list_idx1)].line, 654, Error, 17141 arg_info_list[IL_ARG_DESC_IDX(list_idx1)].col); 17142 } 17143 } 17144 17145 17146 if (list_idx2 != NULL_IDX && IL_IDX(list_idx2) != NULL_IDX) { 17147 info_idx2 = IL_ARG_DESC_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))); 17148 17149 if (arg_info_list[IL_ARG_DESC_IDX(list_idx2)].ed.rank != 0) { 17150 PRINTMSG(arg_info_list[IL_ARG_DESC_IDX(list_idx2)].line, 654, Error, 17151 arg_info_list[IL_ARG_DESC_IDX(list_idx2)].col); 17152 } 17153 } 17154 17155 if ((IL_IDX(list_idx1) == NULL_IDX) && (IL_IDX(list_idx2) == NULL_IDX)) { 17156 PRINTMSG(IR_LINE_NUM(ir_idx), 728, Error, 17157 IR_COL_NUM(ir_idx)); 17158 } 17159 17160 17161 if (IL_IDX(list_idx1) != NULL_IDX) { /* if P is present */ 17162 COPY_OPND(opnd, IL_OPND(list_idx1)); 17163 cast_to_cg_default(&opnd, &(arg_info_list[info_idx1].ed)); 17164 COPY_OPND(IL_OPND(list_idx1), opnd); 17165 } 17166 17167 if (IL_IDX(list_idx2) != NULL_IDX) { /* if R is present */ 17168 COPY_OPND(opnd, IL_OPND(list_idx2)); 17169 cast_to_cg_default(&opnd, &(arg_info_list[info_idx2].ed)); 17170 COPY_OPND(IL_OPND(list_idx2), opnd); 17171 } 17172 17173 IR_TYPE_IDX(ir_idx) = INTEGER_DEFAULT_TYPE; 17174 IR_RANK(ir_idx) = res_exp_desc->rank; 17175 res_exp_desc->type_idx = INTEGER_DEFAULT_TYPE; 17176 type_idx = INTEGER_DEFAULT_TYPE; 17177 res_exp_desc->type = Integer; 17178 res_exp_desc->linear_type = INTEGER_DEFAULT_TYPE; 17179 17180 if (IL_IDX(list_idx1) != NULL_IDX && /* if P is present */ 17181 IL_IDX(list_idx2) != NULL_IDX && /* if R is present */ 17182 IL_FLD(list_idx1) == CN_Tbl_Idx && 17183 IL_FLD(list_idx2) == CN_Tbl_Idx && 17184 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 17185 arg_info_list[info_idx1].ed.type_idx, 17186 (char *)&CN_CONST(IL_IDX(list_idx2)), 17187 arg_info_list[info_idx2].ed.type_idx, 17188 folded_const, 17189 &type_idx, 17190 IR_LINE_NUM(ir_idx), 17191 IR_COL_NUM(ir_idx), 17192 2, 17193 SRK_Opr)) { 17194 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 17195 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 17196 FALSE, 17197 folded_const); 17198 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 17199 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 17200 res_exp_desc->constant = TRUE; 17201 res_exp_desc->foldable = TRUE; 17202 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 17203 } 17204 else if (IL_IDX(list_idx1) != NULL_IDX && /* if P is present */ 17205 IL_IDX(list_idx2) == NULL_IDX && /* if R is not present */ 17206 IL_FLD(list_idx1) == CN_Tbl_Idx && 17207 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 17208 arg_info_list[info_idx1].ed.type_idx, 17209 NULL, 17210 NULL_IDX, 17211 folded_const, 17212 &type_idx, 17213 IR_LINE_NUM(ir_idx), 17214 IR_COL_NUM(ir_idx), 17215 2, 17216 SRK_Opr)) { 17217 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 17218 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 17219 FALSE, 17220 folded_const); 17221 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 17222 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 17223 res_exp_desc->constant = TRUE; 17224 res_exp_desc->foldable = TRUE; 17225 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 17226 } 17227 else if (IL_IDX(list_idx2) != NULL_IDX && /* if R is present */ 17228 IL_IDX(list_idx1) == NULL_IDX && /* if P is not present */ 17229 IL_FLD(list_idx2) == CN_Tbl_Idx && 17230 folder_driver(NULL, 17231 NULL_IDX, 17232 (char *)&CN_CONST(IL_IDX(list_idx2)), 17233 arg_info_list[info_idx2].ed.type_idx, 17234 folded_const, 17235 &type_idx, 17236 IR_LINE_NUM(ir_idx), 17237 IR_COL_NUM(ir_idx), 17238 2, 17239 SRK_Opr)) { 17240 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 17241 OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, 17242 FALSE, 17243 folded_const); 17244 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 17245 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 17246 res_exp_desc->constant = TRUE; 17247 res_exp_desc->foldable = TRUE; 17248 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 17249 } 17250 17251 17252 17253 TRACE (Func_Exit, "selected_real_kind_intrinsic", NULL); 17254 17255 } /* selected_real_kind_intrinsic */ 17256 17257 17258 /******************************************************************************\ 17259 |* *| 17260 |* Description: *| 17261 |* Function REPEAT(STRING, NCOPIES) intrinsic. *| 17262 |* *| 17263 |* Input parameters: *| 17264 |* NONE *| 17265 |* *| 17266 |* Output parameters: *| 17267 |* NONE *| 17268 |* *| 17269 |* Returns: *| 17270 |* NOTHING *| 17271 |* *| 17272 \******************************************************************************/ 17273 17274 void repeat_intrinsic(opnd_type *result_opnd, 17275 expr_arg_type *res_exp_desc, 17276 int *spec_idx) 17277 { 17278 long_type folded_const[MAX_WORDS_FOR_INTEGER]; 17279 int info_idx1; 17280 int info_idx2; 17281 int ir_idx; 17282 int list_idx1; 17283 int list_idx2; 17284 int mult_idx; 17285 opnd_type opnd; 17286 opnd_type opnd2; 17287 int type_idx; 17288 17289 17290 TRACE (Func_Entry, "repeat_intrinsic", NULL); 17291 17292 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 17293 ir_idx = OPND_IDX((*result_opnd)); 17294 list_idx1 = IR_IDX_R(ir_idx); 17295 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 17296 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Character_1; 17297 type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 17298 17299 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 17300 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 17301 17302 if (arg_info_list[info_idx1].ed.rank != 0) { 17303 PRINTMSG(arg_info_list[info_idx1].line, 654, Error, 17304 arg_info_list[info_idx1].col); 17305 } 17306 17307 if (arg_info_list[info_idx2].ed.rank != 0) { 17308 PRINTMSG(arg_info_list[info_idx2].line, 654, Error, 17309 arg_info_list[info_idx2].col); 17310 } 17311 17312 if (IL_FLD(list_idx2) == CN_Tbl_Idx) { 17313 if (compare_cn_and_value(IL_IDX(list_idx2), 0, Lt_Opr)) { 17314 PRINTMSG(arg_info_list[info_idx2].line, 1056, Error, 17315 arg_info_list[info_idx2].col); 17316 } 17317 17318 } 17319 17320 conform_check(0, 17321 ir_idx, 17322 res_exp_desc, 17323 spec_idx, 17324 FALSE); 17325 17326 /*# if 0 */ 17327 17328 if (IL_FLD(list_idx1) == CN_Tbl_Idx && 17329 IL_FLD(list_idx2) == CN_Tbl_Idx && 17330 folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)), 17331 arg_info_list[info_idx1].ed.type_idx, 17332 (char *)&CN_CONST(IL_IDX(list_idx2)), 17333 arg_info_list[info_idx2].ed.type_idx, 17334 folded_const, 17335 &type_idx, 17336 IR_LINE_NUM(ir_idx), 17337 IR_COL_NUM(ir_idx), 17338 2, 17339 Repeat_Opr)) { 17340 17341 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 17342 OPND_IDX((*result_opnd)) = (int) F_INT_TO_C(folded_const, type_idx); 17343 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 17344 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 17345 17346 res_exp_desc->char_len.fld = TYP_FLD(type_idx); 17347 res_exp_desc->char_len.idx = TYP_IDX(type_idx); 17348 res_exp_desc->constant = TRUE; 17349 res_exp_desc->foldable = TRUE; 17350 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 17351 } 17352 17353 # if 0 17354 else { 17355 COPY_OPND(opnd, arg_info_list[info_idx1].ed.char_len); 17356 copy_subtree(&opnd, &opnd); 17357 17358 COPY_OPND(opnd2, IL_OPND(list_idx2)); 17359 copy_subtree(&opnd2, &opnd2); 17360 17361 mult_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 17362 Mult_Opr, CG_INTEGER_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 17363 IR_COL_NUM(ir_idx), 17364 OPND_FLD(opnd2), OPND_IDX(opnd2)); 17365 17366 res_exp_desc->char_len.fld = IR_Tbl_Idx; 17367 res_exp_desc->char_len.idx = mult_idx; 17368 17369 ATD_CHAR_LEN_IN_DV(ATP_RSLT_IDX(*spec_idx)) = TRUE; 17370 } 17371 17372 COPY_OPND(opnd, IL_OPND(list_idx2)); 17373 cast_to_cg_default(&opnd, &(arg_info_list[info_idx2].ed)); 17374 COPY_OPND(IL_OPND(list_idx2), opnd); 17375 17376 # endif 17377 17378 else{ 17379 res_exp_desc->constant = FALSE; 17380 res_exp_desc->foldable = FALSE; 17381 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 17382 } 17383 17384 res_exp_desc->type_idx = type_idx; 17385 IR_TYPE_IDX(ir_idx) = type_idx; 17386 IR_RANK(ir_idx) = res_exp_desc->rank; 17387 17388 17389 TRACE (Func_Exit, "repeat_intrinsic", NULL); 17390 17391 } /* repeat_intrinsic */ 17392 17393 17394 /******************************************************************************\ 17395 |* *| 17396 |* Description: *| 17397 |* Function DOT_PRODUCT(VECTOR_A, VECTOR_B) intrinsic. *| 17398 |* *| 17399 |* Input parameters: *| 17400 |* NONE *| 17401 |* *| 17402 |* Output parameters: *| 17403 |* NONE *| 17404 |* *| 17405 |* Returns: *| 17406 |* NOTHING *| 17407 |* *| 17408 \******************************************************************************/ 17409 17410 void dot_product_intrinsic(opnd_type *result_opnd, 17411 expr_arg_type *res_exp_desc, 17412 int *spec_idx) 17413 { 17414 int ir_idx; 17415 17416 # if defined(GENERATE_WHIRL) 17417 int list_idx1; 17418 int info_idx1; 17419 # endif 17420 17421 17422 TRACE (Func_Entry, "dot_product_intrinsic", NULL); 17423 17424 # ifdef _INLINE_INTRINSICS 17425 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 17426 # endif 17427 17428 ir_idx = OPND_IDX((*result_opnd)); 17429 17430 # if defined(GENERATE_WHIRL) 17431 list_idx1 = IR_IDX_R(ir_idx); 17432 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 17433 # endif 17434 17435 conform_check(0, 17436 ir_idx, 17437 res_exp_desc, 17438 spec_idx, 17439 FALSE); 17440 17441 # if 0 17442 17443 res_exp_desc->rank = 0; 17444 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 17445 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 17446 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 17447 17448 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 17449 io_item_must_flatten = TRUE; 17450 IR_OPR(ir_idx) = Dot_Product_Opr; 17451 17452 # if defined(GENERATE_WHIRL) 17453 if (arg_info_list[info_idx1].ed.type == Logical) { 17454 IR_OPR(ir_idx) = Dot_Product_Logical_Opr; 17455 } 17456 # endif 17457 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 17458 IR_OPND_R(ir_idx) = null_opnd; 17459 } 17460 17461 # endif 17462 17463 IR_TYPE_IDX(ir_idx) = res_exp_desc->type_idx; 17464 IR_RANK(ir_idx) = res_exp_desc->rank; 17465 17466 /* must reset foldable and will_fold_later because there is no */ 17467 /* folder for this intrinsic in constructors. */ 17468 17469 res_exp_desc->foldable = FALSE; 17470 res_exp_desc->will_fold_later = FALSE; 17471 17472 TRACE (Func_Exit, "dot_product_intrinsic", NULL); 17473 17474 } /* dot_product_intrinsic */ 17475 17476 17477 /******************************************************************************\ 17478 |* *| 17479 |* Description: *| 17480 |* Function MATMUL(MATRIX_A, MATRIX_B) intrinsic. *| 17481 |* *| 17482 |* Input parameters: *| 17483 |* NONE *| 17484 |* *| 17485 |* Output parameters: *| 17486 |* NONE *| 17487 |* *| 17488 |* Returns: *| 17489 |* NOTHING *| 17490 |* *| 17491 \******************************************************************************/ 17492 17493 void matmul_intrinsic(opnd_type *result_opnd, 17494 expr_arg_type *res_exp_desc, 17495 int *spec_idx) 17496 { 17497 int ir_idx; 17498 int list_idx1; 17499 int list_idx2; 17500 int info_idx1; 17501 int info_idx2; 17502 opnd_type temp_opnd; 17503 17504 17505 TRACE (Func_Entry, "matmul_intrinsic", NULL); 17506 17507 # ifdef _INLINE_INTRINSICS 17508 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 17509 # endif 17510 17511 ir_idx = OPND_IDX((*result_opnd)); 17512 list_idx1 = IR_IDX_R(ir_idx); 17513 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 17514 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 17515 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 17516 17517 conform_check(0, 17518 ir_idx, 17519 res_exp_desc, 17520 spec_idx, 17521 FALSE); 17522 17523 res_exp_desc->rank = BD_RANK(ATD_ARRAY_IDX(ATP_RSLT_IDX(*spec_idx))); 17524 res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 17525 res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx); 17526 res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx); 17527 17528 if (arg_info_list[info_idx1].ed.rank == 2) { 17529 COPY_OPND(temp_opnd,arg_info_list[info_idx1].ed.shape[1]); 17530 } 17531 17532 if (arg_info_list[info_idx1].ed.rank == 1) { 17533 COPY_OPND(res_exp_desc->shape[0],arg_info_list[info_idx2].ed.shape[1]); 17534 COPY_OPND(temp_opnd,arg_info_list[info_idx1].ed.shape[0]); 17535 } 17536 else if (arg_info_list[info_idx2].ed.rank == 1) { 17537 COPY_OPND(res_exp_desc->shape[0],arg_info_list[info_idx1].ed.shape[0]); 17538 } 17539 else { 17540 COPY_OPND(res_exp_desc->shape[0],arg_info_list[info_idx1].ed.shape[0]); 17541 COPY_OPND(res_exp_desc->shape[1],arg_info_list[info_idx2].ed.shape[1]); 17542 } 17543 17544 if ((OPND_FLD(arg_info_list[info_idx2].ed.shape[0]) == CN_Tbl_Idx) && 17545 (OPND_FLD(temp_opnd) == CN_Tbl_Idx)) { 17546 if (CN_INT_TO_C(OPND_IDX(arg_info_list[info_idx2].ed.shape[0])) != 17547 CN_INT_TO_C(OPND_IDX(temp_opnd))) { 17548 PRINTMSG(arg_info_list[info_idx1].line, 1152, Error, 17549 arg_info_list[info_idx1].col); 17550 } 17551 } 17552 17553 # if defined(GENERATE_WHIRL) 17554 17555 if (res_exp_desc->rank == 1) { 17556 ATP_EXTERNAL_INTRIN(*spec_idx) = !opt_flags.mv_matmul_inline; 17557 } 17558 else { 17559 ATP_EXTERNAL_INTRIN(*spec_idx) = !opt_flags.matmul_inline; 17560 } 17561 # endif 17562 17563 # if 0 17564 17565 if (!ATP_EXTERNAL_INTRIN(*spec_idx)) { 17566 io_item_must_flatten = TRUE; 17567 IR_OPR(ir_idx) = Matmul_Opr; 17568 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 17569 IR_OPND_R(ir_idx) = null_opnd; 17570 } 17571 17572 # endif 17573 17574 IR_TYPE_IDX(ir_idx) = res_exp_desc->type_idx; 17575 IR_RANK(ir_idx) = res_exp_desc->rank; 17576 17577 /* must reset foldable and will_fold_later because there is no */ 17578 /* folder for this intrinsic in constructors. */ 17579 17580 res_exp_desc->foldable = FALSE; 17581 res_exp_desc->will_fold_later = FALSE; 17582 17583 17584 TRACE (Func_Exit, "matmul_intrinsic", NULL); 17585 17586 } /* matmul_intrinsic */ 17587 17588 17589 /******************************************************************************\ 17590 |* *| 17591 |* Description: *| 17592 |* Function TRANSFER(SOURCE, MOLD, SIZE) intrinsic. *| 17593 |* *| 17594 |* Input parameters: *| 17595 |* NONE *| 17596 |* *| 17597 |* Output parameters: *| 17598 |* NONE *| 17599 |* *| 17600 |* Returns: *| 17601 |* NOTHING *| 17602 |* *| 17603 \******************************************************************************/ 17604 17605 void transfer_intrinsic(opnd_type *result_opnd, 17606 expr_arg_type *res_exp_desc, 17607 int *spec_idx) 17608 { 17609 int line; 17610 int col; 17611 int ch_asg_idx; 17612 int info_idx1; 17613 int info_idx2; 17614 int info_idx3; 17615 int ir_idx; 17616 opnd_type length_opnd; 17617 int list_idx1; 17618 int list_idx2; 17619 int list_idx3; 17620 expr_arg_type loc_exp_desc; 17621 int new_idx; 17622 int type_idx; 17623 int_dope_type dope_1; 17624 int_dope_type dope_2; 17625 opnd_type opnd; 17626 boolean fold_it; 17627 int the_cn_idx; 17628 int i; 17629 int tmp_idx; 17630 int or_idx; 17631 int attr_idx; 17632 int constant_type_idx; 17633 long64 bit_length; 17634 int_dope_type dope_result; 17635 cif_usage_code_type save_xref_state; 17636 opnd_type shape_opnd; 17637 boolean ok; 17638 long_type the_constant[MAX_WORDS_FOR_NUMERIC]; /* JEFFL */ 17639 17640 17641 TRACE (Func_Entry, "transfer_intrinsic", NULL); 17642 17643 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 17644 17645 ir_idx = OPND_IDX((*result_opnd)); 17646 list_idx1 = IR_IDX_R(ir_idx); 17647 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 17648 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 17649 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 17650 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 17651 17652 fold_it = arg_info_list[info_idx1].ed.foldable && 17653 arg_info_list[info_idx2].ed.foldable; 17654 17655 type_idx = arg_info_list[info_idx2].ed.type_idx; 17656 17657 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 17658 17659 conform_check(0, 17660 ir_idx, 17661 res_exp_desc, 17662 spec_idx, 17663 FALSE); 17664 17665 res_exp_desc->rank = 0; 17666 res_exp_desc->type_idx = type_idx; 17667 17668 if (TYP_TYPE(type_idx) == Character) { 17669 COPY_OPND((res_exp_desc->char_len), 17670 (arg_info_list[info_idx2].ed.char_len)); 17671 } 17672 17673 if (list_idx3 == NULL_IDX) { /* no third argument */ 17674 if (arg_info_list[info_idx2].ed.rank > 0) { 17675 res_exp_desc->rank = 1; 17676 } 17677 } 17678 else { 17679 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 17680 17681 if (arg_info_list[info_idx3].ed.reference) { 17682 attr_idx = find_base_attr(&IL_OPND(list_idx3), &line, &col); 17683 17684 if (AT_OPTIONAL(attr_idx)) { 17685 PRINTMSG(arg_info_list[info_idx3].line, 875, Error, 17686 arg_info_list[info_idx3].col); 17687 } 17688 } 17689 17690 res_exp_desc->rank = 1; 17691 fold_it = fold_it && arg_info_list[info_idx3].ed.foldable; 17692 } 17693 17694 # if 0 17695 17696 if (fold_it) { 17697 COPY_OPND(opnd, IL_OPND(list_idx1)); 17698 gen_internal_dope_vector(&dope_1, 17699 &opnd, 17700 FALSE, 17701 &arg_info_list[info_idx1].ed); 17702 17703 COPY_OPND(opnd, IL_OPND(list_idx2)); 17704 gen_internal_dope_vector(&dope_2, 17705 &opnd, 17706 FALSE, 17707 &arg_info_list[info_idx2].ed); 17708 17709 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 17710 17711 gen_internal_dope_vector(&dope_result, 17712 &opnd, 17713 TRUE, 17714 &arg_info_list[info_idx2].ed); 17715 17716 dope_result.num_dims = res_exp_desc->rank; 17717 17718 if (list_idx3 == NULL_IDX) { 17719 if (folder_driver((char *)&dope_1, 17720 arg_info_list[info_idx1].ed.type_idx, 17721 (char *)&dope_2, 17722 arg_info_list[info_idx2].ed.type_idx, 17723 (long_type *)&dope_result, 17724 &type_idx, 17725 IR_LINE_NUM(ir_idx), 17726 IR_COL_NUM(ir_idx), 17727 3, 17728 Transfer_Opr, 17729 0L, 17730 0L)) { 17731 } 17732 } 17733 else { 17734 if (folder_driver((char *)&dope_1, 17735 arg_info_list[info_idx1].ed.type_idx, 17736 (char *)&dope_2, 17737 arg_info_list[info_idx2].ed.type_idx, 17738 (long_type *)&dope_result, 17739 &type_idx, 17740 IR_LINE_NUM(ir_idx), 17741 IR_COL_NUM(ir_idx), 17742 3, 17743 Transfer_Opr, 17744 (char *)&CN_CONST(IL_IDX(list_idx3)), 17745 (long)arg_info_list[info_idx3].ed.type_idx)) { 17746 } 17747 } 17748 17749 res_exp_desc->type = arg_info_list[info_idx2].ed.type; 17750 res_exp_desc->linear_type = arg_info_list[info_idx2].ed.linear_type; 17751 res_exp_desc->type_idx = arg_info_list[info_idx2].ed.type_idx; 17752 17753 if (res_exp_desc->rank == 0 && res_exp_desc->type != Structure) { 17754 17755 /* JEFFL - This is max so it probably can stay the same, but it would */ 17756 /* be nice to be consistent with other places. */ 17757 17758 # ifdef _TARGET_OS_MAX 17759 17760 if (TYP_LINEAR(type_idx) == Complex_4) { 17761 /* we need to unpack it into two words */ 17762 the_constant[0] = ((long_type *)dope_result.base_addr)[0]; 17763 the_constant[1] = the_constant[0] & 0xFFFFFFFF; 17764 the_constant[0] = the_constant[0] >> 32; 17765 17766 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 17767 OPND_IDX((*result_opnd)) = ntr_const_tbl(res_exp_desc->type_idx, 17768 FALSE, 17769 the_constant); 17770 } 17771 else 17772 # endif 17773 if (res_exp_desc->type != Character && 17774 storage_bit_size_tbl[res_exp_desc->linear_type] < 17775 TARGET_BITS_PER_WORD) { 17776 /* JEFFL */ 17777 17778 the_constant[0] = ((long_type *)dope_result.base_addr)[0] >> 17779 (TARGET_BITS_PER_WORD - 17780 storage_bit_size_tbl[res_exp_desc->linear_type]); 17781 17782 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 17783 OPND_IDX((*result_opnd)) = ntr_const_tbl(res_exp_desc->type_idx, 17784 FALSE, 17785 the_constant); 17786 } 17787 else { 17788 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 17789 OPND_IDX((*result_opnd)) = ntr_const_tbl(res_exp_desc->type_idx, 17790 FALSE, 17791 (long_type *)(dope_result.base_addr)); 17792 } 17793 17794 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 17795 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 17796 res_exp_desc->foldable = TRUE; 17797 res_exp_desc->constant = TRUE; 17798 } 17799 else { 17800 bit_length = 1; 17801 for (i = 1; i <= dope_result.num_dims; i++) { 17802 bit_length = bit_length * dope_result.dim[i-1].extent; 17803 } 17804 bit_length = bit_length * dope_result.el_len; 17805 17806 if (char_len_in_bytes) { 17807 if (TYP_TYPE(type_idx) == Character) { 17808 /* el_len was in bytes, so change to bits */ 17809 bit_length *= CHAR_BIT; 17810 } 17811 } 17812 17813 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 17814 TYP_TYPE(TYP_WORK_IDX) = Typeless; 17815 TYP_BIT_LEN(TYP_WORK_IDX) = bit_length; 17816 constant_type_idx = ntr_type_tbl(); 17817 17818 /* JEFFL */ 17819 the_cn_idx = ntr_const_tbl(constant_type_idx, 17820 FALSE, 17821 (long_type *)(dope_result.base_addr)); 17822 17823 tmp_idx = gen_compiler_tmp(IR_LINE_NUM(ir_idx), 17824 IR_COL_NUM(ir_idx), 17825 Shared, TRUE); 17826 17827 ATD_TYPE_IDX(tmp_idx) = type_idx; 17828 AT_SEMANTICS_DONE(tmp_idx)= TRUE; 17829 17830 for (i = 1; i <= dope_result.num_dims; i++) { 17831 OPND_FLD(shape_opnd) = CN_Tbl_Idx; 17832 OPND_IDX(shape_opnd) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 17833 dope_result.dim[i-1].extent); 17834 17835 OPND_LINE_NUM(shape_opnd) = IR_LINE_NUM(ir_idx); 17836 OPND_COL_NUM(shape_opnd) = IR_COL_NUM(ir_idx); 17837 SHAPE_WILL_FOLD_LATER(shape_opnd) = TRUE; 17838 SHAPE_FOLDABLE(shape_opnd) = TRUE; 17839 res_exp_desc->shape[i-1] = shape_opnd; 17840 } 17841 17842 ATD_ARRAY_IDX(tmp_idx) = create_bd_ntry_for_const(res_exp_desc, 17843 IR_LINE_NUM(ir_idx), 17844 IR_COL_NUM(ir_idx)); 17845 17846 ATD_SAVED(tmp_idx) = TRUE; 17847 ATD_DATA_INIT(tmp_idx) = TRUE; 17848 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 17849 ATD_FLD(tmp_idx) = CN_Tbl_Idx; 17850 ATD_TMP_IDX(tmp_idx) = the_cn_idx; 17851 ATD_TMP_INIT_NOT_DONE(tmp_idx) = TRUE; 17852 17853 OPND_IDX((*result_opnd)) = tmp_idx; 17854 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 17855 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 17856 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 17857 17858 if (insert_subs_ok) { 17859 if (res_exp_desc->rank) { 17860 ok = gen_whole_subscript(result_opnd, res_exp_desc); 17861 } 17862 else if (res_exp_desc->type == Character) { 17863 ok = gen_whole_substring(result_opnd, res_exp_desc->rank); 17864 } 17865 } 17866 17867 AT_REFERENCED(tmp_idx) = Referenced; 17868 AT_DEFINED(tmp_idx) = TRUE; 17869 17870 res_exp_desc->foldable = TRUE; 17871 res_exp_desc->tmp_reference = TRUE; 17872 } 17873 } 17874 else { 17875 17876 /* must reset foldable and will_fold_later because there is no */ 17877 /* folder for this intrinsic in constructors. */ 17878 17879 res_exp_desc->foldable = FALSE; 17880 res_exp_desc->will_fold_later = FALSE; 17881 17882 io_item_must_flatten = TRUE; 17883 17884 if (arg_info_list[info_idx2].ed.type == Character && 17885 (arg_info_list[info_idx2].ed.char_len.fld != 17886 TYP_FLD(arg_info_list[info_idx2].ed.type_idx) || 17887 arg_info_list[info_idx2].ed.char_len.idx != 17888 TYP_IDX(arg_info_list[info_idx2].ed.type_idx) || 17889 (IL_FLD(list_idx2) == IR_Tbl_Idx && 17890 IR_OPR(IL_IDX(list_idx2)) == Concat_Opr))) { 17891 17892 /* create a new type table index for this character type. */ 17893 17894 loc_exp_desc.rank = 0; 17895 17896 if (IL_FLD(list_idx2) == IR_Tbl_Idx && 17897 IR_OPR(IL_IDX(list_idx2)) == Concat_Opr) { 17898 17899 get_concat_len(IL_IDX(list_idx2), &length_opnd); 17900 } 17901 else { 17902 COPY_OPND(length_opnd, (arg_info_list[info_idx2].ed.char_len)); 17903 } 17904 17905 save_xref_state = xref_state; 17906 xref_state = CIF_No_Usage_Rec; 17907 ok = expr_semantics(&length_opnd, &loc_exp_desc); 17908 xref_state = save_xref_state; 17909 17910 if (loc_exp_desc.constant) { 17911 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 17912 17913 TYP_TYPE(TYP_WORK_IDX) = Character; 17914 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 17915 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 17916 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 17917 TYP_IDX(TYP_WORK_IDX) = OPND_IDX(length_opnd); 17918 res_exp_desc->type_idx = ntr_type_tbl(); 17919 res_exp_desc->type = Character; 17920 res_exp_desc->linear_type = CHARACTER_DEFAULT_TYPE; 17921 } 17922 else { /* non constant character length means an alloc'd item */ 17923 17924 GEN_COMPILER_TMP_ASG(ch_asg_idx, 17925 tmp_idx, 17926 TRUE, /* Semantics done */ 17927 IR_LINE_NUM(ir_idx), 17928 IR_COL_NUM(ir_idx), 17929 loc_exp_desc.type_idx, 17930 Priv); 17931 17932 COPY_OPND(IR_OPND_R(ch_asg_idx), length_opnd); 17933 17934 gen_sh(Before, Assignment_Stmt, stmt_start_line, 17935 stmt_start_col, FALSE, FALSE, TRUE); 17936 17937 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ch_asg_idx; 17938 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 17939 17940 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 17941 17942 TYP_TYPE(TYP_WORK_IDX) = Character; 17943 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 17944 TYP_CHAR_CLASS(TYP_WORK_IDX) = Var_Len_Char; 17945 TYP_FLD(TYP_WORK_IDX) = AT_Tbl_Idx; 17946 TYP_IDX(TYP_WORK_IDX) = tmp_idx; 17947 TYP_ORIG_LEN_IDX(TYP_WORK_IDX) = tmp_idx; 17948 res_exp_desc->type_idx = ntr_type_tbl(); 17949 res_exp_desc->type = Character; 17950 res_exp_desc->linear_type = CHARACTER_DEFAULT_TYPE; 17951 } 17952 17953 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = res_exp_desc->type_idx; 17954 arg_info_list[info_idx2].ed.type_idx = res_exp_desc->type_idx; 17955 arg_info_list[info_idx2].ed.char_len.fld = 17956 TYP_FLD(res_exp_desc->type_idx); 17957 arg_info_list[info_idx2].ed.char_len.idx = 17958 TYP_IDX(res_exp_desc->type_idx); 17959 } 17960 17961 17962 IR_LIST_CNT_R(ir_idx) = 3; 17963 17964 if (list_idx3 == NULL_IDX) { /* no third argument */ 17965 NTR_IR_LIST_TBL(new_idx); 17966 IL_INTRIN_PLACE_HOLDER(new_idx) = TRUE; 17967 IL_NEXT_LIST_IDX(list_idx2) = new_idx; 17968 IL_ARG_DESC_VARIANT(new_idx) = TRUE; 17969 } 17970 else { 17971 COPY_OPND(opnd, IL_OPND(list_idx3)); 17972 cast_to_cg_default(&opnd, &(arg_info_list[info_idx3].ed)); 17973 COPY_OPND(IL_OPND(list_idx3), opnd); 17974 } 17975 17976 17977 IR_TYPE_IDX(ir_idx) = type_idx; 17978 IR_RANK(ir_idx) = res_exp_desc->rank; 17979 17980 if (res_exp_desc->type == Character) { 17981 res_exp_desc->char_len.fld = TYP_FLD(res_exp_desc->type_idx); 17982 res_exp_desc->char_len.idx = TYP_IDX(res_exp_desc->type_idx); 17983 } 17984 17985 if ( 17986 # if defined(GENERATE_WHIRL) 17987 FALSE && /* never inline this intrinsic for IRIX */ 17988 # endif 17989 arg_info_list[info_idx1].ed.type != Character && 17990 arg_info_list[info_idx2].ed.type != Character && 17991 storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] == 17992 storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type] && 17993 storage_bit_size_tbl[TYPELESS_DEFAULT_TYPE] == 17994 storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type] && 17995 arg_info_list[info_idx1].ed.rank == 17996 arg_info_list[info_idx2].ed.rank && 17997 arg_info_list[info_idx2].ed.rank <= 1) { 17998 17999 /* 18000 If SIZE is present make sure it fits the parameters to 18001 do this intrinsic inline. 18002 */ 18003 if (!(list_idx3 != NULL_IDX && 18004 IL_FLD(list_idx3) == CN_Tbl_Idx && 18005 OPND_FLD(arg_info_list[info_idx1].ed.shape[0]) == CN_Tbl_Idx && 18006 IL_IDX(list_idx3) != 18007 OPND_IDX(arg_info_list[info_idx1].ed.shape[0]))) { 18008 18009 res_exp_desc->type = arg_info_list[info_idx2].ed.type; 18010 res_exp_desc->linear_type = arg_info_list[info_idx2].ed.linear_type; 18011 res_exp_desc->type_idx = arg_info_list[info_idx2].ed.type_idx; 18012 18013 COPY_OPND(res_exp_desc->shape[0], 18014 arg_info_list[info_idx1].ed.shape[0]); 18015 18016 or_idx = gen_ir(IL_FLD(list_idx1), IL_IDX(list_idx1), 18017 Bor_Opr, TYPELESS_DEFAULT_TYPE, IR_LINE_NUM(ir_idx), 18018 IR_COL_NUM(ir_idx), 18019 CN_Tbl_Idx, CN_INTEGER_ZERO_IDX); 18020 18021 IR_OPR(ir_idx) = Cvrt_Opr; 18022 IR_FLD_L(ir_idx) = IR_Tbl_Idx; 18023 IR_IDX_L(ir_idx) = or_idx; 18024 IR_OPND_R(ir_idx) = null_opnd; 18025 IR_TYPE_IDX(ir_idx) = res_exp_desc->type_idx; 18026 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 18027 } 18028 } 18029 } 18030 18031 # endif 18032 18033 res_exp_desc->foldable = FALSE; 18034 res_exp_desc->will_fold_later = FALSE; 18035 18036 18037 TRACE (Func_Exit, "transfer_intrinsic", NULL); 18038 18039 } /* transfer_intrinsic */ 18040 18041 18042 18043 /******************************************************************************\ 18044 |* *| 18045 |* Description: *| 18046 |* Function SIZEOF(X) intrinsic. *| 18047 |* *| 18048 |* Input parameters: *| 18049 |* NONE *| 18050 |* *| 18051 |* Output parameters: *| 18052 |* NONE *| 18053 |* *| 18054 |* Returns: *| 18055 |* NOTHING *| 18056 |* *| 18057 \******************************************************************************/ 18058 18059 void sizeof_intrinsic(opnd_type *result_opnd, 18060 expr_arg_type *res_exp_desc, 18061 int *spec_idx) 18062 { 18063 int ir_idx; 18064 int info_idx1; 18065 int cn_idx; 18066 long num; 18067 18068 18069 TRACE (Func_Entry, "sizeof_intrinsic", NULL); 18070 18071 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 18072 ir_idx = OPND_IDX((*result_opnd)); 18073 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 18074 18075 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE; 18076 18077 conform_check(0, 18078 ir_idx, 18079 res_exp_desc, 18080 spec_idx, 18081 FALSE); 18082 18083 18084 res_exp_desc->rank = 0; 18085 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 18086 IR_RANK(ir_idx) = res_exp_desc->rank; 18087 18088 # if 0 /* April */ 18089 18090 /* must reset foldable and will_fold_later because there is no */ 18091 /* folder for this intrinsic in constructors. */ 18092 18093 res_exp_desc->foldable = FALSE; 18094 res_exp_desc->will_fold_later = FALSE; 18095 18096 if (arg_info_list[info_idx1].ed.rank == 0 && 18097 arg_info_list[info_idx1].ed.type != Character) { 18098 18099 num = storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] / 18100 CHAR_BIT; 18101 18102 cn_idx = C_INT_TO_CN(INTEGER_DEFAULT_TYPE, num); 18103 18104 OPND_IDX((*result_opnd)) = cn_idx; 18105 OPND_FLD((*result_opnd)) = CN_Tbl_Idx; 18106 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 18107 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 18108 res_exp_desc->constant = TRUE; 18109 res_exp_desc->foldable = TRUE; 18110 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 18111 } 18112 # endif 18113 res_exp_desc->foldable = FALSE; 18114 res_exp_desc->will_fold_later = FALSE; 18115 18116 TRACE (Func_Exit, "sizeof_intrinsic", NULL); 18117 18118 } /* sizeof_intrinsic */ 18119 18120 18121 18122 18123 /******************************************************************************\ 18124 |* *| 18125 |* Description: *| 18126 |* Function ALLOCATED(ARRAY) intrinsic. *| 18127 |* *| 18128 |* Input parameters: *| 18129 |* NONE *| 18130 |* *| 18131 |* Output parameters: *| 18132 |* NONE *| 18133 |* *| 18134 |* Returns: *| 18135 |* NOTHING *| 18136 |* *| 18137 \******************************************************************************/ 18138 void allocated_intrinsic(opnd_type *result_opnd, 18139 expr_arg_type *res_exp_desc, 18140 int *spec_idx) 18141 { 18142 int col; 18143 int dv_idx; 18144 int ir_idx; 18145 int info_idx1; 18146 int line; 18147 opnd_type opnd; 18148 18149 18150 TRACE (Func_Entry, "allocated_intrinsic", NULL); 18151 18152 has_present_opr = TRUE; 18153 18154 ir_idx = OPND_IDX((*result_opnd)); 18155 info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx)); 18156 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 18157 18158 COPY_OPND(opnd, IL_OPND(IR_IDX_R(ir_idx))); 18159 line = IR_LINE_NUM(ir_idx); 18160 col = IR_COL_NUM(ir_idx); 18161 18162 conform_check(0, 18163 ir_idx, 18164 res_exp_desc, 18165 spec_idx, 18166 FALSE); 18167 18168 if (!arg_info_list[info_idx1].ed.allocatable) { 18169 PRINTMSG(arg_info_list[info_idx1].line, 833, Error, 18170 arg_info_list[info_idx1].col); 18171 } 18172 18173 # if 0 18174 18175 res_exp_desc->rank = 0; 18176 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 18177 18178 18179 if (OPND_FLD(opnd) == IR_Tbl_Idx && 18180 (IR_OPR(OPND_IDX(opnd)) == Substring_Opr || 18181 IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr)) { 18182 18183 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 18184 } 18185 18186 if (OPND_FLD(opnd) == IR_Tbl_Idx && 18187 (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr || 18188 IR_OPR(OPND_IDX(opnd)) == Section_Subscript_Opr || 18189 IR_OPR(OPND_IDX(opnd)) == Subscript_Opr)) { 18190 18191 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 18192 } 18193 18194 if (OPND_FLD(opnd) == IR_Tbl_Idx && 18195 IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) { 18196 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 18197 } 18198 18199 dv_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 18200 Dv_Access_Assoc, CG_INTEGER_DEFAULT_TYPE, line, col, 18201 NO_Tbl_Idx, NULL_IDX); 18202 18203 ir_idx = gen_ir(IR_Tbl_Idx, dv_idx, 18204 Eq_Opr, LOGICAL_DEFAULT_TYPE, line, col, 18205 CN_Tbl_Idx, CN_INTEGER_ONE_IDX); 18206 18207 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 18208 OPND_IDX((*result_opnd)) = ir_idx; 18209 18210 /* must reset foldable and will_fold_later because there is no */ 18211 /* folder for this intrinsic in constructors. */ 18212 18213 # endif 18214 18215 res_exp_desc->foldable = FALSE; 18216 res_exp_desc->will_fold_later = FALSE; 18217 18218 18219 TRACE (Func_Exit, "allocted_intrinsic", NULL); 18220 18221 } /* allocated_intrinsic */ 18222 18223 18224 /******************************************************************************\ 18225 |* *| 18226 |* Description: *| 18227 |* Function ASSOCIATED(POINTER, TARGET) intrinsic. *| 18228 |* *| 18229 |* Input parameters: *| 18230 |* NONE *| 18231 |* *| 18232 |* Output parameters: *| 18233 |* NONE *| 18234 |* *| 18235 |* Returns: *| 18236 |* NOTHING *| 18237 |* *| 18238 \******************************************************************************/ 18239 18240 void associated_intrinsic(opnd_type *result_opnd, 18241 expr_arg_type *res_exp_desc, 18242 int *spec_idx) 18243 { 18244 int col; 18245 int dv_idx; 18246 int info_idx1; 18247 int info_idx2; 18248 int ir_idx; 18249 int line; 18250 int list_idx1; 18251 int list_idx2; 18252 opnd_type opnd; 18253 18254 18255 TRACE (Func_Entry, "associated_intrinsic", NULL); 18256 18257 has_present_opr = TRUE; 18258 18259 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 18260 ir_idx = OPND_IDX((*result_opnd)); 18261 list_idx1 = IR_IDX_R(ir_idx); 18262 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 18263 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 18264 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE; 18265 18266 conform_check(0, 18267 ir_idx, 18268 res_exp_desc, 18269 spec_idx, 18270 FALSE); 18271 18272 if (!arg_info_list[info_idx1].ed.pointer) { 18273 PRINTMSG(arg_info_list[info_idx1].line, 784, Error, 18274 arg_info_list[info_idx1].col); 18275 } 18276 18277 if (list_idx2 == NULL_IDX) { 18278 /* TARGET is not present */ 18279 # if 0 18280 COPY_OPND(opnd, IL_OPND(list_idx1)); 18281 line = IR_LINE_NUM(ir_idx); 18282 col = IR_COL_NUM(ir_idx); 18283 18284 res_exp_desc->rank = 0; 18285 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 18286 18287 if (OPND_FLD(opnd) == IR_Tbl_Idx && 18288 (IR_OPR(OPND_IDX(opnd)) == Substring_Opr || 18289 IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr)) { 18290 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 18291 } 18292 18293 if (OPND_FLD(opnd) == IR_Tbl_Idx && 18294 (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr || 18295 IR_OPR(OPND_IDX(opnd)) == Section_Subscript_Opr || 18296 IR_OPR(OPND_IDX(opnd)) == Subscript_Opr)) { 18297 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 18298 } 18299 18300 if (OPND_FLD(opnd) == IR_Tbl_Idx && 18301 IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr) { 18302 COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd))); 18303 } 18304 18305 dv_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd), 18306 Dv_Access_Assoc, CG_INTEGER_DEFAULT_TYPE, line, col, 18307 NO_Tbl_Idx, NULL_IDX); 18308 18309 ir_idx = gen_ir(IR_Tbl_Idx, dv_idx, 18310 Eq_Opr, LOGICAL_DEFAULT_TYPE, line, col, 18311 CN_Tbl_Idx, CN_INTEGER_ONE_IDX); 18312 18313 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 18314 OPND_IDX((*result_opnd)) = ir_idx; 18315 # endif 18316 18317 } 18318 else { /* TARGET is present */ 18319 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 18320 18321 if ((!arg_info_list[info_idx2].ed.pointer) && 18322 (!arg_info_list[info_idx2].ed.target)) { 18323 PRINTMSG(arg_info_list[info_idx2].line, 783, Error, 18324 arg_info_list[info_idx2].col); 18325 } 18326 # if 0 18327 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 18328 res_exp_desc->rank = 0; 18329 IR_RANK(ir_idx) = res_exp_desc->rank; 18330 # endif 18331 } 18332 18333 /* must reset foldable and will_fold_later because there is no */ 18334 /* folder for this intrinsic in constructors. */ 18335 18336 res_exp_desc->foldable = FALSE; 18337 res_exp_desc->will_fold_later = FALSE; 18338 18339 TRACE (Func_Exit, "associated_intrinsic", NULL); 18340 18341 } /* associated_intrinsic */ 18342 18343 18344 /******************************************************************************\ 18345 |* *| 18346 |* Description: *| 18347 |* Function RESHAPE(SOURCE, SHAPE, PAD, ORDER) intrinsic. *| 18348 |* *| 18349 |* Input parameters: *| 18350 |* NONE *| 18351 |* *| 18352 |* Output parameters: *| 18353 |* NONE *| 18354 |* *| 18355 |* Returns: *| 18356 |* NOTHING *| 18357 |* *| 18358 \******************************************************************************/ 18359 18360 void reshape_intrinsic(opnd_type *result_opnd, 18361 expr_arg_type *res_exp_desc, 18362 int *spec_idx) 18363 18364 { 18365 int info_idx1; 18366 int info_idx2; 18367 int info_idx3; 18368 int info_idx4; 18369 int ir_idx; 18370 int line; 18371 int col; 18372 int the_cn_idx; 18373 int cn_idx; 18374 int i; 18375 int tmp_idx; 18376 opnd_type new_opnd; 18377 int list_idx; 18378 int list_idx1; 18379 int list_idx2; 18380 int list_idx3; 18381 int list_idx4; 18382 int type_idx; 18383 int lhs_type; 18384 int rhs_type; 18385 int attr_idx; 18386 int constant_type_idx; 18387 long64 bit_length; 18388 int_dope_type dope_result; 18389 int_dope_type dope_1; 18390 int_dope_type dope_2; 18391 int_dope_type dope_3; 18392 int_dope_type dope_4; 18393 opnd_type opnd; 18394 opnd_type shape_opnd; 18395 int sub_idx; 18396 int left_idx; 18397 int left_fld; 18398 long64 rank; 18399 boolean fold_it; 18400 boolean optimize = TRUE; 18401 boolean ok; 18402 long64 vv; 18403 int valu1; 18404 long valu2; 18405 expr_arg_type exp_desc; 18406 18407 18408 TRACE (Func_Entry, "reshape_intrinsic", NULL); 18409 18410 ir_idx = OPND_IDX((*result_opnd)); 18411 ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE; 18412 18413 list_idx1 = IR_IDX_R(ir_idx); 18414 list_idx2 = IL_NEXT_LIST_IDX(list_idx1); 18415 list_idx3 = IL_NEXT_LIST_IDX(list_idx2); 18416 list_idx4 = IL_NEXT_LIST_IDX(list_idx3); 18417 18418 info_idx1 = IL_ARG_DESC_IDX(list_idx1); 18419 info_idx2 = IL_ARG_DESC_IDX(list_idx2); 18420 18421 type_idx = arg_info_list[info_idx1].ed.type_idx; 18422 18423 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx; 18424 18425 fold_it = arg_info_list[info_idx1].ed.foldable && 18426 arg_info_list[info_idx2].ed.foldable; 18427 18428 if (arg_info_list[info_idx1].ed.rank < 1) { 18429 PRINTMSG(arg_info_list[info_idx1].line, 640, Error, 18430 arg_info_list[info_idx1].col); 18431 fold_it = FALSE; 18432 optimize = FALSE; 18433 } 18434 18435 conform_check(0, 18436 ir_idx, 18437 res_exp_desc, 18438 spec_idx, 18439 FALSE); 18440 18441 /* 18442 This block of code will optimize a call to RESHAPE by 18443 completely eliminating the call. This is attempted 18444 if just the first and second argument to reshape are present. 18445 Also, the result must have rank 2. 18446 */ 18447 18448 18449 if (list_idx1 != NULL_IDX && IL_IDX(list_idx1) != NULL_IDX && 18450 list_idx2 != NULL_IDX && IL_IDX(list_idx2) != NULL_IDX && 18451 list_idx3 != NULL_IDX && IL_IDX(list_idx3) == NULL_IDX && 18452 list_idx4 != NULL_IDX && IL_IDX(list_idx4) == NULL_IDX) { 18453 if (IR_FLD_R(ir_idx) == IL_Tbl_Idx && 18454 IL_FLD(list_idx1) == IR_Tbl_Idx && 18455 IL_FLD(list_idx2) == IR_Tbl_Idx && 18456 IR_FLD_L(IL_IDX(list_idx1)) == AT_Tbl_Idx && 18457 IR_FLD_L(IL_IDX(list_idx2)) == AT_Tbl_Idx && 18458 AT_OBJ_CLASS(IR_IDX_L(IL_IDX(list_idx1))) == Data_Obj && 18459 ATD_CLASS(IR_IDX_L(IL_IDX(list_idx1))) == Compiler_Tmp && 18460 ATD_TMP_INIT_NOT_DONE(IR_IDX_L(IL_IDX(list_idx1)))) { 18461 rhs_type = TYP_LINEAR(ATD_TYPE_IDX(IR_IDX_L(IL_IDX(list_idx1)))); 18462 18463 list_idx = IR_IDX_R(IL_IDX(list_idx2)); 18464 list_idx = IL_IDX(list_idx); 18465 list_idx = IR_IDX_L(list_idx); 18466 list_idx = IL_NEXT_LIST_IDX(list_idx); 18467 if (IL_FLD(list_idx) == CN_Tbl_Idx) { 18468 rank = (long) CN_INT_TO_C(IL_IDX(list_idx)); 18469 if (rank == 2 && 18470 IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) == Asg_Opr) { 18471 left_idx = IR_IDX_L(SH_IR_IDX(curr_stmt_sh_idx)); 18472 left_fld = IR_FLD_L(SH_IR_IDX(curr_stmt_sh_idx)); 18473 lhs_type = TYP_LINEAR(IR_TYPE_IDX(left_idx)); 18474 if (left_fld == IR_Tbl_Idx && 18475 IR_RANK(left_idx) == rank && 18476 rhs_type == lhs_type) { 18477 copy_subtree(&IR_OPND_L(SH_IR_IDX(curr_stmt_sh_idx)), 18478 &new_opnd); 18479 if (IR_FLD_L(OPND_IDX(new_opnd)) == AT_Tbl_Idx) { 18480 attr_idx = IR_IDX_L(OPND_IDX(new_opnd)); 18481 IR_IDX_L(OPND_IDX(new_opnd)) = IR_IDX_L(IL_IDX(list_idx1)); 18482 ATD_ARRAY_IDX(IR_IDX_L(IL_IDX(list_idx1))) = 18483 ATD_ARRAY_IDX(attr_idx); 18484 18485 res_exp_desc->rank = 2; 18486 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 18487 fold_it = FALSE; 18488 OPND_IDX((*result_opnd)) = OPND_IDX(new_opnd); 18489 OPND_FLD((*result_opnd)) = OPND_FLD(new_opnd); 18490 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 18491 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 18492 } 18493 } 18494 } 18495 } 18496 } 18497 } 18498 18499 18500 if (OPND_FLD(arg_info_list[info_idx2].ed.shape[0]) == IR_Tbl_Idx) { 18501 PRINTMSG(arg_info_list[info_idx2].line, 1106, Error, 18502 arg_info_list[info_idx2].col); 18503 18504 res_exp_desc->rank = 0; 18505 fold_it = FALSE; 18506 optimize = FALSE; 18507 } 18508 else if (OPND_FLD(arg_info_list[info_idx2].ed.shape[0]) == NO_Tbl_Idx) { 18509 res_exp_desc->rank = 0; 18510 fold_it = FALSE; 18511 optimize = FALSE; 18512 } 18513 else { 18514 res_exp_desc->rank = (long) 18515 CN_INT_TO_C(OPND_IDX(arg_info_list[info_idx2].ed.shape[0])); 18516 18517 if (res_exp_desc->rank > MAX_NUM_DIMS) { 18518 PRINTMSG(arg_info_list[info_idx2].line, 1106, Error, 18519 arg_info_list[info_idx2].col); 18520 18521 res_exp_desc->rank = 0; 18522 fold_it = FALSE; 18523 optimize = FALSE; 18524 } 18525 else if (arg_info_list[info_idx2].ed.foldable) { 18526 /* check that each element is >= 0 */ 18527 attr_idx = find_base_attr(&IL_OPND(list_idx2), &line, &col); 18528 18529 # ifdef _DEBUG 18530 if (attr_idx == NULL_IDX || 18531 AT_OBJ_CLASS(attr_idx) != Data_Obj || 18532 ATD_CLASS(attr_idx) != Compiler_Tmp || 18533 ATD_FLD(attr_idx) != CN_Tbl_Idx || 18534 ATD_TMP_IDX(attr_idx) == NULL_IDX) { 18535 18536 PRINTMSG(arg_info_list[info_idx2].line, 626, Internal, 18537 arg_info_list[info_idx2].col, 18538 "array constant", "reshape_intrinsic"); 18539 } 18540 # endif 18541 NTR_IR_TBL(sub_idx); 18542 IR_OPR(sub_idx) = Subscript_Opr; 18543 IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx); 18544 IR_LINE_NUM(sub_idx) = line; 18545 IR_COL_NUM(sub_idx) = col; 18546 18547 IR_FLD_L(sub_idx) = AT_Tbl_Idx; 18548 IR_IDX_L(sub_idx) = attr_idx; 18549 18550 IR_FLD_R(sub_idx) = IL_Tbl_Idx; 18551 IR_LIST_CNT_R(sub_idx) = 1; 18552 NTR_IR_LIST_TBL(list_idx); 18553 18554 IR_IDX_R(sub_idx) = list_idx; 18555 18556 IL_FLD(list_idx) = CN_Tbl_Idx; 18557 18558 exp_desc = init_exp_desc; 18559 exp_desc.type_idx = ATD_TYPE_IDX(attr_idx); 18560 exp_desc.type = TYP_TYPE(exp_desc.type_idx); 18561 exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx); 18562 exp_desc.foldable = TRUE; 18563 exp_desc.constant = TRUE; 18564 18565 for (i = 0; i < res_exp_desc->rank; i++) { 18566 IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, i+1); 18567 OPND_FLD(opnd) = IR_Tbl_Idx; 18568 OPND_IDX(opnd) = sub_idx; 18569 ok = fold_aggragate_expression(&opnd, 18570 &exp_desc, 18571 TRUE); 18572 18573 if (compare_cn_and_value(OPND_IDX(opnd), 0, Lt_Opr)) { 18574 PRINTMSG(arg_info_list[info_idx2].line, 1176, Error, 18575 arg_info_list[info_idx2].col); 18576 18577 fold_it = FALSE; 18578 optimize = FALSE; 18579 break; 18580 } 18581 } 18582 18583 FREE_IR_NODE(sub_idx); 18584 FREE_IR_LIST_NODE(list_idx); 18585 } 18586 18587 } 18588 18589 switch (res_exp_desc->rank) { 18590 case 0: ATD_ARRAY_IDX(ATP_RSLT_IDX(*spec_idx)) = NULL_IDX; 18591 break; 18592 case 1: ATD_ARRAY_IDX(ATP_RSLT_IDX(*spec_idx)) = BD_DEFERRED_1_IDX; 18593 break; 18594 case 2: ATD_ARRAY_IDX(ATP_RSLT_IDX(*spec_idx)) = BD_DEFERRED_2_IDX; 18595 break; 18596 case 3: ATD_ARRAY_IDX(ATP_RSLT_IDX(*spec_idx)) = BD_DEFERRED_3_IDX; 18597 break; 18598 case 4: ATD_ARRAY_IDX(ATP_RSLT_IDX(*spec_idx)) = BD_DEFERRED_4_IDX; 18599 break; 18600 case 5: ATD_ARRAY_IDX(ATP_RSLT_IDX(*spec_idx)) = BD_DEFERRED_5_IDX; 18601 break; 18602 case 6: ATD_ARRAY_IDX(ATP_RSLT_IDX(*spec_idx)) = BD_DEFERRED_6_IDX; 18603 break; 18604 case 7: ATD_ARRAY_IDX(ATP_RSLT_IDX(*spec_idx)) = BD_DEFERRED_7_IDX; 18605 break; 18606 } 18607 18608 if (list_idx3 != NULL_IDX && IL_IDX(list_idx3) != NULL_IDX) { 18609 info_idx3 = IL_ARG_DESC_IDX(list_idx3); 18610 18611 fold_it = fold_it && arg_info_list[info_idx3].ed.foldable; 18612 18613 if (arg_info_list[info_idx3].ed.rank < 1) { 18614 PRINTMSG(arg_info_list[info_idx3].line, 640, Error, 18615 arg_info_list[info_idx3].col); 18616 fold_it = FALSE; 18617 optimize = FALSE; 18618 } 18619 } 18620 else { 18621 18622 /* #if 0 */ 18623 18624 if (fold_it) { 18625 valu2 = 1; 18626 for (i = 1; i <= res_exp_desc->rank; i++) { 18627 COPY_OPND(opnd, IL_OPND(list_idx2)); 18628 vv = i; 18629 cn_idx = get_next_array_expr_element(&opnd, &vv); 18630 valu2 = valu2 * (long) CN_INT_TO_C(cn_idx); 18631 COPY_OPND(IL_OPND(list_idx2), opnd); 18632 } 18633 18634 valu1 = 1; 18635 for (i = 1; i <= arg_info_list[info_idx1].ed.rank; i++) { 18636 valu1 = valu1 * (long) 18637 CN_INT_TO_C(OPND_IDX(arg_info_list[info_idx1].ed.shape[i-1])); 18638 } 18639 18640 if (valu1 < valu2) { 18641 PRINTMSG(arg_info_list[info_idx2].line, 1187, Error, 18642 arg_info_list[info_idx2].col); 18643 fold_it = FALSE; 18644 optimize = FALSE; 18645 } 18646 } 18647 18648 /* #endif */ 18649 } 18650 18651 18652 if (list_idx4 != NULL_IDX && IL_IDX(list_idx4) != NULL_IDX) { 18653 info_idx4 = IL_ARG_DESC_IDX(list_idx4); 18654 fold_it = fold_it && arg_info_list[info_idx4].ed.foldable; 18655 18656 if (arg_info_list[info_idx4].ed.rank != 1) { 18657 PRINTMSG(arg_info_list[info_idx4].line, 654, Error, 18658 arg_info_list[info_idx4].col); 18659 fold_it = FALSE; 18660 optimize = FALSE; 18661 } 18662 } 18663 18664 /* # if 0 */ 18665 18666 if (fold_it) { 18667 18668 COPY_OPND(opnd, IL_OPND(list_idx1)); 18669 gen_internal_dope_vector(&dope_1, 18670 &opnd, 18671 FALSE, 18672 &arg_info_list[info_idx1].ed); 18673 18674 /* Set the compiler tmp for the array to Not_Referenced */ 18675 /* so that space will not be wasted in static space. */ 18676 /* After the fold of reshape, these arguments are not */ 18677 /* needed. */ 18678 18679 tmp_idx = find_base_attr(&opnd, &line, &col); 18680 18681 if (AT_OBJ_CLASS(tmp_idx) == Data_Obj && 18682 ATD_CLASS(tmp_idx) == Compiler_Tmp) { 18683 18684 AT_REFERENCED(tmp_idx) = Not_Referenced; 18685 } 18686 18687 COPY_OPND(opnd, IL_OPND(list_idx2)); 18688 gen_internal_dope_vector(&dope_2, 18689 &opnd, 18690 FALSE, 18691 &arg_info_list[info_idx2].ed); 18692 18693 /* Set the compiler tmp for the array to Not_Referenced */ 18694 /* so that space will not be wasted in static space. */ 18695 /* After the fold of reshape, these arguments are not */ 18696 /* needed. */ 18697 18698 tmp_idx = find_base_attr(&opnd, &line, &col); 18699 18700 if (AT_OBJ_CLASS(tmp_idx) == Data_Obj && 18701 ATD_CLASS(tmp_idx) == Compiler_Tmp) { 18702 18703 AT_REFERENCED(tmp_idx) = Not_Referenced; 18704 } 18705 18706 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 18707 18708 gen_internal_dope_vector(&dope_result, 18709 &opnd, 18710 TRUE, 18711 &arg_info_list[info_idx1].ed); 18712 18713 /* must reset the dope_result.rank to the result rank */ 18714 dope_result.num_dims = res_exp_desc->rank; 18715 18716 if ((IL_IDX(list_idx3) == NULL_IDX) && (IL_IDX(list_idx4) == NULL_IDX)) { 18717 if (folder_driver((char *)&dope_1, 18718 arg_info_list[info_idx1].ed.type_idx, 18719 (char *)&dope_2, 18720 arg_info_list[info_idx2].ed.type_idx, 18721 (long_type *)&dope_result, 18722 &type_idx, 18723 IR_LINE_NUM(ir_idx), 18724 IR_COL_NUM(ir_idx), 18725 4, 18726 Reshape_Opr, 18727 0L, 18728 0L, 18729 0L, 18730 0L)) { 18731 } 18732 } 18733 else if (IL_IDX(list_idx4) == NULL_IDX) { 18734 18735 COPY_OPND(opnd, IL_OPND(list_idx3)); 18736 gen_internal_dope_vector(&dope_3, 18737 &opnd, 18738 FALSE, 18739 &arg_info_list[info_idx3].ed); 18740 18741 /* Set the compiler tmp for the array to Not_Referenced */ 18742 /* so that space will not be wasted in static space. */ 18743 /* After the fold of reshape, these arguments are not */ 18744 /* needed. */ 18745 18746 tmp_idx = find_base_attr(&opnd, &line, &col); 18747 18748 if (AT_OBJ_CLASS(tmp_idx) == Data_Obj && 18749 ATD_CLASS(tmp_idx) == Compiler_Tmp) { 18750 18751 AT_REFERENCED(tmp_idx) = Not_Referenced; 18752 } 18753 18754 if (folder_driver((char *)&dope_1, 18755 arg_info_list[info_idx1].ed.type_idx, 18756 (char *)&dope_2, 18757 arg_info_list[info_idx2].ed.type_idx, 18758 (long_type *)&dope_result, 18759 &type_idx, 18760 IR_LINE_NUM(ir_idx), 18761 IR_COL_NUM(ir_idx), 18762 4, 18763 Reshape_Opr, 18764 (char *)&dope_3, 18765 (long)arg_info_list[info_idx3].ed.type_idx, 18766 0L, 18767 0L)) { 18768 } 18769 } 18770 else if (IL_IDX(list_idx3) == NULL_IDX) { 18771 18772 COPY_OPND(opnd, IL_OPND(list_idx4)); 18773 gen_internal_dope_vector(&dope_4, 18774 &opnd, 18775 FALSE, 18776 &arg_info_list[info_idx4].ed); 18777 18778 /* Set the compiler tmp for the array to Not_Referenced */ 18779 /* so that space will not be wasted in static space. */ 18780 /* After the fold of reshape, these arguments are not */ 18781 /* needed. */ 18782 18783 tmp_idx = find_base_attr(&opnd, &line, &col); 18784 18785 if (AT_OBJ_CLASS(tmp_idx) == Data_Obj && 18786 ATD_CLASS(tmp_idx) == Compiler_Tmp) { 18787 18788 AT_REFERENCED(tmp_idx) = Not_Referenced; 18789 } 18790 18791 if (folder_driver((char *)&dope_1, 18792 arg_info_list[info_idx1].ed.type_idx, 18793 (char *)&dope_2, 18794 arg_info_list[info_idx2].ed.type_idx, 18795 (long_type *)&dope_result, 18796 &type_idx, 18797 IR_LINE_NUM(ir_idx), 18798 IR_COL_NUM(ir_idx), 18799 4, 18800 Reshape_Opr, 18801 0L, 18802 0L, 18803 (char *)&dope_4, 18804 (long)arg_info_list[info_idx4].ed.type_idx)) { 18805 } 18806 } 18807 else { 18808 COPY_OPND(opnd, IL_OPND(list_idx3)); 18809 gen_internal_dope_vector(&dope_3, 18810 &opnd, 18811 FALSE, 18812 &arg_info_list[info_idx3].ed); 18813 18814 /* Set the compiler tmp for the array to Not_Referenced */ 18815 /* so that space will not be wasted in static space. */ 18816 /* After the fold of reshape, these arguments are not */ 18817 /* needed. */ 18818 18819 tmp_idx = find_base_attr(&opnd, &line, &col); 18820 18821 if (AT_OBJ_CLASS(tmp_idx) == Data_Obj && 18822 ATD_CLASS(tmp_idx) == Compiler_Tmp) { 18823 18824 AT_REFERENCED(tmp_idx) = Not_Referenced; 18825 } 18826 18827 COPY_OPND(opnd, IL_OPND(list_idx4)); 18828 gen_internal_dope_vector(&dope_4, 18829 &opnd, 18830 FALSE, 18831 &arg_info_list[info_idx4].ed); 18832 18833 /* Set the compiler tmp for the array to Not_Referenced */ 18834 /* so that space will not be wasted in static space. */ 18835 /* After the fold of reshape, these arguments are not */ 18836 /* needed. */ 18837 18838 tmp_idx = find_base_attr(&opnd, &line, &col); 18839 18840 if (AT_OBJ_CLASS(tmp_idx) == Data_Obj && 18841 ATD_CLASS(tmp_idx) == Compiler_Tmp) { 18842 18843 AT_REFERENCED(tmp_idx) = Not_Referenced; 18844 } 18845 18846 if (folder_driver((char *)&dope_1, 18847 arg_info_list[info_idx1].ed.type_idx, 18848 (char *)&dope_2, 18849 arg_info_list[info_idx2].ed.type_idx, 18850 (long_type *)&dope_result, 18851 &type_idx, 18852 IR_LINE_NUM(ir_idx), 18853 IR_COL_NUM(ir_idx), 18854 4, 18855 Reshape_Opr, 18856 (char *)&dope_3, 18857 (long)arg_info_list[info_idx3].ed.type_idx, 18858 (char *)&dope_4, 18859 (long)arg_info_list[info_idx4].ed.type_idx)) { 18860 } 18861 } 18862 18863 bit_length = 1; 18864 for (i = 1; i <= dope_result.num_dims; i++) { 18865 bit_length = bit_length * dope_result.dim[i-1].extent; 18866 } 18867 bit_length = bit_length * dope_result.el_len; 18868 18869 if (char_len_in_bytes) { 18870 if (TYP_TYPE(type_idx) == Character) { 18871 /* el_len was in bytes, so change to bits */ 18872 bit_length *= CHAR_BIT; 18873 } 18874 } 18875 18876 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 18877 TYP_TYPE(TYP_WORK_IDX) = Typeless; 18878 TYP_BIT_LEN(TYP_WORK_IDX) = bit_length; 18879 constant_type_idx = ntr_type_tbl(); 18880 18881 /* JEFFL */ 18882 the_cn_idx = ntr_const_tbl(constant_type_idx, 18883 FALSE, 18884 (long_type *)(dope_result.base_addr)); 18885 18886 tmp_idx = gen_compiler_tmp(IR_LINE_NUM(ir_idx), 18887 IR_COL_NUM(ir_idx), 18888 Shared, TRUE); 18889 18890 ATD_TYPE_IDX(tmp_idx) = type_idx; 18891 AT_SEMANTICS_DONE(tmp_idx)= TRUE; 18892 18893 for (i = 1; i <= dope_result.num_dims; i++) { 18894 OPND_FLD(shape_opnd) = CN_Tbl_Idx; 18895 OPND_IDX(shape_opnd) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 18896 dope_result.dim[i-1].extent); 18897 OPND_LINE_NUM(shape_opnd) = IR_LINE_NUM(ir_idx); 18898 OPND_COL_NUM(shape_opnd) = IR_COL_NUM(ir_idx); 18899 18900 SHAPE_WILL_FOLD_LATER(shape_opnd) = TRUE; 18901 SHAPE_FOLDABLE(shape_opnd) = TRUE; 18902 res_exp_desc->shape[i-1] = shape_opnd; 18903 } 18904 18905 res_exp_desc->type = arg_info_list[info_idx1].ed.type; 18906 res_exp_desc->linear_type = arg_info_list[info_idx1].ed.linear_type; 18907 res_exp_desc->type_idx = arg_info_list[info_idx1].ed.type_idx; 18908 18909 ATD_ARRAY_IDX(tmp_idx) = create_bd_ntry_for_const(res_exp_desc, 18910 IR_LINE_NUM(ir_idx), 18911 IR_COL_NUM(ir_idx)); 18912 18913 ATD_SAVED(tmp_idx) = TRUE; 18914 ATD_DATA_INIT(tmp_idx) = TRUE; 18915 ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 18916 ATD_FLD(tmp_idx) = CN_Tbl_Idx; 18917 ATD_TMP_IDX(tmp_idx) = the_cn_idx; 18918 ATD_TMP_INIT_NOT_DONE(tmp_idx) = TRUE; 18919 18920 OPND_IDX((*result_opnd)) = tmp_idx; 18921 OPND_FLD((*result_opnd)) = AT_Tbl_Idx; 18922 OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx); 18923 OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx); 18924 18925 if (insert_subs_ok) { 18926 if (res_exp_desc->rank) { 18927 ok = gen_whole_subscript(result_opnd, res_exp_desc); 18928 } 18929 else if (res_exp_desc->type == Character) { 18930 ok = gen_whole_substring(result_opnd, res_exp_desc->rank); 18931 } 18932 } 18933 18934 AT_REFERENCED(tmp_idx) = Referenced; 18935 AT_DEFINED(tmp_idx) = TRUE; 18936 18937 res_exp_desc->foldable = TRUE; 18938 res_exp_desc->tmp_reference = TRUE; 18939 } 18940 else if (! res_exp_desc->will_fold_later && optimize && 18941 optimize_reshape(result_opnd, res_exp_desc)) { 18942 ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE; 18943 } 18944 18945 /* #endif */ 18946 18947 IR_TYPE_IDX(ir_idx) = type_idx; 18948 IR_RANK(ir_idx) = res_exp_desc->rank; 18949 18950 if (res_exp_desc->type == Character) { 18951 res_exp_desc->char_len.fld = TYP_FLD(type_idx); 18952 res_exp_desc->char_len.idx = TYP_IDX(type_idx); 18953 } 18954 18955 /* res_exp_desc->foldable = FALSE; */ 18956 /* res_exp_desc->will_fold_later = FALSE; */ 18957 18958 TRACE (Func_Exit, "reshape_intrinsic", NULL); 18959 18960 } /* reshape_intrinsic */ 18961 18962 18963 /******************************************************************************\ 18964 |* *| 18965 |* Description: *| 18966 |* Function M@MX(X1, X2) intrinsic. *| 18967 |* *| 18968 |* Input parameters: *| 18969 |* NONE *| 18970 |* *| 18971 |* Output parameters: *| 18972 |* NONE *| 18973 |* *| 18974 |* Returns: *| 18975 |* NOTHING *| 18976 |* *| 18977 \******************************************************************************/ 18978 18979 void mmx_intrinsic(opnd_type *result_opnd, 18980 expr_arg_type *res_exp_desc, 18981 int *spec_idx) 18982 { 18983 int ir_idx; 18984 18985 18986 TRACE (Func_Entry, "mmx_intrinsic", NULL); 18987 18988 ir_idx = OPND_IDX((*result_opnd)); 18989 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 18990 18991 conform_check(0, 18992 ir_idx, 18993 res_exp_desc, 18994 spec_idx, 18995 FALSE); 18996 18997 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 18998 IR_RANK(ir_idx) = res_exp_desc->rank; 18999 19000 # if 0 /* April */ 19001 19002 IR_OPR(ir_idx) = Mmx_Opr; 19003 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 19004 IR_OPND_R(ir_idx) = null_opnd; 19005 19006 # endif 19007 19008 /* must reset foldable and will_fold_later because there is no */ 19009 /* folder for this intrinsic in constructors. */ 19010 19011 res_exp_desc->foldable = FALSE; 19012 res_exp_desc->will_fold_later = FALSE; 19013 19014 19015 TRACE (Func_Exit, "mmx_intrinsic", NULL); 19016 19017 } /* mmx_intrinsic */ 19018 19019 19020 /******************************************************************************\ 19021 |* *| 19022 |* Description: *| 19023 |* Function M@LDMX(X1, X2) intrinsic. *| 19024 |* *| 19025 |* Input parameters: *| 19026 |* NONE *| 19027 |* *| 19028 |* Output parameters: *| 19029 |* NONE *| 19030 |* *| 19031 |* Returns: *| 19032 |* NOTHING *| 19033 |* *| 19034 \******************************************************************************/ 19035 19036 void mldmx_intrinsic(opnd_type *result_opnd, 19037 expr_arg_type *res_exp_desc, 19038 int *spec_idx) 19039 { 19040 int ir_idx; 19041 19042 19043 TRACE (Func_Entry, "mldmx_intrinsic", NULL); 19044 19045 ir_idx = OPND_IDX((*result_opnd)); 19046 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 19047 19048 conform_check(0, 19049 ir_idx, 19050 res_exp_desc, 19051 spec_idx, 19052 FALSE); 19053 19054 19055 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 19056 IR_RANK(ir_idx) = res_exp_desc->rank; 19057 19058 # if 0 19059 19060 IR_OPR(ir_idx) = Mldmx_Opr; 19061 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 19062 IR_OPND_R(ir_idx) = null_opnd; 19063 19064 # endif 19065 19066 /* must reset foldable and will_fold_later because there is no */ 19067 /* folder for this intrinsic in constructors. */ 19068 19069 res_exp_desc->foldable = FALSE; 19070 res_exp_desc->will_fold_later = FALSE; 19071 19072 TRACE (Func_Exit, "mldmx_intrinsic", NULL); 19073 19074 } /* mldmx_intrinsic */ 19075 19076 19077 /******************************************************************************\ 19078 |* *| 19079 |* Description: *| 19080 |* Function M@LD(X1) intrinsic. *| 19081 |* *| 19082 |* Input parameters: *| 19083 |* NONE *| 19084 |* *| 19085 |* Output parameters: *| 19086 |* NONE *| 19087 |* *| 19088 |* Returns: *| 19089 |* NOTHING *| 19090 |* *| 19091 \******************************************************************************/ 19092 19093 void mld_intrinsic(opnd_type *result_opnd, 19094 expr_arg_type *res_exp_desc, 19095 int *spec_idx) 19096 { 19097 int ir_idx; 19098 19099 19100 TRACE (Func_Entry, "mld_intrinsic", NULL); 19101 19102 ir_idx = OPND_IDX((*result_opnd)); 19103 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 19104 19105 conform_check(0, 19106 ir_idx, 19107 res_exp_desc, 19108 spec_idx, 19109 FALSE); 19110 19111 19112 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 19113 IR_RANK(ir_idx) = res_exp_desc->rank; 19114 19115 # if 0 /* April */ 19116 19117 IR_OPR(ir_idx) = Mld_Opr; 19118 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 19119 IR_OPND_R(ir_idx) = null_opnd; 19120 19121 # endif 19122 19123 /* must reset foldable and will_fold_later because there is no */ 19124 /* folder for this intrinsic in constructors. */ 19125 19126 res_exp_desc->foldable = FALSE; 19127 res_exp_desc->will_fold_later = FALSE; 19128 19129 19130 TRACE (Func_Exit, "mld_intrinsic", NULL); 19131 19132 } /* mld_intrinsic */ 19133 19134 19135 /******************************************************************************\ 19136 |* *| 19137 |* Description: *| 19138 |* Function M@UL() intrinsic. *| 19139 |* *| 19140 |* Input parameters: *| 19141 |* NONE *| 19142 |* *| 19143 |* Output parameters: *| 19144 |* NONE *| 19145 |* *| 19146 |* Returns: *| 19147 |* NOTHING *| 19148 |* *| 19149 \******************************************************************************/ 19150 19151 void mul_intrinsic(opnd_type *result_opnd, 19152 expr_arg_type *res_exp_desc, 19153 int *spec_idx) 19154 { 19155 int ir_idx; 19156 19157 19158 TRACE (Func_Entry, "mul_intrinsic", NULL); 19159 19160 ir_idx = OPND_IDX((*result_opnd)); 19161 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 19162 19163 conform_check(0, 19164 ir_idx, 19165 res_exp_desc, 19166 spec_idx, 19167 FALSE); 19168 19169 19170 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 19171 IR_RANK(ir_idx) = res_exp_desc->rank; 19172 19173 # if 0 19174 19175 IR_OPR(ir_idx) = Mul_Opr; 19176 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 19177 IR_OPND_R(ir_idx) = null_opnd; 19178 19179 # endif 19180 19181 /* must reset foldable and will_fold_later because there is no */ 19182 /* folder for this intrinsic in constructors. */ 19183 19184 res_exp_desc->foldable = FALSE; 19185 res_exp_desc->will_fold_later = FALSE; 19186 19187 19188 TRACE (Func_Exit, "mul_intrinsic", NULL); 19189 19190 } /* mul_intrinsic */ 19191 19192 19193 /******************************************************************************\ 19194 |* *| 19195 |* Description: *| 19196 |* Function M@CLR() intrinsic. *| 19197 |* *| 19198 |* Input parameters: *| 19199 |* NONE *| 19200 |* *| 19201 |* Output parameters: *| 19202 |* NONE *| 19203 |* *| 19204 |* Returns: *| 19205 |* NOTHING *| 19206 |* *| 19207 \******************************************************************************/ 19208 19209 void mclr_intrinsic(opnd_type *result_opnd, 19210 expr_arg_type *res_exp_desc, 19211 int *spec_idx) 19212 { 19213 int ir_idx; 19214 19215 19216 TRACE (Func_Entry, "mclr_intrinsic", NULL); 19217 19218 ir_idx = OPND_IDX((*result_opnd)); 19219 ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE; 19220 19221 conform_check(0, 19222 ir_idx, 19223 res_exp_desc, 19224 spec_idx, 19225 FALSE); 19226 19227 IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)); 19228 IR_RANK(ir_idx) = res_exp_desc->rank; 19229 19230 # if 0 19231 19232 IR_OPR(ir_idx) = Mcbl_Opr; 19233 COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx)); 19234 IR_OPND_R(ir_idx) = null_opnd; 19235 19236 # endif 19237 19238 /* must reset foldable and will_fold_later because there is no */ 19239 /* folder for this intrinsic in constructors. */ 19240 19241 res_exp_desc->foldable = FALSE; 19242 res_exp_desc->will_fold_later = FALSE; 19243 19244 TRACE (Func_Exit, "mclr_intrinsic", NULL); 19245 19246 } /* mclr_intrinsic */ 19247 19248 19249 /******************************************************************************\ 19250 |* *| 19251 |* Description: *| 19252 |* Issue an error if this ever gets called. There is a problem with *| 19253 |* intrinsic processing. ATP_INTRIN_ENUM is bad. *| 19254 |* *| 19255 |* Input parameters: *| 19256 |* NONE *| 19257 |* *| 19258 |* Output parameters: *| 19259 |* NONE *| 19260 |* *| 19261 |* Returns: *| 19262 |* NOTHING *| 19263 |* *| 19264 \******************************************************************************/ 19265 19266 void unknown_intrinsic(opnd_type *result_opnd, 19267 expr_arg_type *res_exp_desc, 19268 int *spec_idx) 19269 { 19270 TRACE (Func_Entry, "unknown_intrinsic", NULL); 19271 19272 PRINTMSG(stmt_start_line, 937, Internal, stmt_start_col); 19273 19274 TRACE (Func_Exit, "unknown_intrinsic", NULL); 19275 19276 } /* unknown_intrinsic */
1.7.6.1 
