|
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/fold_drive.c 5.19 10/14/99 14:09:57\n"; 00038 00039 # include <stdarg.h> 00040 # include "defines.h" /* Machine dependent ifdefs */ 00041 # include "host.m" /* Host machine dependent macros.*/ 00042 # include "host.h" /* Host machine dependent header.*/ 00043 # include "target.m" /* Target machine dependent macros.*/ 00044 # include "target.h" /* Target machine dependent header.*/ 00045 # include "globals.m" 00046 # include "tokens.m" 00047 # include "sytb.m" 00048 # include "s_globals.m" 00049 # include "debug.m" 00050 # include "fold_drive.m" 00051 # include "globals.h" 00052 # include "tokens.h" 00053 # include "sytb.h" 00054 # include "s_globals.h" 00055 # include "fmath.h" 00056 # include "arith.h" 00057 # include "fold_drive.h" 00058 00059 /* This function has Fortran linkage. */ 00060 #if defined(__GNUC__) && defined(__alpha) 00061 /* GCC alpha is different for some reason... */ 00062 # define FOLD_OPERATION fold_operation__ 00063 #else 00064 # define FOLD_OPERATION fold_operation_ 00065 #endif 00066 00067 00068 /******************************************************************************\ 00069 |* *| 00070 |* Description: *| 00071 |* Compare a constant table entry with a "c" long value according to *| 00072 |* the relational operator "opr". *| 00073 |* NOTE: This does not handle values bigger than a long on the host *| 00074 |* machine. Call folder_driver directly for that. *| 00075 |* *| 00076 |* Input parameters: *| 00077 |* NONE *| 00078 |* *| 00079 |* Output parameters: *| 00080 |* NONE *| 00081 |* *| 00082 |* Returns: *| 00083 |* NOTHING *| 00084 |* *| 00085 \******************************************************************************/ 00086 boolean compare_cn_and_value(int cn_idx, 00087 #if defined(_HOST32) && defined(_TARGET64) 00088 long long value, 00089 #else 00090 long value, 00091 #endif 00092 int opr) 00093 00094 { 00095 long_type result[MAX_WORDS_FOR_NUMERIC]; 00096 long_type right_value[MAX_WORDS_FOR_NUMERIC]; 00097 boolean is_true = FALSE; 00098 int type_idx; 00099 00100 00101 TRACE (Func_Entry,"compare_cn_and_value" , NULL); 00102 00103 C_TO_F_INT(right_value, value, CG_INTEGER_DEFAULT_TYPE); 00104 00105 type_idx = CG_LOGICAL_DEFAULT_TYPE; 00106 00107 if (folder_driver((char *)&CN_CONST(cn_idx), 00108 CN_TYPE_IDX(cn_idx), 00109 (char *)&right_value, 00110 # ifdef _WHIRL_HOST64_TARGET64 00111 Integer_8, 00112 # else 00113 CG_INTEGER_DEFAULT_TYPE, 00114 # endif /* _WHIRL_HOST64_TARGET64 */ 00115 result, 00116 &type_idx, 00117 stmt_start_line, 00118 stmt_start_col, 00119 2, 00120 opr)) { 00121 00122 if (THIS_IS_TRUE(result, type_idx)) { 00123 is_true = TRUE; 00124 } 00125 } 00126 00127 TRACE (Func_Exit, "compare_cn_and_value", NULL); 00128 00129 return(is_true); 00130 00131 } /* compare_cn_and_value */ 00132 00133 00134 /******************************************************************************\ 00135 |* *| 00136 |* Description: *| 00137 |* This routine compares two character strings according to the f90 rules*| 00138 |* *| 00139 |* Input parameters: *| 00140 |* NONE *| 00141 |* *| 00142 |* Output parameters: *| 00143 |* NONE *| 00144 |* *| 00145 |* Returns: *| 00146 |* returns the TRUE_VALUE or FALSE_VALUE depending on the result of *| 00147 |* the compare and the operation requested. *| 00148 |* *| 00149 \******************************************************************************/ 00150 static void f90_character_compare(char *ch_ptr1, 00151 long64 len1, 00152 char *ch_ptr2, 00153 long64 len2, 00154 int opr, 00155 long_type *result, 00156 int type_idx) 00157 00158 { 00159 char char1; 00160 char char2; 00161 int comp_result = 0; 00162 long64 i; 00163 00164 00165 TRACE (Func_Entry, "f90_character_compare", NULL); 00166 00167 set_up_logical_constant(result, type_idx, FALSE_VALUE, FALSE); 00168 00169 for (i = 0; i < (len1 > len2 ? len1 : len2); i++) { 00170 00171 if (i < len1) { 00172 char1 = ch_ptr1[i]; 00173 } 00174 else { 00175 char1 = ' '; 00176 } 00177 00178 if (i < len2) { 00179 char2 = ch_ptr2[i]; 00180 } 00181 else { 00182 char2 = ' '; 00183 } 00184 00185 if (char1 == char2) { 00186 /* intentionally blank */ 00187 } 00188 else if (char1 < char2) { 00189 comp_result = -1; 00190 break; 00191 } 00192 else if (char1 > char2) { 00193 comp_result = 1; 00194 break; 00195 } 00196 } 00197 00198 00199 switch (opr) { 00200 case Eq_Opr : 00201 00202 if (comp_result == 0) { 00203 set_up_logical_constant(result, type_idx, TRUE_VALUE, FALSE); 00204 } 00205 break; 00206 00207 case Ne_Opr : 00208 00209 if (comp_result != 0) { 00210 set_up_logical_constant(result, type_idx, TRUE_VALUE, FALSE); 00211 } 00212 break; 00213 00214 case Lt_Opr : 00215 00216 if (comp_result < 0) { 00217 set_up_logical_constant(result, type_idx, TRUE_VALUE, FALSE); 00218 } 00219 break; 00220 00221 case Le_Opr : 00222 00223 if (comp_result <= 0) { 00224 set_up_logical_constant(result, type_idx, TRUE_VALUE, FALSE); 00225 } 00226 break; 00227 00228 case Gt_Opr : 00229 00230 if (comp_result > 0) { 00231 set_up_logical_constant(result, type_idx, TRUE_VALUE, FALSE); 00232 } 00233 break; 00234 00235 case Ge_Opr : 00236 00237 if (comp_result >= 0) { 00238 set_up_logical_constant(result, type_idx, TRUE_VALUE, FALSE); 00239 } 00240 break; 00241 00242 } 00243 00244 TRACE (Func_Exit, "f90_character_compare", NULL); 00245 00246 return; 00247 00248 } /* f90_character_compare */ 00249 00250 00251 /******************************************************************************\ 00252 |* *| 00253 |* Description: *| 00254 |* <description> *| 00255 |* *| 00256 |* Input parameters: *| 00257 |* NONE *| 00258 |* *| 00259 |* Output parameters: *| 00260 |* NONE *| 00261 |* *| 00262 |* Returns: *| 00263 |* NOTHING *| 00264 |* *| 00265 \******************************************************************************/ 00266 boolean folder_driver(char *l_value_ptr, 00267 int l_type_idx, 00268 char *r_value_ptr, 00269 int r_type_idx, 00270 long_type *result, 00271 int *res_type_idx, 00272 int line, 00273 int col, 00274 int num_args, 00275 int opr, 00276 ...) 00277 00278 { 00279 struct value_entry { long_type v[MAX_WORDS_FOR_NUMERIC]; }; 00280 00281 typedef struct value_entry value_type; 00282 00283 struct big_value_entry { long_type v[2000]; }; 00284 00285 typedef struct big_value_entry big_value_type; 00286 00287 boolean ok = TRUE; 00288 long64 count; 00289 big_value_type l_value; 00290 value_type r_value; 00291 value_type a3_value; 00292 value_type a4_value; 00293 value_type str_len1; 00294 value_type str_len2; 00295 big_value_type loc_result; 00296 long64 i; 00297 int j; 00298 int k; 00299 int cn_idx; 00300 int cn_idx1; 00301 int cn_idx2; 00302 long64 length; 00303 long64 length_o; 00304 long64 length_d; 00305 linear_type_type l_linear_type; 00306 linear_type_type r_linear_type; 00307 linear_type_type a3_linear_type; 00308 linear_type_type a4_linear_type; 00309 linear_type_type res_linear_type; 00310 linear_type_type str1_linear_type; 00311 linear_type_type str2_linear_type; 00312 long_type mask; 00313 char *a3_value_ptr; 00314 int a3_type_idx; 00315 char *a4_value_ptr; 00316 int a4_type_idx; 00317 va_list arg_ptr; 00318 char char_buf[8000]; 00319 int type_idx; 00320 int char_idx; 00321 int tmp_opr; 00322 char *char_ptr; 00323 long arith_type; 00324 long arith_type_l; 00325 AR_COMPARE_TYPE comp_res; 00326 long64 char_len; 00327 00328 00329 TRACE (Func_Entry, "folder_driver", NULL); 00330 00331 if (l_type_idx != NULL_IDX) { 00332 l_linear_type = TYP_LINEAR(l_type_idx); 00333 } 00334 00335 res_linear_type = TYP_LINEAR(*res_type_idx); 00336 00337 if (num_args > 1 && r_type_idx != NULL_IDX) { 00338 r_linear_type = TYP_LINEAR(r_type_idx); 00339 } 00340 00341 if (num_args > 2) { 00342 va_start (arg_ptr, opr); 00343 a3_value_ptr = va_arg(arg_ptr, char *); 00344 a3_type_idx = va_arg(arg_ptr, long); 00345 a4_value_ptr = va_arg(arg_ptr, char *); 00346 a4_type_idx = va_arg(arg_ptr, long); 00347 va_end(arg_ptr); 00348 00349 if (a3_type_idx != NULL_IDX) { 00350 a3_linear_type = TYP_LINEAR(a3_type_idx); 00351 } 00352 00353 if (num_args == 4 && 00354 a4_type_idx != NULL_IDX) { 00355 00356 a4_linear_type = TYP_LINEAR(a4_type_idx); 00357 } 00358 } 00359 00360 if ((opr == SRK_Opr) || 00361 (opr == Transfer_Opr) || 00362 (opr == Reshape_Opr)) { 00363 goto CONTINUE; 00364 } 00365 00366 /* copy arguments to local variables so that addresses of */ 00367 /* constant tbl entries can be sent. */ 00368 00369 if (TYP_TYPE(l_type_idx) == Typeless) { 00370 for (i = 0; 00371 i < ((TYP_BIT_LEN(l_type_idx) + TARGET_BITS_PER_WORD - 1)/ 00372 TARGET_BITS_PER_WORD); 00373 i++) { 00374 l_value.v[i] = ((long_type *)l_value_ptr)[i]; 00375 } 00376 } 00377 else if (TYP_TYPE(l_type_idx) != Character) { 00378 for (i = 0; i < num_host_wds[TYP_LINEAR(l_type_idx)]; i++) { 00379 l_value.v[i] = ((long_type *)l_value_ptr)[i]; 00380 } 00381 00382 # ifdef _TARGET_OS_MAX 00383 if (l_linear_type == Complex_4) { 00384 /* we need to pack it up into one word */ 00385 l_value.v[0] = l_value.v[0] << 32; 00386 l_value.v[0] = l_value.v[0] | (l_value.v[1] & 0xFFFFFFFF); 00387 } 00388 # endif 00389 } 00390 else { /* processing character data */ 00391 char_ptr = (char *)l_value.v; 00392 l_value.v[0] = 0; 00393 00394 for (i = 0; i < CN_INT_TO_C(TYP_IDX(l_type_idx)); i++) { 00395 char_ptr[i] = l_value_ptr[i]; 00396 } 00397 00398 for ( ; i < TARGET_BYTES_PER_WORD; i++) { 00399 char_ptr[i] = ' '; 00400 } 00401 } 00402 00403 if (num_args > 1) { 00404 00405 if (TYP_TYPE(r_type_idx) == Typeless) { 00406 00407 for (i = 0; 00408 i < ((TYP_BIT_LEN(r_type_idx) + TARGET_BITS_PER_WORD - 1)/ 00409 TARGET_BITS_PER_WORD); 00410 i++) { 00411 00412 r_value.v[i] = ((long_type *)r_value_ptr)[i]; 00413 } 00414 } 00415 else if (TYP_TYPE(r_type_idx) != Character) { 00416 00417 for (i = 0; i < num_host_wds[TYP_LINEAR(r_type_idx)]; i++) { 00418 r_value.v[i] = ((long_type *)r_value_ptr)[i]; 00419 } 00420 00421 # ifdef _TARGET_OS_MAX 00422 if (r_linear_type == Complex_4) { 00423 /* we need to pack it up into one word */ 00424 r_value.v[0] = r_value.v[0] << 32; 00425 r_value.v[0] = r_value.v[0] | (r_value.v[1] & 0xFFFFFFFF); 00426 } 00427 # endif 00428 } 00429 else { 00430 char_ptr = (char *)r_value.v; 00431 r_value.v[0] = 0; 00432 00433 for (i = 0; i < CN_INT_TO_C(TYP_IDX(r_type_idx)) && 00434 i < TARGET_BYTES_PER_WORD; 00435 i++) { 00436 char_ptr[i] = r_value_ptr[i]; 00437 } 00438 00439 for ( ; i < TARGET_BYTES_PER_WORD; i++) { 00440 char_ptr[i] = ' '; 00441 } 00442 } 00443 } 00444 00445 if (num_args > 2) { 00446 00447 if (TYP_TYPE(a3_type_idx) == Typeless) { 00448 00449 for (i = 0; 00450 i < ((TYP_BIT_LEN(a3_type_idx) + TARGET_BITS_PER_WORD - 1)/ 00451 TARGET_BITS_PER_WORD); 00452 i++) { 00453 00454 a3_value.v[i] = ((long_type *)a3_value_ptr)[i]; 00455 } 00456 } 00457 else if (TYP_TYPE(a3_type_idx) != Character) { 00458 00459 for (i = 0; i < num_host_wds[a3_linear_type]; i++) { 00460 a3_value.v[i] = ((long_type *)a3_value_ptr)[i]; 00461 } 00462 00463 # ifdef _TARGET_OS_MAX 00464 if (a3_linear_type == Complex_4) { 00465 /* we need to pack it up into one word */ 00466 a3_value.v[0] = a3_value.v[0] << 32; 00467 a3_value.v[0] = a3_value.v[0] | (a3_value.v[1] & 0xFFFFFFFF); 00468 } 00469 # endif 00470 } 00471 else { 00472 char_ptr = (char *)a3_value.v; 00473 a3_value.v[0] = 0; 00474 00475 for (i = 0; i < CN_INT_TO_C(TYP_IDX(a3_type_idx)) && 00476 i < TARGET_BYTES_PER_WORD; 00477 i++) { 00478 char_ptr[i] = a3_value_ptr[i]; 00479 } 00480 00481 for ( ; i < TARGET_BYTES_PER_WORD; i++) { 00482 char_ptr[i] = ' '; 00483 } 00484 } 00485 } 00486 00487 if (num_args > 3) { 00488 00489 if (TYP_TYPE(a4_type_idx) == Typeless) { 00490 00491 for (i = 0; 00492 i < ((TYP_BIT_LEN(a4_type_idx) + TARGET_BITS_PER_WORD - 1)/ 00493 TARGET_BITS_PER_WORD); 00494 i++) { 00495 00496 a4_value.v[i] = ((long_type *)a4_value_ptr)[i]; 00497 } 00498 } 00499 else if (TYP_TYPE(a4_type_idx) != Character) { 00500 00501 for (i = 0; i < num_host_wds[a4_linear_type]; i++) { 00502 a4_value.v[i] = ((long_type *)a4_value_ptr)[i]; 00503 } 00504 00505 # ifdef _TARGET_OS_MAX 00506 if (a4_linear_type == Complex_4) { 00507 /* we need to pack it up into one word */ 00508 a4_value.v[0] = a4_value.v[0] << 32; 00509 a4_value.v[0] = a4_value.v[0] | (a4_value.v[1] & 0xFFFFFFFF); 00510 } 00511 # endif 00512 } 00513 else { 00514 char_ptr = (char *)a4_value.v; 00515 a4_value.v[0] = 0; 00516 00517 for (i = 0; i < CN_INT_TO_C(TYP_IDX(a4_type_idx)) && 00518 i < TARGET_BYTES_PER_WORD; 00519 i++) { 00520 char_ptr[i] = a4_value_ptr[i]; 00521 } 00522 00523 for ( ; i < TARGET_BYTES_PER_WORD; i++) { 00524 char_ptr[i] = ' '; 00525 } 00526 } 00527 } 00528 00529 00530 CONTINUE: 00531 00532 switch (opr) { 00533 case Reshape_Opr : 00534 mask = AR_reshape((void *)result, 00535 (const void *)l_value_ptr, 00536 (const void *)r_value_ptr, 00537 (const void *)a3_value_ptr, 00538 (const void *)a4_value_ptr); 00539 00540 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 00541 00542 goto EXIT; /* goto exit because this returns a dope vector. */ 00543 00544 00545 case Transfer_Opr : 00546 if (a3_value_ptr != NULL) { 00547 for (i = 0; i < num_host_wds[a3_linear_type]; i++) { 00548 a3_value.v[i] = ((long_type *)a3_value_ptr)[i]; 00549 } 00550 SHIFT_ARITH_ARG(a3_value.v, a3_linear_type); 00551 00552 mask = AR_transfer((void *)result, 00553 (const void *)l_value_ptr, 00554 (const void *)r_value_ptr, 00555 (const AR_DATA *)a3_value.v, 00556 (const AR_TYPE *)&linear_to_arith[a3_linear_type]); 00557 } 00558 else { 00559 mask = AR_transfer((void *)result, 00560 (const void *)l_value_ptr, 00561 (const void *)r_value_ptr, 00562 (const AR_DATA *)a3_value_ptr, 00563 (const AR_TYPE *)&linear_to_arith[INTEGER_DEFAULT_TYPE]); 00564 } 00565 00566 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 00567 00568 goto EXIT; /* goto exit because this returns a dope vector. */ 00569 00570 00571 case Trim_Opr : 00572 /* Do this inline */ 00573 /* return a cn table index in result[0] */ 00574 00575 i = CN_INT_TO_C(TYP_IDX(l_type_idx)); 00576 while (i > 0 && l_value_ptr[i-1] == ' ') { 00577 i--; 00578 } 00579 00580 char_len = i; 00581 00582 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 00583 TYP_TYPE(TYP_WORK_IDX) = Character; 00584 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 00585 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 00586 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 00587 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(NULL_IDX, char_len); 00588 *res_type_idx = ntr_type_tbl(); 00589 00590 result[0] = ntr_const_tbl((*res_type_idx), TRUE, NULL); 00591 char_ptr = (char *) &CN_CONST(result[0]); 00592 00593 for (i = 0; i < char_len; i++) { 00594 char_ptr[i] = l_value_ptr[i]; 00595 } 00596 00597 break; 00598 00599 00600 case Repeat_Opr : 00601 00602 /* do this inline. */ 00603 00604 /* JEFFL BRIANJ - Do changes need to be made here? */ 00605 00606 length = CP_CONSTANT(CN_POOL_IDX(TYP_IDX(l_type_idx)) + 00607 num_host_wds[TYP_LINEAR(CN_TYPE_IDX(TYP_IDX(l_type_idx)))] - 1); 00608 00609 count = r_value.v[num_host_wds[r_linear_type] - 1]; 00610 00611 length = length * count; 00612 00613 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 00614 TYP_TYPE(TYP_WORK_IDX) = Character; 00615 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 00616 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 00617 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 00618 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, length), 00619 *res_type_idx = ntr_type_tbl(); 00620 00621 result[0] = ntr_const_tbl((*res_type_idx), TRUE, NULL); 00622 char_ptr = (char *) &CN_CONST(result[0]); 00623 00624 length = CP_CONSTANT(CN_POOL_IDX(TYP_IDX(l_type_idx)) + 00625 num_host_wds[TYP_LINEAR(CN_TYPE_IDX(TYP_IDX(l_type_idx)))] - 1); 00626 00627 char_idx = 0; 00628 for (k = 0; k < count; k++) { 00629 for (i = 0; i < length; i++) { 00630 char_ptr[char_idx] = l_value_ptr[i]; 00631 char_idx++; 00632 } 00633 } 00634 break; 00635 00636 00637 case SRK_Opr : 00638 00639 if (l_value_ptr!=NULL) 00640 for (i = 0; i < num_host_wds[l_linear_type]; i++) { 00641 l_value.v[i] = ((long_type *)l_value_ptr)[i]; 00642 } 00643 00644 if (r_value_ptr!=NULL) 00645 for (i = 0; i < num_host_wds[r_linear_type]; i++) { 00646 r_value.v[i] = ((long_type *)r_value_ptr)[i]; 00647 } 00648 00649 00650 if (l_value_ptr!=NULL && r_value_ptr!=NULL) { 00651 cn_idx1 = ntr_const_tbl(l_type_idx, FALSE, &l_value.v[0]); 00652 cn_idx2 = ntr_const_tbl(r_type_idx, FALSE, &r_value.v[0]); 00653 if (compare_cn_and_value(cn_idx1,PRECISION_REAL4_F90,Le_Opr)) { 00654 if (compare_cn_and_value(cn_idx2,RANGE_REAL4_F90,Le_Opr)) { 00655 i=4; 00656 } 00657 else if (compare_cn_and_value(cn_idx2,RANGE_REAL8_F90,Le_Opr)) { 00658 i=8; 00659 } 00660 else { 00661 i=-2; 00662 } 00663 } 00664 else if (compare_cn_and_value(cn_idx1,PRECISION_REAL8_F90,Le_Opr)) { 00665 if (compare_cn_and_value(cn_idx2,RANGE_REAL8_F90,Le_Opr)) { 00666 i=8; 00667 } else { 00668 i=-2; 00669 } 00670 } 00671 else if (compare_cn_and_value(cn_idx1,PRECISION_REAL16_F90,Le_Opr)) { 00672 if (compare_cn_and_value(cn_idx2,RANGE_REAL16_F90,Le_Opr)) { 00673 i=16; 00674 } else { 00675 i=-2; 00676 } 00677 } 00678 else if(compare_cn_and_value(cn_idx2,RANGE_REAL8_F90,Le_Opr)) { 00679 i=-1; 00680 } else { 00681 i=-3; 00682 } 00683 } 00684 00685 00686 if (l_value_ptr!=NULL && r_value_ptr==NULL) { 00687 cn_idx1 = ntr_const_tbl(l_type_idx, FALSE, &l_value.v[0]); 00688 if (compare_cn_and_value(cn_idx1,PRECISION_REAL4_F90,Le_Opr)) { 00689 i=4; 00690 } else 00691 if (compare_cn_and_value(cn_idx1,PRECISION_REAL8_F90,Le_Opr)) { 00692 i=8; 00693 } else 00694 if (compare_cn_and_value(cn_idx1,PRECISION_REAL16_F90,Le_Opr)) { 00695 i=16; 00696 } else 00697 i=-1; 00698 } 00699 00700 if (l_value_ptr==NULL && r_value_ptr!=NULL) { 00701 cn_idx2 = ntr_const_tbl(r_type_idx, FALSE, &r_value.v[0]); 00702 if (compare_cn_and_value(cn_idx2,RANGE_REAL4_F90,Le_Opr)) { 00703 i=4; } 00704 else 00705 if (compare_cn_and_value(cn_idx2,RANGE_REAL8_F90,Le_Opr)) { 00706 i=8; } 00707 else 00708 i=-2; 00709 } 00710 00711 C_TO_F_INT(result, i, res_linear_type); 00712 00713 00714 if (FALSE) { 00715 00716 00717 00718 if (r_value_ptr == NULL) { 00719 00720 for (i = 0; i < num_host_wds[l_linear_type]; i++) { 00721 l_value.v[i] = ((long_type *)l_value_ptr)[i]; 00722 } 00723 00724 if (l_linear_type != res_linear_type) { 00725 SHIFT_ARITH_ARG(l_value.v, l_linear_type); 00726 00727 # if defined(_USE_FOLD_DOT_f) 00728 tmp_opr = Cvrt_Opr; 00729 FOLD_OPERATION( 00730 &tmp_opr, 00731 &loc_result.v, 00732 &res_linear_type, 00733 &l_value.v, 00734 &l_linear_type, 00735 &r_value.v, 00736 &r_linear_type, 00737 &a3_value.v, 00738 &a3_linear_type); 00739 # else 00740 mask = AR_convert((AR_DATA *)loc_result.v, 00741 (const AR_TYPE *)&linear_to_arith[res_linear_type], 00742 (const AR_DATA *)l_value.v, 00743 (const AR_TYPE *)&linear_to_arith[l_linear_type]); 00744 # endif 00745 00746 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 00747 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 00748 00749 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 00750 l_value.v[i] = loc_result.v[i]; 00751 } 00752 } 00753 00754 r_linear_type = Err_Res; 00755 00756 /* SHIFT_ARITH_ARG(l_value.v, res_linear_type); */ 00757 00758 /* SELECTED_REAL_KIND instrinc function implementation in fold.f 00759 * is removed because Linux doesn't have F90 compiler, use AR_xxx 00760 * implemenation in arith.a instead! 00761 */ 00762 # if 0 00763 FOLD_OPERATION( 00764 &opr, 00765 &loc_result.v, 00766 &res_linear_type, 00767 &l_value.v, 00768 &l_linear_type, 00769 &r_value.v, 00770 &r_linear_type, 00771 &a3_value.v, 00772 &a3_linear_type); 00773 # else 00774 mask = AR_selected_real_kind((AR_DATA *)loc_result.v, 00775 (const AR_TYPE *)&linear_to_arith[res_linear_type], 00776 (const AR_DATA *)l_value.v, 00777 (const AR_TYPE *)&linear_to_arith[res_linear_type], 00778 (const AR_DATA *)NULL, 00779 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 00780 # endif 00781 00782 } 00783 else if (l_value_ptr == NULL) { 00784 for (i = 0; i < num_host_wds[r_linear_type]; i++) { 00785 r_value.v[i] = ((long_type *)r_value_ptr)[i]; 00786 ((long_type *)r_value_ptr)[i]=r_value.v[i]; /* fff */ 00787 } 00788 00789 if (r_linear_type != res_linear_type) { 00790 SHIFT_ARITH_ARG(r_value.v, r_linear_type); 00791 00792 # if defined(_USE_FOLD_DOT_f) 00793 tmp_opr = Cvrt_Opr; 00794 FOLD_OPERATION( 00795 &tmp_opr, 00796 &loc_result.v, 00797 &res_linear_type, 00798 &r_value.v, 00799 &r_linear_type, 00800 &r_value.v, 00801 &r_linear_type, 00802 &a3_value.v, 00803 &a3_linear_type); 00804 # else 00805 mask = AR_convert((AR_DATA *)loc_result.v, 00806 (const AR_TYPE *)&linear_to_arith[res_linear_type], 00807 (const AR_DATA *)r_value.v, 00808 (const AR_TYPE *)&linear_to_arith[r_linear_type]); 00809 # endif 00810 00811 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 00812 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 00813 00814 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 00815 r_value.v[i] = loc_result.v[i]; 00816 } 00817 } 00818 00819 l_linear_type = Err_Res; 00820 00821 /* fff SHIFT_ARITH_ARG(r_value.v, res_linear_type); */ 00822 00823 /* SELECTED_REAL_KIND instrinc function implementation in fold.f 00824 * is removed because Linux doesn't have F90 compiler, use AR_xxx 00825 * implemenation in arith.a instead! 00826 */ 00827 # if 0 00828 FOLD_OPERATION( 00829 &opr, 00830 &loc_result.v, 00831 &res_linear_type, 00832 &l_value.v, 00833 &l_linear_type, 00834 &r_value.v, 00835 &r_linear_type, 00836 &a3_value.v, 00837 &a3_linear_type); 00838 # else 00839 mask = AR_selected_real_kind((AR_DATA *)loc_result.v, 00840 (const AR_TYPE *)&linear_to_arith[res_linear_type], 00841 (const AR_DATA *)NULL, 00842 (const AR_TYPE *)&linear_to_arith[res_linear_type], 00843 (const AR_DATA *)r_value.v, 00844 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 00845 # endif 00846 } 00847 else { 00848 00849 for (i = 0; i < num_host_wds[l_linear_type]; i++) { 00850 l_value.v[i] = ((long_type *)l_value_ptr)[i]; 00851 } 00852 00853 if (l_linear_type != res_linear_type) { 00854 /* fff SHIFT_ARITH_ARG(l_value.v, l_linear_type); */ 00855 00856 # if defined(_USE_FOLD_DOT_f) 00857 tmp_opr = Cvrt_Opr; 00858 FOLD_OPERATION( 00859 &tmp_opr, 00860 &loc_result.v, 00861 &res_linear_type, 00862 &l_value.v, 00863 &l_linear_type, 00864 &r_value.v, 00865 &r_linear_type, 00866 &a3_value.v, 00867 &a3_linear_type); 00868 # else 00869 mask = AR_convert((AR_DATA *)loc_result.v, 00870 (const AR_TYPE *)&linear_to_arith[res_linear_type], 00871 (const AR_DATA *)l_value.v, 00872 (const AR_TYPE *)&linear_to_arith[l_linear_type]); 00873 # endif 00874 00875 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 00876 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 00877 00878 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 00879 l_value.v[i] = loc_result.v[i]; 00880 } 00881 } 00882 00883 /* fff SHIFT_ARITH_ARG(l_value.v, res_linear_type); */ 00884 00885 for (i = 0; i < num_host_wds[r_linear_type]; i++) { 00886 r_value.v[i] = ((long_type *)r_value_ptr)[i]; 00887 } 00888 00889 if (r_linear_type != res_linear_type) { 00890 /* SHIFT_ARITH_ARG(r_value.v, r_linear_type); */ 00891 00892 # if defined(_USE_FOLD_DOT_f) 00893 tmp_opr = Cvrt_Opr; 00894 FOLD_OPERATION( 00895 &tmp_opr, 00896 &loc_result.v, 00897 &res_linear_type, 00898 &r_value.v, 00899 &r_linear_type, 00900 &r_value.v, 00901 &r_linear_type, 00902 &a3_value.v, 00903 &a3_linear_type); 00904 # else 00905 mask = AR_convert((AR_DATA *)loc_result.v, 00906 (const AR_TYPE *)&linear_to_arith[res_linear_type], 00907 (const AR_DATA *)r_value.v, 00908 (const AR_TYPE *)&linear_to_arith[r_linear_type]); 00909 # endif 00910 00911 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 00912 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 00913 00914 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 00915 r_value.v[i] = loc_result.v[i]; 00916 } 00917 } 00918 00919 /* SHIFT_ARITH_ARG(r_value.v, res_linear_type); */ 00920 00921 /* SELECTED_REAL_KIND instrinc function implementation in fold.f 00922 * is removed because Linux doesn't have F90 compiler, use AR_xxx 00923 * implemenation in arith.a instead! 00924 */ 00925 # if 0 00926 FOLD_OPERATION( 00927 &opr, 00928 &loc_result.v, 00929 &res_linear_type, 00930 &l_value.v, 00931 &l_linear_type, 00932 &r_value.v, 00933 &r_linear_type, 00934 &a3_value.v, 00935 &a3_linear_type); 00936 # else 00937 mask = AR_selected_real_kind((AR_DATA *)loc_result.v, 00938 (const AR_TYPE *)&linear_to_arith[res_linear_type], 00939 (const AR_DATA *)l_value.v, 00940 (const AR_TYPE *)&linear_to_arith[res_linear_type], 00941 (const AR_DATA *)r_value.v, 00942 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 00943 # endif 00944 } 00945 00946 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 00947 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 00948 00949 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 00950 result[i] = loc_result.v[i]; 00951 } 00952 } 00953 00954 break; 00955 00956 00957 case SIK_Opr : 00958 cn_idx = ntr_const_tbl(l_type_idx, FALSE, &l_value.v[0]); 00959 00960 if (compare_cn_and_value(cn_idx, RANGE_INT1_F90, Le_Opr)) { 00961 i = 1; 00962 } 00963 else if (compare_cn_and_value(cn_idx, RANGE_INT2_F90, Le_Opr)) { 00964 i = 2; 00965 } 00966 else if (compare_cn_and_value(cn_idx, RANGE_INT4_F90, Le_Opr)) { 00967 i = 4; 00968 } 00969 else if (compare_cn_and_value(cn_idx, RANGE_INT8_F90, Le_Opr)) { 00970 i = 8; 00971 } 00972 else { 00973 i = -1; 00974 } 00975 00976 C_TO_F_INT(result, i, res_linear_type); 00977 00978 break; 00979 00980 00981 case Uminus_Opr : 00982 if (l_linear_type != res_linear_type && 00983 TYP_TYPE(l_type_idx) != Typeless) { 00984 00985 SHIFT_ARITH_ARG(l_value.v, l_linear_type); 00986 00987 # if defined(_USE_FOLD_DOT_f) 00988 tmp_opr = Cvrt_Opr; 00989 FOLD_OPERATION( 00990 &tmp_opr, 00991 &loc_result.v, 00992 &res_linear_type, 00993 &l_value.v, 00994 &l_linear_type, 00995 &r_value.v, 00996 &r_linear_type, 00997 &a3_value.v, 00998 &a3_linear_type); 00999 # else 01000 mask = AR_convert((AR_DATA *)loc_result.v, 01001 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01002 (const AR_DATA *)l_value.v, 01003 (const AR_TYPE *)&linear_to_arith[l_linear_type]); 01004 # endif 01005 01006 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01007 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01008 01009 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01010 l_value.v[i] = loc_result.v[i]; 01011 } 01012 } 01013 01014 SHIFT_ARITH_ARG(l_value.v, res_linear_type); 01015 01016 # if defined(_USE_FOLD_DOT_f) 01017 FOLD_OPERATION( 01018 &opr, 01019 &loc_result.v, 01020 &res_linear_type, 01021 &l_value.v, 01022 &res_linear_type, 01023 &r_value.v, 01024 &res_linear_type, 01025 &a3_value.v, 01026 &a3_linear_type); 01027 # else 01028 mask = AR_negate((AR_DATA *)loc_result.v, 01029 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01030 (const AR_DATA *)l_value.v, 01031 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01032 # endif 01033 01034 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01035 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01036 01037 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01038 result[i] = loc_result.v[i]; 01039 } 01040 break; 01041 01042 01043 case Cvrt_Opr : 01044 case Int_Opr : 01045 if (TYP_TYPE(l_type_idx) == Character) { /* source */ 01046 length_o = CN_INT_TO_C(TYP_IDX(l_type_idx)); 01047 01048 if (TYP_TYPE((*res_type_idx)) == Character) { /* destination */ 01049 length_d = CN_INT_TO_C(TYP_IDX((*res_type_idx))); 01050 } 01051 else { 01052 length_d = num_host_wds[TYP_LINEAR((*res_type_idx))] * 01053 TARGET_CHARS_PER_WORD; 01054 } 01055 01056 char_ptr = (char *) result; 01057 l_value_ptr = (char *) &l_value.v; 01058 01059 for (i = 0; i < length_o; i++) { 01060 char_ptr[i] = l_value_ptr[i]; 01061 } 01062 01063 for (j = i; j < length_d; j++) { 01064 char_ptr[j] = ' '; 01065 } 01066 01067 break; 01068 } 01069 01070 if (TYP_TYPE(l_type_idx) == Logical && 01071 TYP_TYPE((*res_type_idx)) == Logical) { 01072 01073 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 01074 if (l_linear_type == Logical_8 && 01075 (res_linear_type == Logical_1 || 01076 res_linear_type == Logical_2 || 01077 res_linear_type == Logical_4)) { 01078 01079 # if defined(_HOST_LITTLE_ENDIAN) && defined(_TARGET_LITTLE_ENDIAN) 01080 *(long *)result = *(long long *)(l_value.v); 01081 # else 01082 result[0] = l_value.v[1]; 01083 # endif 01084 } 01085 else if (res_linear_type == Logical_8 && 01086 (l_linear_type == Logical_1 || 01087 l_linear_type == Logical_2 || 01088 l_linear_type == Logical_4)) { 01089 01090 # if defined(_HOST_LITTLE_ENDIAN) && defined(_TARGET_LITTLE_ENDIAN) 01091 *(long long *)result = *(long *)(l_value.v); 01092 # else 01093 result[0] = 0; 01094 result[1] = l_value.v[0]; 01095 # endif 01096 } 01097 else { 01098 result[0] = l_value.v[0]; 01099 result[1] = l_value.v[1]; 01100 } 01101 # else 01102 result[0] = l_value.v[0]; 01103 # endif 01104 break; 01105 } 01106 01107 if (TYP_TYPE(l_type_idx) == Typeless) { /* source */ 01108 for (i = 0;i < (TYP_BIT_LEN(l_type_idx)/TARGET_BITS_PER_WORD);i++) { 01109 result[i] = l_value.v[i]; 01110 } 01111 break; 01112 } 01113 01114 if (l_linear_type == res_linear_type) { 01115 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01116 result[i] = l_value.v[i]; 01117 } 01118 break; 01119 } 01120 01121 # if defined(_USE_FOLD_DOT_f) 01122 tmp_opr = Cvrt_Opr; 01123 FOLD_OPERATION( 01124 &tmp_opr, 01125 &loc_result.v, 01126 &res_linear_type, 01127 &l_value.v, 01128 &l_linear_type, 01129 &r_value.v, 01130 &r_linear_type, 01131 &a3_value.v, 01132 &a3_linear_type); 01133 # else 01134 arith_type = linear_to_arith[l_linear_type]; 01135 01136 if ((TYP_TYPE(l_type_idx) == Real || 01137 TYP_TYPE(l_type_idx) == Complex) && 01138 TYP_TYPE((*res_type_idx)) == Integer) { 01139 01140 /* this needs to be truncation, not rounding */ 01141 01142 switch(linear_to_arith[l_linear_type]) { 01143 case AR_Float_IEEE_NR_32 : 01144 arith_type = AR_Float_IEEE_ZE_32; 01145 break; 01146 01147 case AR_Float_IEEE_NR_64 : 01148 arith_type = AR_Float_IEEE_ZE_64; 01149 break; 01150 01151 case AR_Float_IEEE_NR_128 : 01152 arith_type = AR_Float_IEEE_ZE_128; 01153 break; 01154 01155 case AR_Complex_IEEE_NR_32 : 01156 arith_type = AR_Complex_IEEE_ZE_32; 01157 break; 01158 01159 case AR_Complex_IEEE_NR_64 : 01160 arith_type = AR_Complex_IEEE_ZE_64; 01161 break; 01162 01163 case AR_Complex_IEEE_NR_128 : 01164 arith_type = AR_Complex_IEEE_ZE_128; 01165 break; 01166 01167 } 01168 } 01169 01170 SHIFT_ARITH_ARG(l_value.v, l_linear_type); 01171 01172 mask = AR_convert((AR_DATA *)loc_result.v, 01173 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01174 (const AR_DATA *)l_value.v, 01175 (const AR_TYPE *)&arith_type); 01176 # endif 01177 01178 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01179 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01180 01181 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01182 result[i] = loc_result.v[i]; 01183 } 01184 break; 01185 01186 01187 case Cvrt_Unsigned_Opr : 01188 SHIFT_ARITH_ARG(l_value.v, l_linear_type); 01189 01190 arith_type = linear_to_arith[res_linear_type]; 01191 arith_type_l = linear_to_arith[l_linear_type]; 01192 01193 # if defined(_TARGET_OS_MAX) || defined(_TARGET_OS_SOLARIS) || \ 01194 (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 01195 01196 if (TYP_TYPE((*res_type_idx)) == Integer) { 01197 arith_type = input_arith_type[res_linear_type]; 01198 } 01199 01200 if (arith_type_l == AR_Int_32_S) { 01201 arith_type_l = AR_Int_32_U; 01202 } 01203 else if (arith_type_l == AR_Int_64_S) { 01204 arith_type_l = AR_Int_64_U; 01205 } 01206 # endif 01207 01208 # if defined(_USE_FOLD_DOT_f) 01209 tmp_opr = Cvrt_Opr; 01210 FOLD_OPERATION( 01211 &tmp_opr, 01212 &loc_result.v, 01213 &res_linear_type, 01214 &l_value.v, 01215 &l_linear_type, 01216 &r_value.v, 01217 &r_linear_type, 01218 &a3_value.v, 01219 &a3_linear_type); 01220 # else 01221 mask = AR_convert((AR_DATA *)loc_result.v, 01222 (const AR_TYPE *)&arith_type, 01223 (const AR_DATA *)l_value.v, 01224 (const AR_TYPE *)&arith_type_l); 01225 # endif 01226 01227 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01228 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01229 01230 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01231 result[i] = loc_result.v[i]; 01232 } 01233 break; 01234 01235 01236 case Power_Opr : 01237 if (l_linear_type != res_linear_type && 01238 TYP_TYPE(l_type_idx) != Typeless) { 01239 01240 SHIFT_ARITH_ARG(l_value.v, l_linear_type); 01241 01242 # if defined(_USE_FOLD_DOT_f) 01243 tmp_opr = Cvrt_Opr; 01244 FOLD_OPERATION( 01245 &tmp_opr, 01246 &loc_result.v, 01247 &res_linear_type, 01248 &l_value.v, 01249 &l_linear_type, 01250 &r_value.v, 01251 &r_linear_type, 01252 &a3_value.v, 01253 &a3_linear_type); 01254 # else 01255 mask = AR_convert((AR_DATA *)loc_result.v, 01256 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01257 (const AR_DATA *)l_value.v, 01258 (const AR_TYPE *)&linear_to_arith[l_linear_type]); 01259 # endif 01260 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01261 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01262 01263 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01264 l_value.v[i] = loc_result.v[i]; 01265 } 01266 } 01267 01268 if (r_linear_type != res_linear_type && 01269 TYP_TYPE(r_type_idx) == Integer && 01270 TYP_TYPE((*res_type_idx)) == Integer) { 01271 01272 SHIFT_ARITH_ARG(r_value.v, r_linear_type); 01273 01274 # if defined(_USE_FOLD_DOT_f) 01275 tmp_opr = Cvrt_Opr; 01276 FOLD_OPERATION( 01277 &tmp_opr, 01278 &loc_result.v, 01279 &res_linear_type, 01280 &r_value.v, 01281 &r_linear_type, 01282 &r_value.v, 01283 &r_linear_type, 01284 &a3_value.v, 01285 &a3_linear_type); 01286 # else 01287 mask = AR_convert((AR_DATA *)loc_result.v, 01288 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01289 (const AR_DATA *)r_value.v, 01290 (const AR_TYPE *)&linear_to_arith[r_linear_type]); 01291 # endif 01292 01293 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01294 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01295 01296 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01297 r_value.v[i] = loc_result.v[i]; 01298 } 01299 01300 r_linear_type = res_linear_type; 01301 } 01302 else if (r_linear_type != res_linear_type && 01303 TYP_TYPE(r_type_idx) != Integer && 01304 TYP_TYPE(r_type_idx) != Typeless) { 01305 01306 SHIFT_ARITH_ARG(r_value.v, r_linear_type); 01307 01308 # if defined(_USE_FOLD_DOT_f) 01309 tmp_opr = Cvrt_Opr; 01310 FOLD_OPERATION( 01311 &tmp_opr, 01312 &loc_result.v, 01313 &res_linear_type, 01314 &r_value.v, 01315 &r_linear_type, 01316 &r_value.v, 01317 &r_linear_type, 01318 &a3_value.v, 01319 &a3_linear_type); 01320 # else 01321 mask = AR_convert((AR_DATA *)loc_result.v, 01322 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01323 (const AR_DATA *)r_value.v, 01324 (const AR_TYPE *)&linear_to_arith[r_linear_type]); 01325 # endif 01326 01327 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01328 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01329 01330 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01331 r_value.v[i] = loc_result.v[i]; 01332 } 01333 01334 r_linear_type = res_linear_type; 01335 } 01336 01337 SHIFT_ARITH_ARG(l_value.v, res_linear_type); 01338 SHIFT_ARITH_ARG(r_value.v, r_linear_type); 01339 01340 # if defined(_USE_FOLD_DOT_f) 01341 FOLD_OPERATION( 01342 &opr, 01343 &loc_result.v, 01344 &res_linear_type, 01345 &l_value.v, 01346 &res_linear_type, 01347 &r_value.v, 01348 &r_linear_type, 01349 &a3_value.v, 01350 &a3_linear_type); 01351 # else 01352 mask = AR_power((AR_DATA *)loc_result.v, 01353 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01354 (const AR_DATA *)l_value.v, 01355 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01356 (const AR_DATA *)r_value.v, 01357 (const AR_TYPE *)&linear_to_arith[r_linear_type]); 01358 # endif 01359 01360 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01361 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01362 01363 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01364 result[i] = loc_result.v[i]; 01365 } 01366 break; 01367 01368 01369 case Mult_Opr : 01370 case Div_Opr : 01371 case Real_Div_To_Int_Opr: 01372 case Minus_Opr : 01373 case Plus_Opr : 01374 case Mod_Opr : 01375 case Modulo_Opr : 01376 if (l_linear_type != res_linear_type && 01377 TYP_TYPE(l_type_idx) != Typeless) { 01378 01379 SHIFT_ARITH_ARG(l_value.v, l_linear_type); 01380 01381 # if defined(_USE_FOLD_DOT_f) 01382 tmp_opr = Cvrt_Opr; 01383 FOLD_OPERATION( 01384 &tmp_opr, 01385 &loc_result.v, 01386 &res_linear_type, 01387 &l_value.v, 01388 &l_linear_type, 01389 &r_value.v, 01390 &r_linear_type, 01391 &a3_value.v, 01392 &a3_linear_type); 01393 # else 01394 mask = AR_convert((AR_DATA *)loc_result.v, 01395 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01396 (const AR_DATA *)l_value.v, 01397 (const AR_TYPE *)&linear_to_arith[l_linear_type]); 01398 # endif 01399 01400 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01401 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01402 01403 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01404 l_value.v[i] = loc_result.v[i]; 01405 } 01406 } 01407 01408 if (r_linear_type != res_linear_type && 01409 TYP_TYPE(r_type_idx) != Typeless) { 01410 01411 SHIFT_ARITH_ARG(r_value.v, r_linear_type); 01412 01413 # if defined(_USE_FOLD_DOT_f) 01414 tmp_opr = Cvrt_Opr; 01415 FOLD_OPERATION( 01416 &tmp_opr, 01417 &loc_result.v, 01418 &res_linear_type, 01419 &r_value.v, 01420 &r_linear_type, 01421 &r_value.v, 01422 &r_linear_type, 01423 &a3_value.v, 01424 &a3_linear_type); 01425 # else 01426 mask = AR_convert((AR_DATA *)loc_result.v, 01427 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01428 (const AR_DATA *)r_value.v, 01429 (const AR_TYPE *)&linear_to_arith[r_linear_type]); 01430 # endif 01431 01432 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01433 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01434 01435 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01436 r_value.v[i] = loc_result.v[i]; 01437 } 01438 } 01439 01440 SHIFT_ARITH_ARG(l_value.v, res_linear_type); 01441 SHIFT_ARITH_ARG(r_value.v, res_linear_type); 01442 01443 # if defined(_USE_FOLD_DOT_f) 01444 FOLD_OPERATION( 01445 &opr, 01446 &loc_result.v, 01447 &res_linear_type, 01448 &l_value.v, 01449 &res_linear_type, 01450 &r_value.v, 01451 &res_linear_type, 01452 &a3_value.v, 01453 &a3_linear_type); 01454 # else 01455 switch (opr) { 01456 case Mult_Opr: 01457 mask = AR_multiply((AR_DATA *)loc_result.v, 01458 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01459 (const AR_DATA *)l_value.v, 01460 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01461 (const AR_DATA *)r_value.v, 01462 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01463 break; 01464 01465 case Div_Opr : 01466 mask = AR_divide((AR_DATA *)loc_result.v, 01467 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01468 (const AR_DATA *)l_value.v, 01469 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01470 (const AR_DATA *)r_value.v, 01471 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01472 break; 01473 01474 case Real_Div_To_Int_Opr : 01475 mask = AR_divide((AR_DATA *)loc_result.v, 01476 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01477 (const AR_DATA *)l_value.v, 01478 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01479 (const AR_DATA *)r_value.v, 01480 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01481 01482 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01483 01484 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01485 r_value.v[i] = loc_result.v[i]; 01486 } 01487 01488 mask = AR_round_int_div((AR_DATA *)loc_result.v, 01489 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01490 (const AR_DATA *)r_value.v, 01491 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01492 break; 01493 01494 case Minus_Opr : 01495 mask = AR_subtract((AR_DATA *)loc_result.v, 01496 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01497 (const AR_DATA *)l_value.v, 01498 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01499 (const AR_DATA *)r_value.v, 01500 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01501 break; 01502 01503 case Plus_Opr : 01504 mask = AR_add((AR_DATA *)loc_result.v, 01505 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01506 (const AR_DATA *)l_value.v, 01507 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01508 (const AR_DATA *)r_value.v, 01509 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01510 break; 01511 01512 case Modulo_Opr : 01513 mask = AR_Modulo((AR_DATA *)loc_result.v, 01514 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01515 (const AR_DATA *)l_value.v, 01516 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01517 (const AR_DATA *)r_value.v, 01518 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01519 break; 01520 01521 case Mod_Opr : 01522 mask = AR_mod((AR_DATA *)loc_result.v, 01523 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01524 (const AR_DATA *)l_value.v, 01525 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01526 (const AR_DATA *)r_value.v, 01527 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01528 break; 01529 01530 } 01531 # endif 01532 01533 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01534 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01535 01536 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01537 result[i] = loc_result.v[i]; 01538 } 01539 break; 01540 01541 01542 case Eq_Opr : 01543 case Ne_Opr : 01544 case Lt_Opr : 01545 case Le_Opr : 01546 case Gt_Opr : 01547 case Ge_Opr : 01548 if (TYP_TYPE(l_type_idx) == Character && 01549 TYP_TYPE(r_type_idx) == Character) { 01550 f90_character_compare(l_value_ptr, 01551 CN_INT_TO_C(TYP_IDX(l_type_idx)), 01552 r_value_ptr, 01553 CN_INT_TO_C(TYP_IDX(r_type_idx)), 01554 opr, 01555 result, 01556 (*res_type_idx)); 01557 } 01558 else { 01559 res_linear_type = (linear_type_type) 01560 bin_add_tbl[l_linear_type][r_linear_type].type; 01561 01562 if (l_linear_type != res_linear_type && 01563 TYP_TYPE(l_type_idx) != Typeless) { 01564 01565 SHIFT_ARITH_ARG(l_value.v, l_linear_type); 01566 01567 # if defined(_USE_FOLD_DOT_f) 01568 tmp_opr = Cvrt_Opr; 01569 FOLD_OPERATION( 01570 &tmp_opr, 01571 &loc_result.v, 01572 &res_linear_type, 01573 &l_value.v, 01574 &l_linear_type, 01575 &r_value.v, 01576 &r_linear_type, 01577 &a3_value.v, 01578 &a3_linear_type); 01579 # else 01580 mask = AR_convert((AR_DATA *)loc_result.v, 01581 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01582 (const AR_DATA *)l_value.v, 01583 (const AR_TYPE *)&linear_to_arith[l_linear_type]); 01584 # endif 01585 01586 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01587 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01588 01589 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01590 l_value.v[i] = loc_result.v[i]; 01591 } 01592 } 01593 01594 if (r_linear_type != res_linear_type && 01595 TYP_TYPE(r_type_idx) != Typeless) { 01596 01597 SHIFT_ARITH_ARG(r_value.v, r_linear_type); 01598 01599 # if defined(_USE_FOLD_DOT_f) 01600 tmp_opr = Cvrt_Opr; 01601 FOLD_OPERATION( 01602 &tmp_opr, 01603 &loc_result.v, 01604 &res_linear_type, 01605 &r_value.v, 01606 &r_linear_type, 01607 &r_value.v, 01608 &r_linear_type, 01609 &a3_value.v, 01610 &a3_linear_type); 01611 # else 01612 mask = AR_convert((AR_DATA *)loc_result.v, 01613 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01614 (const AR_DATA *)r_value.v, 01615 (const AR_TYPE *)&linear_to_arith[r_linear_type]); 01616 # endif 01617 01618 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01619 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01620 01621 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01622 r_value.v[i] = loc_result.v[i]; 01623 } 01624 } 01625 01626 # if defined(_USE_FOLD_DOT_f) 01627 FOLD_OPERATION( 01628 &opr, 01629 &loc_result.v, 01630 &res_linear_type, 01631 &l_value.v, 01632 &res_linear_type, 01633 &r_value.v, 01634 &res_linear_type, 01635 &a3_value.v, 01636 &a3_linear_type); 01637 01638 if (loc_result.v[0] == 0) { 01639 set_up_logical_constant(result, 01640 (*res_type_idx), 01641 FALSE_VALUE, 01642 FALSE); 01643 } 01644 else { 01645 set_up_logical_constant(result, 01646 (*res_type_idx), 01647 TRUE_VALUE, 01648 FALSE); 01649 } 01650 # else 01651 SHIFT_ARITH_ARG(l_value.v, res_linear_type); 01652 SHIFT_ARITH_ARG(r_value.v, res_linear_type); 01653 01654 comp_res = AR_compare((const AR_DATA *)l_value.v, 01655 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01656 (const AR_DATA *)r_value.v, 01657 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01658 01659 switch (opr) { 01660 case Eq_Opr : 01661 if (comp_res == AR_Compare_EQ) { 01662 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, 01663 FALSE); 01664 } 01665 else { 01666 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE, 01667 FALSE); 01668 } 01669 break; 01670 01671 case Ne_Opr : 01672 if (comp_res != AR_Compare_EQ) { 01673 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, 01674 FALSE); 01675 } 01676 else { 01677 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE, 01678 FALSE); 01679 } 01680 break; 01681 01682 case Lt_Opr : 01683 if (comp_res == AR_Compare_LT) { 01684 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, 01685 FALSE); 01686 } 01687 else { 01688 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE, 01689 FALSE); 01690 } 01691 break; 01692 01693 case Le_Opr : 01694 if (comp_res != AR_Compare_GT) { 01695 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, 01696 FALSE); 01697 } 01698 else { 01699 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE, 01700 FALSE); 01701 } 01702 break; 01703 01704 case Gt_Opr : 01705 if (comp_res == AR_Compare_GT) { 01706 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, 01707 FALSE); 01708 } 01709 else { 01710 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE, 01711 FALSE); 01712 } 01713 break; 01714 01715 case Ge_Opr : 01716 if (comp_res != AR_Compare_LT) { 01717 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, 01718 FALSE); 01719 } 01720 else { 01721 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE, 01722 FALSE); 01723 } 01724 break; 01725 } 01726 # endif 01727 01728 res_linear_type = TYP_LINEAR(*res_type_idx); 01729 } 01730 break; 01731 01732 01733 case Not_Opr : 01734 if (THIS_IS_TRUE(l_value.v, l_type_idx)) { 01735 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE,FALSE); 01736 } 01737 else { 01738 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, FALSE); 01739 } 01740 break; 01741 01742 01743 case And_Opr : 01744 if (THIS_IS_TRUE(l_value.v, l_type_idx) && 01745 THIS_IS_TRUE(r_value.v, r_type_idx)) { 01746 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, FALSE); 01747 } 01748 else { 01749 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE,FALSE); 01750 } 01751 break; 01752 01753 01754 case Or_Opr : 01755 if (THIS_IS_TRUE(l_value.v, l_type_idx) || 01756 THIS_IS_TRUE(r_value.v, r_type_idx)) { 01757 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, FALSE); 01758 } 01759 else { 01760 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE,FALSE); 01761 } 01762 break; 01763 01764 01765 case Eqv_Opr : 01766 if ((THIS_IS_TRUE(l_value.v, l_type_idx)) == 01767 (THIS_IS_TRUE(r_value.v, r_type_idx))) { 01768 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, FALSE); 01769 } 01770 else { 01771 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE,FALSE); 01772 } 01773 break; 01774 01775 01776 case Neqv_Opr : 01777 if ((THIS_IS_TRUE(l_value.v, l_type_idx)) != 01778 (THIS_IS_TRUE(r_value.v, r_type_idx))) { 01779 set_up_logical_constant(result, (*res_type_idx), TRUE_VALUE, FALSE); 01780 } 01781 else { 01782 set_up_logical_constant(result, (*res_type_idx), FALSE_VALUE,FALSE); 01783 } 01784 break; 01785 01786 01787 case Bnot_Opr : 01788 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01789 result[i] = ~l_value.v[i]; 01790 } 01791 break; 01792 01793 01794 case Band_Opr : 01795 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01796 result[i] = l_value.v[i] & r_value.v[i]; 01797 } 01798 break; 01799 01800 01801 case Bor_Opr : 01802 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01803 result[i] = l_value.v[i] | r_value.v[i]; 01804 } 01805 break; 01806 01807 01808 case Bneqv_Opr : 01809 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01810 result[i] = l_value.v[i] ^ r_value.v[i]; 01811 } 01812 break; 01813 01814 01815 case Beqv_Opr : 01816 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01817 result[i] = ~(l_value.v[i] ^ r_value.v[i]); 01818 } 01819 break; 01820 01821 01822 # if defined(_USE_FOLD_DOT_f) 01823 case Sqrt_Opr : 01824 SHIFT_ARITH_ARG(l_value.v, res_linear_type); 01825 01826 FOLD_OPERATION( 01827 &opr, 01828 &loc_result.v, 01829 &res_linear_type, 01830 &l_value.v, 01831 &res_linear_type, 01832 &r_value.v, 01833 &res_linear_type, 01834 &a3_value.v, 01835 &a3_linear_type); 01836 01837 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01838 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01839 01840 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01841 result[i] = loc_result.v[i]; 01842 } 01843 break; 01844 # endif 01845 01846 01847 case Abs_Opr : 01848 SHIFT_ARITH_ARG(l_value.v, res_linear_type); 01849 01850 # if defined(_USE_FOLD_DOT_f) 01851 FOLD_OPERATION( 01852 &opr, 01853 &loc_result.v, 01854 &res_linear_type, 01855 &l_value.v, 01856 &res_linear_type, 01857 &r_value.v, 01858 &res_linear_type, 01859 &a3_value.v, 01860 &a3_linear_type); 01861 # else 01862 mask = AR_abs((AR_DATA *)loc_result.v, 01863 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01864 (const AR_DATA *)l_value.v, 01865 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01866 # endif 01867 01868 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01869 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 01870 01871 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01872 result[i] = loc_result.v[i]; 01873 } 01874 break; 01875 01876 01877 case Nint_Opr : 01878 # if defined(_USE_FOLD_DOT_f) 01879 FOLD_OPERATION( 01880 &opr, 01881 &loc_result.v, 01882 &res_linear_type, 01883 &l_value.v, 01884 &l_linear_type, 01885 &r_value.v, 01886 &r_linear_type, 01887 &a3_value.v, 01888 &a3_linear_type); 01889 01890 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 01891 result[i] = loc_result.v[i]; 01892 } 01893 # else 01894 strcpy(char_buf, "0.5"); 01895 mask = AR_convert_str_to_float((AR_DATA *)a3_value.v, 01896 (const AR_TYPE *)&input_arith_type[l_linear_type], 01897 (const char *)char_buf); 01898 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01899 SHIFT_ARITH_RESULT(a3_value.v, l_linear_type); 01900 01901 type_idx = CG_LOGICAL_DEFAULT_TYPE; 01902 01903 ok &= folder_driver((char *)l_value.v, 01904 l_type_idx, 01905 (char *)&CN_CONST(CN_INTEGER_ZERO_IDX), 01906 CG_INTEGER_DEFAULT_TYPE, 01907 a4_value.v, 01908 &type_idx, 01909 line, 01910 col, 01911 2, 01912 Le_Opr); 01913 01914 if (THIS_IS_TRUE(a4_value.v,type_idx)) { 01915 type_idx = l_type_idx; 01916 ok &= folder_driver((char *)l_value.v, 01917 l_type_idx, 01918 (char *)a3_value.v, 01919 l_type_idx, 01920 a4_value.v, 01921 &type_idx, 01922 line, 01923 col, 01924 2, 01925 Minus_Opr); 01926 } 01927 else { 01928 type_idx = l_type_idx; 01929 ok &= folder_driver((char *)l_value.v, 01930 l_type_idx, 01931 (char *)a3_value.v, 01932 l_type_idx, 01933 a4_value.v, 01934 &type_idx, 01935 line, 01936 col, 01937 2, 01938 Plus_Opr); 01939 } 01940 01941 ok &= folder_driver((char *)a4_value.v, 01942 l_type_idx, 01943 NULL, 01944 NULL_IDX, 01945 result, 01946 res_type_idx, 01947 line, 01948 col, 01949 1, 01950 Int_Opr); 01951 # endif 01952 break; 01953 01954 01955 case Sign_Opr : 01956 SHIFT_ARITH_ARG(l_value.v, res_linear_type); 01957 01958 # if defined(_USE_FOLD_DOT_f) 01959 tmp_opr = Abs_Opr; 01960 FOLD_OPERATION( 01961 &tmp_opr, 01962 &a3_value.v, 01963 &res_linear_type, 01964 &l_value.v, 01965 &res_linear_type, 01966 &r_value.v, 01967 &r_linear_type, 01968 &a3_value.v, 01969 &a3_linear_type); 01970 # else 01971 mask = AR_abs((AR_DATA *)a3_value.v, 01972 (const AR_TYPE *)&linear_to_arith[res_linear_type], 01973 (const AR_DATA *)l_value.v, 01974 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 01975 # endif 01976 01977 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 01978 SHIFT_ARITH_RESULT(a3_value.v, res_linear_type); 01979 01980 type_idx = CG_LOGICAL_DEFAULT_TYPE; 01981 01982 ok &= folder_driver((char *)r_value.v, 01983 r_type_idx, 01984 (char *)&CN_CONST(CN_INTEGER_ZERO_IDX), 01985 CG_INTEGER_DEFAULT_TYPE, 01986 a4_value.v, 01987 &type_idx, 01988 line, 01989 col, 01990 2, 01991 Lt_Opr); 01992 01993 if (THIS_IS_TRUE(a4_value.v, type_idx)) { 01994 /* negate the result */ 01995 SHIFT_ARITH_ARG(a3_value.v, res_linear_type); 01996 01997 # if defined(_USE_FOLD_DOT_f) 01998 tmp_opr = Uminus_Opr; 01999 FOLD_OPERATION( 02000 &tmp_opr, 02001 &loc_result.v, 02002 &res_linear_type, 02003 &a3_value.v, 02004 &res_linear_type, 02005 &r_value.v, 02006 &r_linear_type, 02007 &a3_value.v, 02008 &a3_linear_type); 02009 # else 02010 mask = AR_negate((AR_DATA *)loc_result.v, 02011 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02012 (const AR_DATA *)a3_value.v, 02013 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 02014 # endif 02015 02016 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02017 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02018 02019 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02020 result[i] = loc_result.v[i]; 02021 } 02022 } 02023 else { 02024 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02025 result[i] = a3_value.v[i]; 02026 } 02027 } 02028 break; 02029 02030 02031 02032 02033 case Shift_Opr : 02034 /* to behave like the runtime shift, we must calculate */ 02035 /* mod(r_value.v, TARGET_BITS_PER_WORD) to use as shift count */ 02036 02037 # if defined(_USE_FOLD_DOT_f) 02038 FOLD_OPERATION( 02039 &opr, 02040 &loc_result.v, 02041 &res_linear_type, 02042 &l_value.v, 02043 &l_linear_type, 02044 &r_value.v, 02045 &r_linear_type, 02046 &a3_value.v, 02047 &a3_linear_type); 02048 02049 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02050 result[i] = loc_result.v[i]; 02051 } 02052 02053 break; 02054 # endif 02055 02056 02057 02058 a4_value.v[0] = TARGET_BITS_PER_WORD; 02059 # ifdef _TARGET32 02060 if (num_host_wds[res_linear_type] != 1) { 02061 a4_value.v[1] = 2 * TARGET_BITS_PER_WORD; 02062 a4_value.v[0] = 0; 02063 } 02064 # endif 02065 02066 02067 SHIFT_ARITH_ARG(r_value.v, res_linear_type); 02068 SHIFT_ARITH_ARG(a4_value.v, res_linear_type); 02069 02070 mask = AR_mod((AR_DATA *)a3_value.v, 02071 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02072 (const AR_DATA *)r_value.v, 02073 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02074 (const AR_DATA *)a4_value.v, 02075 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 02076 02077 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02078 02079 a4_value.v[0] = 0; 02080 a4_value.v[1] = 0; 02081 a4_value.v[2] = 0; 02082 a4_value.v[3] = 0; 02083 02084 SHIFT_ARITH_ARG(l_value.v, res_linear_type); 02085 02086 if ((mask & AR_STAT_NEGATIVE) != 0) { 02087 02088 mask = AR_negate((AR_DATA *)loc_result.v, 02089 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02090 (const AR_DATA *)a3_value.v, 02091 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 02092 02093 for (i = 0; i < 4; i++) { 02094 a3_value.v[i] = loc_result.v[i]; 02095 } 02096 02097 mask = AR_dshiftr((AR_DATA *)r_value.v, 02098 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02099 (const AR_DATA *)l_value.v, 02100 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02101 (const AR_DATA *)a4_value.v, 02102 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02103 (const AR_DATA *)a3_value.v, 02104 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 02105 02106 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02107 02108 mask = AR_shiftr((AR_DATA *)loc_result.v, 02109 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02110 (const AR_DATA *)l_value.v, 02111 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02112 (const AR_DATA *)a3_value.v, 02113 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 02114 02115 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02116 } 02117 else { 02118 mask = AR_dshiftl((AR_DATA *)r_value.v, 02119 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02120 (const AR_DATA *)a4_value.v, 02121 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02122 (const AR_DATA *)l_value.v, 02123 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02124 (const AR_DATA *)a3_value.v, 02125 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 02126 02127 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02128 02129 mask = AR_shiftl((AR_DATA *)loc_result.v, 02130 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02131 (const AR_DATA *)l_value.v, 02132 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02133 (const AR_DATA *)a3_value.v, 02134 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 02135 02136 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02137 } 02138 02139 SHIFT_ARITH_RESULT(r_value.v, res_linear_type); 02140 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02141 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02142 loc_result.v[i] |= r_value.v[i]; 02143 } 02144 02145 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02146 result[i] = loc_result.v[i]; 02147 } 02148 break; 02149 02150 02151 02152 case Ishftc_Opr : 02153 case Ibits_Opr : 02154 if (l_linear_type != res_linear_type && 02155 TYP_TYPE(l_type_idx) != Typeless) { 02156 02157 SHIFT_ARITH_ARG(l_value.v, l_linear_type); 02158 02159 # if defined(_USE_FOLD_DOT_f) 02160 tmp_opr = Cvrt_Opr; 02161 FOLD_OPERATION( 02162 &tmp_opr, 02163 &loc_result.v, 02164 &res_linear_type, 02165 &l_value.v, 02166 &l_linear_type, 02167 &r_value.v, 02168 &r_linear_type, 02169 &a3_value.v, 02170 &a3_linear_type); 02171 # else 02172 mask = AR_convert((AR_DATA *)loc_result.v, 02173 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02174 (const AR_DATA *)l_value.v, 02175 (const AR_TYPE *)&linear_to_arith[l_linear_type]); 02176 # endif 02177 02178 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02179 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02180 02181 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02182 l_value.v[i] = loc_result.v[i]; 02183 } 02184 } 02185 02186 if (r_linear_type != res_linear_type && 02187 TYP_TYPE(r_type_idx) != Typeless) { 02188 02189 SHIFT_ARITH_ARG(r_value.v, r_linear_type); 02190 02191 # if defined(_USE_FOLD_DOT_f) 02192 tmp_opr = Cvrt_Opr; 02193 FOLD_OPERATION( 02194 &tmp_opr, 02195 &loc_result.v, 02196 &res_linear_type, 02197 &r_value.v, 02198 &r_linear_type, 02199 &r_value.v, 02200 &r_linear_type, 02201 &a3_value.v, 02202 &a3_linear_type); 02203 # else 02204 mask = AR_convert((AR_DATA *)loc_result.v, 02205 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02206 (const AR_DATA *)r_value.v, 02207 (const AR_TYPE *)&linear_to_arith[r_linear_type]); 02208 # endif 02209 02210 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02211 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02212 02213 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02214 r_value.v[i] = loc_result.v[i]; 02215 } 02216 } 02217 02218 if (a3_linear_type != res_linear_type && 02219 TYP_TYPE(a3_type_idx) != Typeless) { 02220 02221 SHIFT_ARITH_ARG(a3_value.v, a3_linear_type); 02222 02223 # if defined(_USE_FOLD_DOT_f) 02224 tmp_opr = Cvrt_Opr; 02225 FOLD_OPERATION( 02226 &tmp_opr, 02227 &loc_result.v, 02228 &res_linear_type, 02229 &a3_value.v, 02230 &a3_linear_type, 02231 &r_value.v, 02232 &r_linear_type, 02233 &a3_value.v, 02234 &a3_linear_type); 02235 # else 02236 mask = AR_convert((AR_DATA *)loc_result.v, 02237 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02238 (const AR_DATA *)a3_value.v, 02239 (const AR_TYPE *)&linear_to_arith[a3_linear_type]); 02240 # endif 02241 02242 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02243 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02244 02245 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02246 a3_value.v[i] = loc_result.v[i]; 02247 } 02248 } 02249 02250 SHIFT_ARITH_ARG(l_value.v, res_linear_type); 02251 SHIFT_ARITH_ARG(r_value.v, res_linear_type); 02252 SHIFT_ARITH_ARG(a3_value.v, res_linear_type); 02253 02254 # if defined(_USE_FOLD_DOT_f) 02255 FOLD_OPERATION( 02256 &opr, 02257 &loc_result.v, 02258 &res_linear_type, 02259 &l_value.v, 02260 &res_linear_type, 02261 &r_value.v, 02262 &res_linear_type, 02263 &a3_value.v, 02264 &res_linear_type); 02265 # else 02266 if (opr == Ibits_Opr) { 02267 mask = AR_ibits((AR_DATA *)loc_result.v, 02268 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02269 (const AR_DATA *)l_value.v, 02270 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02271 (const AR_DATA *)r_value.v, 02272 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02273 (const AR_DATA *)a3_value.v, 02274 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 02275 } 02276 else { 02277 mask = AR_ishftc((AR_DATA *)loc_result.v, 02278 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02279 (const AR_DATA *)l_value.v, 02280 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02281 (const AR_DATA *)r_value.v, 02282 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02283 (const AR_DATA *)a3_value.v, 02284 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 02285 } 02286 02287 /* don't check for anything but invalid type here */ 02288 02289 if ((mask & AR_STAT_INVALID_TYPE) != 0) { 02290 PRINTMSG(line, 1079, Internal, col); 02291 } 02292 # endif 02293 02294 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02295 02296 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02297 result[i] = loc_result.v[i]; 02298 } 02299 break; 02300 02301 02302 case Shiftl_Opr : 02303 case Shiftr_Opr : 02304 case Shifta_Opr : 02305 if (l_linear_type != res_linear_type && 02306 TYP_TYPE(l_type_idx) != Typeless) { 02307 02308 SHIFT_ARITH_ARG(l_value.v, l_linear_type); 02309 02310 # if defined(_USE_FOLD_DOT_f) 02311 tmp_opr = Cvrt_Opr; 02312 FOLD_OPERATION( 02313 &tmp_opr, 02314 &loc_result.v, 02315 &res_linear_type, 02316 &l_value.v, 02317 &l_linear_type, 02318 &r_value.v, 02319 &r_linear_type, 02320 &a3_value.v, 02321 &a3_linear_type); 02322 # else 02323 mask = AR_convert((AR_DATA *)loc_result.v, 02324 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02325 (const AR_DATA *)l_value.v, 02326 (const AR_TYPE *)&linear_to_arith[l_linear_type]); 02327 # endif 02328 02329 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02330 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02331 02332 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02333 l_value.v[i] = loc_result.v[i]; 02334 } 02335 } 02336 02337 if (r_linear_type != res_linear_type && 02338 TYP_TYPE(r_type_idx) != Typeless) { 02339 02340 SHIFT_ARITH_ARG(r_value.v, r_linear_type); 02341 02342 # if defined(_USE_FOLD_DOT_f) 02343 tmp_opr = Cvrt_Opr; 02344 FOLD_OPERATION( 02345 &tmp_opr, 02346 &loc_result.v, 02347 &res_linear_type, 02348 &r_value.v, 02349 &r_linear_type, 02350 &r_value.v, 02351 &r_linear_type, 02352 &a3_value.v, 02353 &a3_linear_type); 02354 # else 02355 mask = AR_convert((AR_DATA *)loc_result.v, 02356 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02357 (const AR_DATA *)r_value.v, 02358 (const AR_TYPE *)&linear_to_arith[r_linear_type]); 02359 # endif 02360 02361 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02362 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02363 02364 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02365 r_value.v[i] = loc_result.v[i]; 02366 } 02367 } 02368 02369 SHIFT_ARITH_ARG(l_value.v, res_linear_type); 02370 SHIFT_ARITH_ARG(r_value.v, res_linear_type); 02371 02372 arith_type = linear_to_arith[res_linear_type]; 02373 02374 if (opr != Shifta_Opr) { 02375 if (arith_type == AR_Int_32_S) { 02376 arith_type = AR_Int_32_U; 02377 } 02378 else if (arith_type == AR_Int_64_S) { 02379 arith_type = AR_Int_64_U; 02380 } 02381 } 02382 02383 # if defined(_USE_FOLD_DOT_f) 02384 FOLD_OPERATION( 02385 &opr, 02386 &loc_result.v, 02387 &res_linear_type, 02388 &l_value.v, 02389 &res_linear_type, 02390 &r_value.v, 02391 &res_linear_type, 02392 &a3_value.v, 02393 &a3_linear_type); 02394 # else 02395 switch (opr) { 02396 case Shiftl_Opr : 02397 mask = AR_shiftl((AR_DATA *)loc_result.v, 02398 (const AR_TYPE *)&arith_type, 02399 (const AR_DATA *)l_value.v, 02400 (const AR_TYPE *)&arith_type, 02401 (const AR_DATA *)r_value.v, 02402 (const AR_TYPE *)&arith_type); 02403 break; 02404 02405 case Shiftr_Opr : 02406 case Shifta_Opr : 02407 mask = AR_shiftr((AR_DATA *)loc_result.v, 02408 (const AR_TYPE *)&arith_type, 02409 (const AR_DATA *)l_value.v, 02410 (const AR_TYPE *)&arith_type, 02411 (const AR_DATA *)r_value.v, 02412 (const AR_TYPE *)&arith_type); 02413 break; 02414 } 02415 02416 /* don't check for anything but invalid type here */ 02417 02418 if ((mask & AR_STAT_INVALID_TYPE) != 0) { 02419 PRINTMSG(line, 1079, Internal, col); 02420 } 02421 # endif 02422 02423 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02424 02425 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02426 result[i] = loc_result.v[i]; 02427 } 02428 break; 02429 02430 02431 case Dim_Opr : 02432 type_idx = CG_LOGICAL_DEFAULT_TYPE; 02433 02434 ok = folder_driver((char *)l_value.v, 02435 l_type_idx, 02436 (char *)r_value.v, 02437 r_type_idx, 02438 a3_value.v, 02439 &type_idx, 02440 line, 02441 col, 02442 2, 02443 Le_Opr); 02444 02445 if (THIS_IS_TRUE(a3_value.v, type_idx)) { 02446 ok &= folder_driver((char *)&CN_CONST(CN_INTEGER_ZERO_IDX), 02447 CG_INTEGER_DEFAULT_TYPE, 02448 NULL, 02449 NULL_IDX, 02450 result, 02451 res_type_idx, 02452 line, 02453 col, 02454 1, 02455 Cvrt_Opr); 02456 } 02457 else { 02458 ok = folder_driver((char *)l_value.v, 02459 l_type_idx, 02460 (char *)r_value.v, 02461 r_type_idx, 02462 a3_value.v, 02463 res_type_idx, 02464 line, 02465 col, 02466 2, 02467 Minus_Opr); 02468 02469 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02470 result[i] = a3_value.v[i]; 02471 } 02472 } 02473 break; 02474 02475 02476 02477 case Ichar_Opr : 02478 result[0] = l_value_ptr[0]; 02479 02480 # ifdef _TARGET32 02481 if (res_linear_type == Integer_8) { 02482 result[1] = result[0]; 02483 result[0] = 0; 02484 } 02485 # endif 02486 break; 02487 02488 02489 case Char_Opr : 02490 # if defined(_TARGET_LITTLE_ENDIAN) 02491 /* 02492 * NOTE: 1) range checking is pre-performed by caller 02493 * 2) Integer_8 is swapped, so this works for it as well 02494 */ 02495 result[0] = l_value.v[0]; 02496 # else 02497 02498 # ifdef _TARGET32 02499 if (l_linear_type == Integer_8) { 02500 l_value.v[0] = l_value.v[1]; 02501 } 02502 # endif 02503 result[0] = l_value.v[0] << (TARGET_BITS_PER_WORD - CHAR_BIT); 02504 # endif 02505 break; 02506 02507 02508 case Index_Opr : 02509 SHIFT_ARITH_ARG(a3_value.v, a3_linear_type); 02510 02511 str1_linear_type = TYP_LINEAR(CN_TYPE_IDX(TYP_IDX(l_type_idx))); 02512 str2_linear_type = TYP_LINEAR(CN_TYPE_IDX(TYP_IDX(r_type_idx))); 02513 02514 for (i = 0; 02515 i < num_host_wds[str1_linear_type]; 02516 i++) { 02517 02518 str_len1.v[i] = CP_CONSTANT(CN_POOL_IDX(TYP_IDX(l_type_idx)) + i); 02519 } 02520 02521 for (i = 0; 02522 i < num_host_wds[str2_linear_type]; 02523 i++) { 02524 02525 str_len2.v[i] = CP_CONSTANT(CN_POOL_IDX(TYP_IDX(r_type_idx)) + i); 02526 } 02527 02528 # ifdef _TARGET32 02529 if (num_host_wds[str1_linear_type] != num_host_wds[res_linear_type]) { 02530 if (res_linear_type == Integer_8) { 02531 str_len1.v[1] = str_len1.v[0]; 02532 str_len1.v[0] = 0; 02533 } 02534 else { 02535 str_len1.v[0] = str_len1.v[1]; 02536 } 02537 } 02538 02539 if (num_host_wds[str2_linear_type] != num_host_wds[res_linear_type]) { 02540 if (res_linear_type == Integer_8) { 02541 str_len2.v[1] = str_len2.v[0]; 02542 str_len2.v[0] = 0; 02543 } 02544 else { 02545 str_len2.v[0] = str_len2.v[1]; 02546 } 02547 } 02548 # endif 02549 02550 02551 SHIFT_ARITH_ARG(str_len1.v, res_linear_type); 02552 SHIFT_ARITH_ARG(str_len2.v, res_linear_type); 02553 02554 mask = AR_index((AR_DATA *)loc_result.v, 02555 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02556 (const char *)l_value_ptr, 02557 (const AR_DATA *)str_len1.v, 02558 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02559 (const char *)r_value_ptr, 02560 (const AR_DATA *)str_len2.v, 02561 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02562 (const AR_DATA *)a3_value.v, 02563 (const AR_TYPE *)&linear_to_arith[a3_linear_type]); 02564 02565 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02566 02567 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02568 result[i] = loc_result.v[i]; 02569 } 02570 02571 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02572 break; 02573 02574 02575 case Scan_Opr : 02576 SHIFT_ARITH_ARG(a3_value.v, a3_linear_type); 02577 02578 str1_linear_type = TYP_LINEAR(CN_TYPE_IDX(TYP_IDX(l_type_idx))); 02579 str2_linear_type = TYP_LINEAR(CN_TYPE_IDX(TYP_IDX(r_type_idx))); 02580 02581 for (i = 0; 02582 i < num_host_wds[str1_linear_type]; 02583 i++) { 02584 02585 str_len1.v[i] = CP_CONSTANT(CN_POOL_IDX(TYP_IDX(l_type_idx)) + i); 02586 } 02587 02588 for (i = 0; 02589 i < num_host_wds[str2_linear_type]; 02590 i++) { 02591 02592 str_len2.v[i] = CP_CONSTANT(CN_POOL_IDX(TYP_IDX(r_type_idx)) + i); 02593 } 02594 02595 # ifdef _TARGET32 02596 if (num_host_wds[str1_linear_type] != num_host_wds[res_linear_type]) { 02597 if (res_linear_type == Integer_8) { 02598 str_len1.v[1] = str_len1.v[0]; 02599 str_len1.v[0] = 0; 02600 } 02601 else { 02602 str_len1.v[0] = str_len1.v[1]; 02603 } 02604 } 02605 02606 if (num_host_wds[str2_linear_type] != num_host_wds[res_linear_type]) { 02607 if (res_linear_type == Integer_8) { 02608 str_len2.v[1] = str_len2.v[0]; 02609 str_len2.v[0] = 0; 02610 } 02611 else { 02612 str_len2.v[0] = str_len2.v[1]; 02613 } 02614 } 02615 # endif 02616 02617 02618 SHIFT_ARITH_ARG(str_len1.v, res_linear_type); 02619 SHIFT_ARITH_ARG(str_len2.v, res_linear_type); 02620 02621 mask = AR_scan((AR_DATA *)loc_result.v, 02622 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02623 (const char *)l_value_ptr, 02624 (const AR_DATA *)str_len1.v, 02625 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02626 (const char *)r_value_ptr, 02627 (const AR_DATA *)str_len2.v, 02628 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02629 (const AR_DATA *)a3_value.v, 02630 (const AR_TYPE *)&linear_to_arith[a3_linear_type]); 02631 02632 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02633 02634 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02635 result[i] = loc_result.v[i]; 02636 } 02637 #if 0 /*fzhao March*/ 02638 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02639 # endif 02640 break; 02641 02642 02643 case Verify_Opr : 02644 SHIFT_ARITH_ARG(a3_value.v, a3_linear_type); 02645 02646 str1_linear_type = TYP_LINEAR(CN_TYPE_IDX(TYP_IDX(l_type_idx))); 02647 str2_linear_type = TYP_LINEAR(CN_TYPE_IDX(TYP_IDX(r_type_idx))); 02648 02649 for (i = 0; 02650 i < num_host_wds[str1_linear_type]; 02651 i++) { 02652 02653 str_len1.v[i] = CP_CONSTANT(CN_POOL_IDX(TYP_IDX(l_type_idx)) + i); 02654 } 02655 02656 for (i = 0; 02657 i < num_host_wds[str2_linear_type]; 02658 i++) { 02659 02660 str_len2.v[i] = CP_CONSTANT(CN_POOL_IDX(TYP_IDX(r_type_idx)) + i); 02661 } 02662 02663 # ifdef _TARGET32 02664 if (num_host_wds[str1_linear_type] != num_host_wds[res_linear_type]) { 02665 if (res_linear_type == Integer_8) { 02666 str_len1.v[1] = str_len1.v[0]; 02667 str_len1.v[0] = 0; 02668 } 02669 else { 02670 str_len1.v[0] = str_len1.v[1]; 02671 } 02672 } 02673 02674 if (num_host_wds[str2_linear_type] != num_host_wds[res_linear_type]) { 02675 if (res_linear_type == Integer_8) { 02676 str_len2.v[1] = str_len2.v[0]; 02677 str_len2.v[0] = 0; 02678 } 02679 else { 02680 str_len2.v[0] = str_len2.v[1]; 02681 } 02682 } 02683 # endif 02684 02685 02686 SHIFT_ARITH_ARG(str_len1.v, res_linear_type); 02687 SHIFT_ARITH_ARG(str_len2.v, res_linear_type); 02688 02689 02690 mask = AR_verify((AR_DATA *)loc_result.v, 02691 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02692 (const char *)l_value_ptr, 02693 (const AR_DATA *)str_len1.v, 02694 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02695 (const char *)r_value_ptr, 02696 (const AR_DATA *)str_len2.v, 02697 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02698 (const AR_DATA *)a3_value.v, 02699 (const AR_TYPE *)&linear_to_arith[a3_linear_type]); 02700 02701 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02702 02703 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02704 result[i] = loc_result.v[i]; 02705 } 02706 02707 ARITH_ERROR_RESULT_TEST(mask, (*res_type_idx), ok, line, col); 02708 break; 02709 02710 02711 case Adjustl_Opr : 02712 /* The return value is the constant tbl index for */ 02713 /* the character result constant. */ 02714 02715 result[0] = ntr_const_tbl(l_type_idx, TRUE, NULL); 02716 02717 *res_type_idx = l_type_idx; 02718 02719 char_len = CN_INT_TO_C(TYP_IDX(l_type_idx)); 02720 02721 i = 0; 02722 while (i < char_len && 02723 l_value_ptr[i] == ' ') { 02724 i++; 02725 } 02726 02727 char_ptr = (char *)&(CN_CONST(result[0])); 02728 02729 for (k = 0; k < (char_len - i); k++) { 02730 char_ptr[k] = l_value_ptr[i + k]; 02731 } 02732 02733 for (; k < char_len; k++) { 02734 char_ptr[k] = ' '; 02735 } 02736 break; 02737 02738 02739 case Adjustr_Opr : 02740 /* The return value is the constant tbl index for */ 02741 /* the character result constant. */ 02742 02743 result[0] = ntr_const_tbl(l_type_idx, 02744 TRUE, 02745 (long_type *) char_buf); 02746 02747 *res_type_idx = l_type_idx; 02748 02749 char_len = CN_INT_TO_C(TYP_IDX(l_type_idx)); 02750 02751 i = 0; 02752 while (i < char_len && 02753 l_value_ptr[(char_len - i) - 1] == ' ') { 02754 i++; 02755 } 02756 02757 /* i is the number of blanks */ 02758 02759 char_ptr = (char *)&(CN_CONST(result[0])); 02760 02761 for (k = char_len; k > i; k--) { 02762 char_ptr[k - 1] = l_value_ptr[(k - i) - 1]; 02763 } 02764 02765 for (; k > 0; k--) { 02766 char_ptr[k - 1] = ' '; 02767 } 02768 break; 02769 02770 02771 case Len_Trim_Opr : 02772 char_len = CN_INT_TO_C(TYP_IDX(l_type_idx)); 02773 while (char_len > 0 && l_value_ptr[char_len-1] == ' ') { 02774 char_len--; 02775 } 02776 02777 /* char_len is a C value, result is a target value */ 02778 02779 C_TO_F_INT(result, char_len, TYP_LINEAR(*res_type_idx)); 02780 break; 02781 02782 02783 case Mask_Opr : 02784 SHIFT_ARITH_ARG(l_value.v, l_linear_type); 02785 02786 mask = AR_mask((AR_DATA *)loc_result.v, 02787 (const AR_TYPE *)&linear_to_arith[res_linear_type], 02788 (const AR_DATA *)l_value.v, 02789 (const AR_TYPE *)&linear_to_arith[res_linear_type]); 02790 02791 /* don't check for anything but invalid type here */ 02792 02793 if ((mask & AR_STAT_INVALID_TYPE) != 0) { 02794 PRINTMSG(line, 1079, Internal, col); 02795 } 02796 SHIFT_ARITH_RESULT(loc_result.v, res_linear_type); 02797 02798 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02799 result[i] = loc_result.v[i]; 02800 } 02801 break; 02802 02803 02804 02805 case Csmg_Opr : 02806 /* transform to this ... */ 02807 /* csmg(x,y,z) = (x .and. z) .or. (y .and. (.not. z)) */ 02808 02809 type_idx = *res_type_idx; 02810 02811 /* (x .and. z) */ 02812 ok = folder_driver((char *)l_value.v, 02813 l_type_idx, 02814 (char *)a3_value.v, 02815 a3_type_idx, 02816 a4_value.v, 02817 &type_idx, 02818 line, 02819 col, 02820 2, 02821 Band_Opr) && ok; 02822 02823 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02824 l_value.v[i] = a4_value.v[i]; 02825 } 02826 /* x now holds (x .and. z) */ 02827 02828 /* (.not. z) */ 02829 02830 ok = folder_driver((char *)a3_value.v, 02831 a3_type_idx, 02832 NULL, 02833 NULL_IDX, 02834 a4_value.v, 02835 &type_idx, 02836 line, 02837 col, 02838 1, 02839 Bnot_Opr) && ok; 02840 02841 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02842 a3_value.v[i] = a4_value.v[i]; 02843 } 02844 /* z now holds (.not. z) */ 02845 02846 /* (y .and. (.not. z)) */ 02847 ok = folder_driver((char *)r_value.v, 02848 r_type_idx, 02849 (char *)a3_value.v, 02850 type_idx, 02851 a4_value.v, 02852 &type_idx, 02853 line, 02854 col, 02855 2, 02856 Band_Opr) && ok; 02857 02858 for (i = 0; i < num_host_wds[res_linear_type]; i++) { 02859 r_value.v[i] = a4_value.v[i]; 02860 } 02861 /* y now holds (y .and. (.not. z)) */ 02862 02863 02864 /* (x .and. z) .or. (y .and. (.not. z)) */ 02865 02866 ok = folder_driver((char *)l_value.v, 02867 type_idx, 02868 (char *)r_value.v, 02869 type_idx, 02870 result, 02871 res_type_idx, 02872 line, 02873 col, 02874 2, 02875 Bor_Opr) && ok; 02876 02877 break; 02878 02879 default: 02880 PRINTMSG(line, 828, Internal, col); 02881 break; 02882 } 02883 02884 # ifdef _TARGET_OS_MAX 02885 if (res_linear_type == Complex_4) { /* KAYKAY */ 02886 /* we need to unpack it into two words */ 02887 result[1] = result[0] & 0xFFFFFFFF; 02888 result[0] = result[0] >> 32; 02889 } 02890 # endif 02891 02892 EXIT: 02893 02894 TRACE (Func_Exit, "folder_driver", NULL); 02895 02896 return(ok); 02897 02898 } /* folder_driver */ 02899 02900 02901 /******************************************************************************\ 02902 |* *| 02903 |* Description: *| 02904 |* Depending on input, either fold two values using the passed in *| 02905 |* operator, or generate IR for the two values using the passed in *| 02906 |* operator. *| 02907 |* *| 02908 |* Input parameters: *| 02909 |* *op1 Pointer to the first operator. *| 02910 |* *op2 Pointer to the first operator. *| 02911 |* opr Operator to use for the calculation. *| 02912 |* *| 02913 |* Output parameters: *| 02914 |* *result Pointer to the result. *| 02915 |* *| 02916 |* Returns: *| 02917 |* TRUE if calculation folded okay or was created ok. *| 02918 |* *| 02919 \******************************************************************************/ 02920 boolean size_offset_binary_calc(size_offset_type *op1, 02921 size_offset_type *op2, 02922 operator_type opr, 02923 size_offset_type *result) 02924 02925 { 02926 long_type *constant1; 02927 long_type *constant2; 02928 int i; 02929 int ir_idx; 02930 boolean ok; 02931 opnd_type opnd1; 02932 opnd_type opnd2; 02933 boolean symbolic_constant = FALSE; 02934 int type_idx; 02935 int type1_idx; 02936 int type2_idx; 02937 long_type result_long[MAX_WORDS_FOR_INTEGER]; 02938 02939 02940 TRACE (Func_Entry, "size_offset_binary_calc", NULL); 02941 02942 switch ((*op1).fld) { 02943 case NO_Tbl_Idx: 02944 constant1 = &((*op1).constant[0]); 02945 type1_idx = (*op1).type_idx; 02946 break; 02947 02948 case CN_Tbl_Idx: 02949 constant1 = &(CN_CONST((*op1).idx)); 02950 type1_idx = CN_TYPE_IDX((*op1).idx); 02951 break; 02952 02953 case AT_Tbl_Idx: 02954 constant1 = NULL; 02955 type1_idx = ATD_TYPE_IDX((*op1).idx); 02956 symbolic_constant = (AT_OBJ_CLASS((*op1).idx) == Data_Obj) && 02957 ATD_SYMBOLIC_CONSTANT((*op1).idx); 02958 break; 02959 02960 case IR_Tbl_Idx: 02961 constant1 = NULL; 02962 type1_idx = IR_TYPE_IDX((*op1).idx); 02963 break; 02964 02965 default: /* IL_Tbl_Idx and SH_Tbl_Idx -> Shouldn't be, but just in case. */ 02966 02967 constant1 = NULL; 02968 type1_idx = SA_INTEGER_DEFAULT_TYPE; 02969 break; 02970 02971 } /* End switch */ 02972 02973 02974 switch ((*op2).fld) { 02975 case NO_Tbl_Idx: 02976 constant2 = &((*op2).constant[0]); 02977 type2_idx = (*op2).type_idx; 02978 break; 02979 02980 case CN_Tbl_Idx: 02981 constant2 = &(CN_CONST((*op2).idx)); 02982 type2_idx = CN_TYPE_IDX((*op2).idx); 02983 break; 02984 02985 case AT_Tbl_Idx: 02986 constant2 = NULL; 02987 type2_idx = ATD_TYPE_IDX((*op2).idx); 02988 symbolic_constant |= (AT_OBJ_CLASS((*op2).idx) == Data_Obj) && 02989 ATD_SYMBOLIC_CONSTANT((*op2).idx); 02990 break; 02991 02992 case IR_Tbl_Idx: 02993 constant2 = NULL; 02994 type2_idx = IR_TYPE_IDX((*op2).idx); 02995 break; 02996 02997 default: /* IL_Tbl_Idx and SH_Tbl_Idx -> Shouldn't be, but just in case. */ 02998 02999 constant2 = NULL; 03000 type2_idx = SA_INTEGER_DEFAULT_TYPE; 03001 break; 03002 03003 } /* End switch */ 03004 03005 03006 if (constant1 != NULL && constant2 != NULL) { 03007 type_idx = (TYP_LINEAR(type2_idx) > TYP_LINEAR(type1_idx)) ? type2_idx : 03008 type1_idx; 03009 03010 issue_overflow_msg_719 = FALSE; 03011 03012 ok = folder_driver((char *) constant1, 03013 type1_idx, 03014 (char *) constant2, 03015 type2_idx, 03016 result_long, 03017 &type_idx, 03018 stmt_start_line, 03019 stmt_start_col, 03020 2, 03021 opr); 03022 03023 if (need_to_issue_719) { 03024 03025 if (TYP_LINEAR(type_idx) < LARGEST_INTEGER_TYPE) { 03026 need_to_issue_719 = FALSE; 03027 type_idx = LARGEST_INTEGER_TYPE; 03028 ok |= folder_driver((char *) constant1, 03029 type1_idx, 03030 (char *) constant2, 03031 type2_idx, 03032 result_long, 03033 &type_idx, 03034 stmt_start_line, 03035 stmt_start_col, 03036 2, 03037 opr); 03038 } 03039 03040 if (need_to_issue_719) { 03041 PRINTMSG(stmt_start_line, 1175, Error, stmt_start_col); 03042 need_to_issue_719 = FALSE; 03043 } 03044 } 03045 03046 for (i = 0; i < MAX_WORDS_FOR_INTEGER; i++) { 03047 (*result).constant[i] = result_long[i]; 03048 } 03049 03050 (*result).type_idx = type_idx; 03051 (*result).fld = NO_Tbl_Idx; 03052 issue_overflow_msg_719 = TRUE; 03053 } 03054 else { 03055 03056 /* One or the other may be constant, but not both. */ 03057 /* But to generate IR we need both as table indexes. */ 03058 03059 if ((*op1).fld == NO_Tbl_Idx) { 03060 (*op1).idx = ntr_const_tbl((*op1).type_idx, FALSE, (*op1).constant); 03061 (*op1).fld = CN_Tbl_Idx; 03062 } 03063 else if ((*op2).fld == NO_Tbl_Idx) { 03064 (*op2).idx = ntr_const_tbl((*op2).type_idx, FALSE, (*op2).constant); 03065 (*op2).fld = CN_Tbl_Idx; 03066 } 03067 03068 OPND_FLD(opnd1) = (*op1).fld; 03069 OPND_IDX(opnd1) = (*op1).idx; 03070 OPND_LINE_NUM(opnd1) = stmt_start_line; 03071 OPND_COL_NUM(opnd1) = stmt_start_col; 03072 03073 OPND_FLD(opnd2) = (*op2).fld; 03074 OPND_IDX(opnd2) = (*op2).idx; 03075 OPND_LINE_NUM(opnd2) = stmt_start_line; 03076 OPND_COL_NUM(opnd2) = stmt_start_col; 03077 03078 if (!symbolic_constant) { 03079 type1_idx = check_type_for_size_address(&opnd1); 03080 type2_idx = check_type_for_size_address(&opnd2); 03081 } 03082 03083 type_idx = (TYP_LINEAR(type2_idx) > TYP_LINEAR(type1_idx)) ? type2_idx : 03084 type1_idx; 03085 03086 NTR_IR_TBL(ir_idx); 03087 IR_TYPE_IDX(ir_idx) = type_idx; 03088 IR_LINE_NUM_L(ir_idx) = stmt_start_line; 03089 IR_LINE_NUM_R(ir_idx) = stmt_start_line; 03090 IR_LINE_NUM(ir_idx) = stmt_start_line; 03091 IR_COL_NUM_L(ir_idx) = stmt_start_col; 03092 IR_COL_NUM_R(ir_idx) = stmt_start_col; 03093 IR_COL_NUM(ir_idx) = stmt_start_col; 03094 IR_FLD_L(ir_idx) = OPND_FLD(opnd1); 03095 IR_IDX_L(ir_idx) = OPND_IDX(opnd1); 03096 IR_FLD_R(ir_idx) = OPND_FLD(opnd2); 03097 IR_IDX_R(ir_idx) = OPND_IDX(opnd2); 03098 03099 if (symbolic_constant) { 03100 03101 switch(opr) { 03102 case Plus_Opr: 03103 opr = Symbolic_Plus_Opr; 03104 break; 03105 03106 case Div_Opr: 03107 opr = Symbolic_Div_Opr; 03108 break; 03109 03110 case Mult_Opr: 03111 opr = Symbolic_Mult_Opr; 03112 break; 03113 03114 case Minus_Opr: 03115 opr = Symbolic_Minus_Opr; 03116 break; 03117 03118 case Mod_Opr: 03119 opr = Symbolic_Mod_Opr; 03120 break; 03121 03122 case Shiftl_Opr: 03123 opr = Symbolic_Shiftl_Opr; 03124 break; 03125 03126 case Shiftr_Opr: 03127 opr = Symbolic_Shiftr_Opr; 03128 break; 03129 } 03130 03131 (*result).fld = AT_Tbl_Idx; 03132 (*result).idx = gen_compiler_tmp(stmt_start_line, stmt_start_col, 03133 Priv, TRUE); 03134 03135 ATD_TYPE_IDX((*result).idx) = INTEGER_DEFAULT_TYPE; 03136 ATD_FLD((*result).idx) = IR_Tbl_Idx; 03137 ATD_TMP_IDX((*result).idx) = ir_idx; 03138 ATD_SYMBOLIC_CONSTANT((*result).idx) = TRUE; 03139 } 03140 else { 03141 (*result).idx = ir_idx; 03142 (*result).fld = IR_Tbl_Idx; 03143 } 03144 03145 IR_OPR(ir_idx) = opr; 03146 ok = TRUE; 03147 } 03148 03149 TRACE (Func_Exit, "size_offset_binary_calc", NULL); 03150 03151 return(ok); 03152 03153 } /* size_offset_binary_calc */ 03154 03155 03156 /******************************************************************************\ 03157 |* *| 03158 |* Description: *| 03159 |* Depending on input, either fold two values using the passed in *| 03160 |* operator, or generate IR for the two values using the passed in *| 03161 |* operator. *| 03162 |* *| 03163 |* Input parameters: *| 03164 |* *op1 Pointer to the first operator. *| 03165 |* *op2 Pointer to the first operator. *| 03166 |* opr Operator to use for the calculation. *| 03167 |* *| 03168 |* Output parameters: *| 03169 |* *result Pointer to the result. *| 03170 |* *| 03171 |* Returns: *| 03172 |* TRUE if calculation folded okay or was created ok. *| 03173 |* *| 03174 \******************************************************************************/ 03175 boolean size_offset_logical_calc(size_offset_type *op1, 03176 size_offset_type *op2, 03177 operator_type opr, 03178 size_offset_type *result) 03179 03180 { 03181 long_type *constant1; 03182 long_type *constant2; 03183 int ir_idx; 03184 boolean ok; 03185 int type_idx; 03186 int type1_idx; 03187 int type2_idx; 03188 03189 03190 TRACE (Func_Entry, "size_offset_logical_calc", NULL); 03191 03192 switch ((*op1).fld) { 03193 case NO_Tbl_Idx: 03194 constant1 = &((*op1).constant[0]); 03195 type1_idx = (*op1).type_idx; 03196 break; 03197 03198 case CN_Tbl_Idx: 03199 constant1 = &(CN_CONST((*op1).idx)); 03200 type1_idx = CN_TYPE_IDX((*op1).idx); 03201 break; 03202 03203 case AT_Tbl_Idx: 03204 constant1 = NULL; 03205 type1_idx = ATD_TYPE_IDX((*op1).idx); 03206 break; 03207 03208 case IR_Tbl_Idx: 03209 constant1 = NULL; 03210 type1_idx = IR_TYPE_IDX((*op1).idx); 03211 break; 03212 03213 default: /* IL_Tbl_Idx and SH_Tbl_Idx -> Shouldn't be, but just in case. */ 03214 03215 constant1 = NULL; 03216 type1_idx = CG_INTEGER_DEFAULT_TYPE; 03217 break; 03218 03219 } /* End switch */ 03220 03221 03222 switch ((*op2).fld) { 03223 case NO_Tbl_Idx: 03224 constant2 = &((*op2).constant[0]); 03225 type2_idx = (*op2).type_idx; 03226 break; 03227 03228 case CN_Tbl_Idx: 03229 constant2 = &(CN_CONST((*op2).idx)); 03230 type2_idx = CN_TYPE_IDX((*op2).idx); 03231 break; 03232 03233 case AT_Tbl_Idx: 03234 constant2 = NULL; 03235 type2_idx = ATD_TYPE_IDX((*op2).idx); 03236 break; 03237 03238 case IR_Tbl_Idx: 03239 constant2 = NULL; 03240 type2_idx = IR_TYPE_IDX((*op2).idx); 03241 break; 03242 03243 default: /* IL_Tbl_Idx and SH_Tbl_Idx -> Shouldn't be, but just in case. */ 03244 03245 constant2 = NULL; 03246 type2_idx = CG_INTEGER_DEFAULT_TYPE; 03247 break; 03248 03249 } /* End switch */ 03250 03251 type_idx = CG_LOGICAL_DEFAULT_TYPE; 03252 03253 if (constant1 != NULL && constant2 != NULL) { 03254 03255 ok = folder_driver((char *) constant1, 03256 type1_idx, 03257 (char *) constant2, 03258 type2_idx, 03259 (*result).constant, 03260 &type_idx, 03261 stmt_start_line, 03262 stmt_start_col, 03263 2, 03264 opr); 03265 03266 (*result).type_idx = type_idx; 03267 (*result).fld = NO_Tbl_Idx; 03268 } 03269 else { 03270 03271 /* One or the other may be constant, but not both. */ 03272 /* But to generate IR we need both as table indexes. */ 03273 03274 if ((*op1).fld == NO_Tbl_Idx) { 03275 (*op1).idx = ntr_const_tbl((*op1).type_idx, FALSE, (*op1).constant); 03276 (*op1).fld = CN_Tbl_Idx; 03277 } 03278 else if ((*op2).fld == NO_Tbl_Idx) { 03279 (*op2).idx = ntr_const_tbl((*op2).type_idx, FALSE, (*op2).constant); 03280 (*op2).fld = CN_Tbl_Idx; 03281 } 03282 03283 NTR_IR_TBL(ir_idx); 03284 03285 IR_TYPE_IDX(ir_idx) = type_idx; 03286 IR_LINE_NUM_L(ir_idx) = stmt_start_line; 03287 IR_LINE_NUM_R(ir_idx) = stmt_start_line; 03288 IR_LINE_NUM(ir_idx) = stmt_start_line; 03289 IR_COL_NUM_L(ir_idx) = stmt_start_col; 03290 IR_COL_NUM_R(ir_idx) = stmt_start_col; 03291 IR_COL_NUM(ir_idx) = stmt_start_col; 03292 IR_OPR(ir_idx) = opr; 03293 IR_IDX_L(ir_idx) = (*op1).idx; 03294 IR_FLD_L(ir_idx) = (*op1).fld; 03295 IR_IDX_R(ir_idx) = (*op2).idx; 03296 IR_FLD_R(ir_idx) = (*op2).fld; 03297 03298 (*result).idx = ir_idx; 03299 (*result).fld = IR_Tbl_Idx; 03300 ok = TRUE; 03301 } 03302 03303 TRACE (Func_Exit, "size_offset_logical_calc", NULL); 03304 03305 return(ok); 03306 03307 } /* size_offset_logical_calc */ 03308 03309 03310 /******************************************************************************\ 03311 |* *| 03312 |* Description: *| 03313 |* Depending on input, either fold the list of values using the Min_Opr *| 03314 |* or generate IR for the list of values using the Min_Opr. *| 03315 |* *| 03316 |* Input parameters: *| 03317 |* *op1 Pointer to the first operator. *| 03318 |* *op2 Pointer to the first operator. *| 03319 |* *| 03320 |* Output parameters: *| 03321 |* *result Pointer to the result. *| 03322 |* *| 03323 |* Returns: *| 03324 |* TRUE if calculation folded okay or was created ok. *| 03325 |* *| 03326 \******************************************************************************/ 03327 boolean size_offset_min_max_calc(size_offset_type *op1, 03328 size_offset_type *op2, 03329 operator_type operator, 03330 size_offset_type *result) 03331 03332 { 03333 long_type *constant1; 03334 long_type *constant2; 03335 int il_idx; 03336 int il_idx2; 03337 int ir_idx; 03338 boolean ok; 03339 opnd_type opnd1; 03340 opnd_type opnd2; 03341 boolean symbolic_constant; 03342 int type_idx; 03343 int type1_idx; 03344 int type2_idx; 03345 03346 03347 TRACE (Func_Entry, "size_offset_min_calc", NULL); 03348 03349 switch ((*op1).fld) { 03350 case NO_Tbl_Idx: 03351 constant1 = &((*op1).constant[0]); 03352 type1_idx = (*op1).type_idx; 03353 break; 03354 03355 case CN_Tbl_Idx: 03356 constant1 = &(CN_CONST((*op1).idx)); 03357 type1_idx = CN_TYPE_IDX((*op1).idx); 03358 break; 03359 03360 case AT_Tbl_Idx: 03361 constant1 = NULL; 03362 type1_idx = ATD_TYPE_IDX((*op1).idx); 03363 symbolic_constant = (AT_OBJ_CLASS((*op1).idx) == Data_Obj) && 03364 ATD_SYMBOLIC_CONSTANT((*op1).idx); 03365 break; 03366 03367 case IR_Tbl_Idx: 03368 constant1 = NULL; 03369 type1_idx = IR_TYPE_IDX((*op1).idx); 03370 break; 03371 03372 default: /* IL_Tbl_Idx and SH_Tbl_Idx -> Shouldn't be, but just in case. */ 03373 03374 constant1 = NULL; 03375 type1_idx = CG_INTEGER_DEFAULT_TYPE; 03376 break; 03377 03378 } /* End switch */ 03379 03380 03381 switch ((*op2).fld) { 03382 case NO_Tbl_Idx: 03383 constant2 = &((*op2).constant[0]); 03384 type2_idx = (*op2).type_idx; 03385 break; 03386 03387 case CN_Tbl_Idx: 03388 constant2 = &(CN_CONST((*op2).idx)); 03389 type2_idx = CN_TYPE_IDX((*op2).idx); 03390 break; 03391 03392 case AT_Tbl_Idx: 03393 constant2 = NULL; 03394 type2_idx = ATD_TYPE_IDX((*op2).idx); 03395 symbolic_constant |= (AT_OBJ_CLASS((*op2).idx) == Data_Obj) && 03396 ATD_SYMBOLIC_CONSTANT((*op2).idx); 03397 break; 03398 03399 case IR_Tbl_Idx: 03400 constant2 = NULL; 03401 type2_idx = IR_TYPE_IDX((*op2).idx); 03402 break; 03403 03404 default: /* IL_Tbl_Idx and SH_Tbl_Idx -> Shouldn't be, but just in case. */ 03405 constant2 = NULL; 03406 type2_idx = CG_INTEGER_DEFAULT_TYPE; 03407 break; 03408 03409 } /* End switch */ 03410 03411 if (constant1 != NULL && constant2 != NULL) { 03412 type_idx = CG_LOGICAL_DEFAULT_TYPE; 03413 03414 ok = folder_driver((char *) constant1, 03415 type1_idx, 03416 (char *) constant2, 03417 type2_idx, 03418 (*result).constant, 03419 &type_idx, 03420 stmt_start_line, 03421 stmt_start_col, 03422 2, 03423 Lt_Opr); 03424 03425 if (THIS_IS_TRUE((*result).constant, (*result).type_idx)) { 03426 (*result) = (operator == Min_Opr) ? (*op1) : (*op2); 03427 } 03428 else { 03429 (*result) = (operator == Min_Opr) ? (*op2) : (*op1); 03430 } 03431 } 03432 else { 03433 03434 /* One or the other may be constant, but not both. */ 03435 /* But to generate IR we need both as table indexes. */ 03436 03437 if ((*op1).fld == NO_Tbl_Idx) { 03438 (*op1).idx = ntr_const_tbl((*op1).type_idx, FALSE, (*op1).constant); 03439 (*op1).fld = CN_Tbl_Idx; 03440 } 03441 else if ((*op2).fld == NO_Tbl_Idx) { 03442 (*op2).idx = ntr_const_tbl((*op2).type_idx, FALSE, (*op2).constant); 03443 (*op2).fld = CN_Tbl_Idx; 03444 } 03445 03446 OPND_FLD(opnd1) = (*op1).fld; 03447 OPND_IDX(opnd1) = (*op1).idx; 03448 OPND_LINE_NUM(opnd1) = stmt_start_line; 03449 OPND_COL_NUM(opnd1) = stmt_start_col; 03450 03451 OPND_FLD(opnd2) = (*op2).fld; 03452 OPND_IDX(opnd2) = (*op2).idx; 03453 OPND_LINE_NUM(opnd2) = stmt_start_line; 03454 OPND_COL_NUM(opnd2) = stmt_start_col; 03455 03456 if (!symbolic_constant) { 03457 type1_idx = check_type_for_size_address(&opnd1); 03458 type2_idx = check_type_for_size_address(&opnd2); 03459 } 03460 03461 type_idx = (TYP_LINEAR(type2_idx) > TYP_LINEAR(type1_idx)) ? type2_idx : 03462 type1_idx; 03463 03464 NTR_IR_TBL(ir_idx); 03465 03466 IR_TYPE_IDX(ir_idx) = type_idx; 03467 IR_LINE_NUM(ir_idx) = stmt_start_line; 03468 IR_COL_NUM(ir_idx) = stmt_start_col; 03469 03470 if (operator == Min_Opr) { 03471 IR_OPR(ir_idx) = (symbolic_constant) ? Symbolic_Min_Opr : 03472 Min_Opr; 03473 } 03474 else { 03475 IR_OPR(ir_idx) = (symbolic_constant) ? Symbolic_Max_Opr : 03476 Max_Opr; 03477 } 03478 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 03479 IR_LIST_CNT_L(ir_idx) = 2; 03480 03481 NTR_IR_LIST_TBL(il_idx); 03482 IL_LINE_NUM(il_idx) = stmt_start_line; 03483 IL_COL_NUM(il_idx) = stmt_start_col; 03484 IL_FLD(il_idx) = OPND_FLD(opnd1); 03485 IL_IDX(il_idx) = OPND_IDX(opnd1); 03486 03487 IR_IDX_L(ir_idx) = il_idx; 03488 03489 NTR_IR_LIST_TBL(il_idx2); 03490 IL_LINE_NUM(il_idx2) = stmt_start_line; 03491 IL_COL_NUM(il_idx2) = stmt_start_col; 03492 IL_FLD(il_idx2) = OPND_FLD(opnd2); 03493 IL_IDX(il_idx2) = OPND_IDX(opnd2); 03494 IL_PREV_LIST_IDX(il_idx2) = il_idx; 03495 03496 IL_NEXT_LIST_IDX(il_idx) = il_idx2; 03497 03498 (*result).idx = ir_idx; 03499 (*result).fld = IR_Tbl_Idx; 03500 ok = TRUE; 03501 } 03502 03503 TRACE (Func_Exit, "size_offset_min_calc", NULL); 03504 03505 return(ok); 03506 03507 } /* size_offset_min_calc */ 03508 03509 /******************************************************************************\ 03510 |* *| 03511 |* Description: *| 03512 |* The following routine makes sure that integer constant *| 03513 |* entries can be used in 'C' arithmetic and comparison. *| 03514 |* *| 03515 |* Input parameters: *| 03516 |* NONE *| 03517 |* *| 03518 |* Output parameters: *| 03519 |* NONE *| 03520 |* *| 03521 |* Returns: *| 03522 |* NOTHING *| 03523 |* *| 03524 \******************************************************************************/ 03525 03526 long64 f_int_to_cval(long_type *the_constant, 03527 int lin_type) 03528 03529 { 03530 int i; 03531 long_type input[MAX_WORDS_FOR_INTEGER]; 03532 long64 result; 03533 03534 03535 TRACE (Func_Entry, "f_int_to_cval", NULL); 03536 03537 for (i = 0; i < num_host_wds[TYP_LINEAR(lin_type)]; i++) { 03538 input[i] = the_constant[i]; 03539 } 03540 03541 SHIFT_ARITH_ARG(input, lin_type); 03542 03543 i = AR_convert_int_to_host_sint64((AR_HOST_SINT64 *) &result, 03544 (const AR_DATA *) &input, 03545 (const AR_TYPE *) &linear_to_arith[lin_type]); 03546 03547 TRACE (Func_Exit, "f_int_to_cval", NULL); 03548 03549 return(result); 03550 03551 } /* f_int_to_cval */ 03552 03553 /******************************************************************************\ 03554 |* *| 03555 |* Description: *| 03556 |* The following routine makes sure that a 'C' constant translates back *| 03557 |* to a target constant. This is used where host and target *| 03558 |* representation of constants is not the same. Endian and host/target *| 03559 |* sizes differing are two examples of where this is used. It is the *| 03560 |* underlying routine used by the macro. C_TO_F_INT *| 03561 |* Use the macro - do not use this routine directly, as on most *| 03562 |* platforms, this much overhead is not necessary. *| 03563 |* *| 03564 |* Input parameters: *| 03565 |* NONE *| 03566 |* *| 03567 |* Output parameters: *| 03568 |* NONE *| 03569 |* *| 03570 |* Returns: *| 03571 |* NOTHING *| 03572 |* *| 03573 \******************************************************************************/ 03574 int cval_to_f_int(long_type *result, 03575 long64 *the_constant, 03576 int type_idx) 03577 03578 { 03579 int lin_type; 03580 int ret; 03581 03582 03583 TRACE (Func_Entry, "cval_to_f_int", NULL); 03584 03585 lin_type = (type_idx == NULL_IDX) ? CG_INTEGER_DEFAULT_TYPE : 03586 TYP_LINEAR(type_idx); 03587 03588 ret = AR_convert_host_sint64_to_int((AR_DATA *) result, 03589 (const AR_TYPE *) &linear_to_arith[lin_type], 03590 (AR_HOST_SINT64) *the_constant); 03591 03592 03593 if (ret == AR_STAT_OVERFLOW) { /* Overflowed specified type */ 03594 03595 if (type_idx == NULL_IDX && 03596 CG_INTEGER_DEFAULT_TYPE < LARGEST_INTEGER_TYPE) { 03597 lin_type = LARGEST_INTEGER_TYPE; 03598 ret = AR_convert_host_sint64_to_int( 03599 (AR_DATA *) result, 03600 (const AR_TYPE *) &linear_to_arith[LARGEST_INTEGER_TYPE], 03601 (AR_HOST_SINT64) *the_constant); 03602 } 03603 03604 if (ret == AR_STAT_OVERFLOW) { /* Still overflowed */ 03605 PRINTMSG(stmt_start_line, 719, Error, stmt_start_col); 03606 lin_type = Err_Res; 03607 } 03608 else { 03609 SHIFT_ARITH_RESULT(result, lin_type); 03610 } 03611 } 03612 else { 03613 SHIFT_ARITH_RESULT(result, lin_type); 03614 } 03615 03616 TRACE (Func_Exit, "cval_to_f_int", NULL); 03617 03618 return(lin_type); 03619 03620 } /* cval_to_f_int */ 03621 03622 /******************************************************************************\ 03623 |* *| 03624 |* Description: *| 03625 |* The following routine enters a 'C' (host) integer constant into the *| 03626 |* constant table. *| 03627 |* *| 03628 |* Input parameters: *| 03629 |* NONE *| 03630 |* *| 03631 |* Output parameters: *| 03632 |* NONE *| 03633 |* *| 03634 |* Returns: *| 03635 |* NOTHING *| 03636 |* *| 03637 \******************************************************************************/ 03638 int ntr_int_const_tbl(int type_idx, 03639 long64 constant) 03640 03641 { 03642 int cn_idx; 03643 long_type the_constant[MAX_WORDS_FOR_INTEGER]; 03644 03645 # if !defined(_HOST64) || !defined(_TARGET64) 03646 int new_type; 03647 03648 # if defined(GENERATE_WHIRL) 03649 long *cn_ptr; 03650 # endif 03651 # endif 03652 03653 03654 TRACE (Func_Entry, "ntr_int_const_tbl", NULL); 03655 03656 # if defined(_HOST64) && defined(_TARGET64) 03657 03658 if (type_idx == NULL_IDX) { 03659 type_idx = CG_INTEGER_DEFAULT_TYPE; 03660 } 03661 03662 the_constant[0] = constant; 03663 03664 # elif defined(_USE_FOLD_DOT_f) 03665 if (type_idx == NULL_IDX) { 03666 type_idx = CG_INTEGER_DEFAULT_TYPE; 03667 } 03668 03669 if (TYP_LINEAR(type_idx) == Integer_8 || 03670 TYP_LINEAR(type_idx) == Typeless_8) { 03671 cn_ptr = (long *) &constant; 03672 the_constant[0] = *cn_ptr; 03673 if (MAX_WORDS_FOR_INTEGER > 1 ) 03674 the_constant[1] = *(++cn_ptr); 03675 } 03676 else { 03677 the_constant[0] = constant; 03678 if (MAX_WORDS_FOR_INTEGER > 1 ) 03679 the_constant[1] = 0; 03680 } 03681 03682 # elif defined(GENERATE_WHIRL) 03683 03684 if (type_idx == NULL_IDX) { /* Set type according to size */ 03685 new_type = cval_to_f_int(the_constant, 03686 &constant, 03687 NULL_IDX); 03688 03689 if (new_type == NULL_IDX) { /* Error situation */ 03690 type_idx = CG_INTEGER_DEFAULT_TYPE; 03691 } 03692 else { 03693 type_idx = TYP_LINEAR(new_type); 03694 } 03695 } 03696 else { /* Use type passed in */ 03697 03698 if (TYP_LINEAR(type_idx) == Integer_8 || 03699 TYP_LINEAR(type_idx) == Typeless_8) { 03700 cn_ptr = (long *) &constant; 03701 the_constant[0] = *cn_ptr; 03702 if (MAX_WORDS_FOR_INTEGER > 1 ) 03703 the_constant[1] = *(++cn_ptr); 03704 } 03705 else { 03706 the_constant[0] = (long) constant; 03707 if (MAX_WORDS_FOR_INTEGER > 1 ) 03708 the_constant[1] = 0; 03709 } 03710 } 03711 03712 # else 03713 03714 /* NOTE: type_idx may be NULL_IDX. Then we want cval_to_f_int to */ 03715 /* determine what the type_idx should be for this constant. */ 03716 03717 new_type = cval_to_f_int(the_constant, 03718 &constant, 03719 type_idx); 03720 03721 if (new_type == NULL_IDX) { /* Error situation */ 03722 type_idx = CG_INTEGER_DEFAULT_TYPE; 03723 } 03724 else { 03725 type_idx = TYP_LINEAR(new_type); 03726 } 03727 03728 # endif 03729 03730 cn_idx = ntr_const_tbl(type_idx, 03731 FALSE, 03732 the_constant); 03733 03734 TRACE (Func_Exit, "ntr_int_const_tbl", NULL); 03735 03736 return(cn_idx); 03737 03738 } /* ntr_int_const_tbl */ 03739 03740 /******************************************************************************\ 03741 |* *| 03742 |* Description: *| 03743 |* On mpp systems, the macro CN_INT_TO_C calls this routine to ensure *| 03744 |* sign extension when veiwing 32 bit ints as c ints. *| 03745 |* *| 03746 |* Input parameters: *| 03747 |* NONE *| 03748 |* *| 03749 |* Output parameters: *| 03750 |* NONE *| 03751 |* *| 03752 |* Returns: *| 03753 |* NOTHING *| 03754 |* *| 03755 \******************************************************************************/ 03756 long_type mpp_cn_int_to_c(int cn_idx) 03757 03758 { 03759 long_type the_constant; 03760 int type_idx; 03761 03762 TRACE (Func_Entry, "mpp_cn_int_to_c", NULL); 03763 03764 if (TYP_LINEAR(CN_TYPE_IDX(cn_idx)) == Integer_1 || 03765 TYP_LINEAR(CN_TYPE_IDX(cn_idx)) == Integer_2 || 03766 TYP_LINEAR(CN_TYPE_IDX(cn_idx)) == Integer_4) { 03767 03768 type_idx = CG_INTEGER_DEFAULT_TYPE; 03769 03770 if (folder_driver((char *)&CN_CONST(cn_idx), 03771 CN_TYPE_IDX(cn_idx), 03772 NULL, 03773 NULL_IDX, 03774 &the_constant, 03775 &type_idx, 03776 stmt_start_line, 03777 stmt_start_col, 03778 1, 03779 Cvrt_Opr)) { 03780 /* intentionally blank */ 03781 } 03782 } 03783 else { 03784 the_constant = CN_CONST(cn_idx); 03785 } 03786 03787 TRACE (Func_Exit, "mpp_cn_int_to_c", NULL); 03788 03789 return(the_constant); 03790 03791 } /* mpp_cn_int_to_c */ 03792 03793 /******************************************************************************\ 03794 |* *| 03795 |* Description: *| 03796 |* *| 03797 |* Input parameters: *| 03798 |* *| 03799 |* Output parameters: *| 03800 |* NONE *| 03801 |* *| 03802 |* Returns: *| 03803 |* TRUE if they are the same, else FALSE. *| 03804 |* *| 03805 \******************************************************************************/ 03806 03807 boolean compare_target_consts(long_type *const1, 03808 int type1, 03809 long_type *const2, 03810 int type2, 03811 int opr) 03812 03813 { 03814 boolean is_true; 03815 long_type result[MAX_WORDS_FOR_INTEGER]; 03816 int type_idx; 03817 03818 03819 TRACE (Func_Entry, "compare_target_consts", NULL); 03820 03821 type_idx = LOGICAL_DEFAULT_TYPE; 03822 03823 if (folder_driver((char *)const1, 03824 type1, 03825 (char *)const2, 03826 type2, 03827 result, 03828 &type_idx, 03829 stmt_start_line, 03830 stmt_start_col, 03831 2, 03832 opr)) { 03833 03834 is_true = THIS_IS_TRUE(result, type_idx); 03835 } 03836 else { 03837 is_true = FALSE; 03838 } 03839 03840 TRACE (Func_Exit, "compare_target_consts", NULL); 03841 03842 return(is_true); 03843 03844 } /* compare_target_consts */ 03845 03846 03847 # ifdef _USE_FOLD_DOT_f 03848 03849 /******************************************************************************\ 03850 |* *| 03851 |* Description: *| 03852 |* ONLY FOR THE LINUX COMPILER. USE UNTIL ARITH IS READY. *| 03853 |* *| 03854 |* Use sscanf to convert strings to host format constants for integer *| 03855 |* and real types. No error detection. *| 03856 |* *| 03857 |* Input parameters: *| 03858 |* NONE *| 03859 |* *| 03860 |* Output parameters: *| 03861 |* NONE *| 03862 |* *| 03863 |* Returns: *| 03864 |* NOTHING *| 03865 |* *| 03866 \******************************************************************************/ 03867 03868 void kludge_input_conversion (char *str, 03869 int type_idx) 03870 { 03871 int i; 03872 long_type number[MAX_WORDS_FOR_NUMERIC]; 03873 03874 for (i = 0; i < MAX_WORDS_FOR_NUMERIC; i++) { 03875 number[i] = 0; 03876 } 03877 03878 switch (TYP_LINEAR(type_idx)) { 03879 case Integer_1: 03880 case Integer_2: 03881 case Integer_4: 03882 sscanf(str, "%lu", (long *)number); 03883 break; 03884 03885 case Integer_8: 03886 sscanf(str, "%lld", (long long *)number); 03887 break; 03888 03889 case Real_4: 03890 sscanf(str, "%f", (float *)number); 03891 break; 03892 03893 case Real_8: 03894 sscanf(str, "%lf", (double *)number); 03895 break; 03896 03897 case Real_16: 03898 sscanf(str, "%Lf", (long double *)number); 03899 break; 03900 03901 default: 03902 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 03903 "Integer or Real type", "kludge_input_conversion"); 03904 break; 03905 } 03906 03907 TOKEN_CONST_TBL_IDX(token) = ntr_const_tbl(type_idx, 03908 FALSE, 03909 number); 03910 } 03911 03912 /******************************************************************************\ 03913 |* *| 03914 |* Description: *| 03915 |* ONLY FOR THE LINUX COMPILER. USE UNTIL ARITH IS READY. *| 03916 |* *| 03917 |* Use sprintf to convert host format constants to strings for integer *| 03918 |* and real types. No error detection. *| 03919 |* *| 03920 |* Input parameters: *| 03921 |* NONE *| 03922 |* *| 03923 |* Output parameters: *| 03924 |* NONE *| 03925 |* *| 03926 |* Returns: *| 03927 |* NOTHING *| 03928 |* *| 03929 \******************************************************************************/ 03930 03931 void kludge_output_conversion (long_type *the_constant, 03932 int type_idx, 03933 char *str) 03934 { 03935 03936 switch (TYP_LINEAR(type_idx)) { 03937 case Integer_1: 03938 case Integer_2: 03939 case Integer_4: 03940 sprintf(str, "%ld", *(long *)the_constant); 03941 break; 03942 03943 case Integer_8: 03944 sprintf(str, "%lld", *(long long *)the_constant); 03945 break; 03946 03947 case Real_4: 03948 sprintf(str, "%f", *(float *)the_constant); 03949 break; 03950 03951 case Real_8: 03952 sprintf(str, "%f", *(double *)the_constant); 03953 break; 03954 03955 case Real_16: 03956 sprintf(str, "%Lf", *(long double *)the_constant); 03957 break; 03958 03959 default: 03960 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 03961 "Integer or Real type", "kludge_output_conversion"); 03962 break; 03963 } 03964 } 03965 03966 # endif
1.7.6.1 
