|
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 /* Simulate library intrinsics if this module is loaded */ 00037 00038 #include <stdio.h> 00039 00040 #include "arith.internal.h" 00041 #include "int64.h" 00042 00043 #define MAX_DOPE_VECTOR_WORDS 32 00044 00045 #define CRAY_FLOAT_64 (UNROUNDED_TYPE(AR_Float_Cray1_64)) 00046 #define CRAY_FLOAT_128 (UNROUNDED_TYPE(AR_Float_Cray1_128)) 00047 #define CRAY_COMPLEX_64 (UNROUNDED_TYPE(AR_Complex_Cray1_64)) 00048 #define CRAY_COMPLEX_128 (UNROUNDED_TYPE(AR_Complex_Cray1_128)) 00049 00050 #define IEEE_FLOAT_32 (UNROUNDED_TYPE(AR_Float_IEEE_NR_32)) 00051 #define IEEE_FLOAT_64 (UNROUNDED_TYPE(AR_Float_IEEE_NR_64)) 00052 #define IEEE_FLOAT_128 (UNROUNDED_TYPE(AR_Float_IEEE_NR_128)) 00053 #define IEEE_COMPLEX_32 (UNROUNDED_TYPE(AR_Complex_IEEE_NR_32)) 00054 #define IEEE_COMPLEX_64 (UNROUNDED_TYPE(AR_Complex_IEEE_NR_64)) 00055 #define IEEE_COMPLEX_128 (UNROUNDED_TYPE(AR_Complex_IEEE_NR_128)) 00056 00057 /* Declarations of simulation support functions */ 00058 00059 extern int ar_ext_address(AR_INT_64 *intaddr, const void *extaddr, int nwords); 00060 00061 extern int ar_pass_arg_address(const ar_data *arg, const AR_TYPE *argtype); 00062 00063 extern int ar_pass_ext_address(AR_INT_64 *intaddr, const void *extaddr, int nwords); 00064 00065 extern int ar_pass_fcd_address(const char *str, long lenstr); 00066 00067 extern int ar_pass_arg_value(const ar_data *arg, const AR_TYPE *argtype); 00068 00069 extern int ar_put_real_address(AR_INT_64 *intaddr); 00070 00071 extern int ar_get_function_value(ar_data *result, const AR_TYPE *resulttype); 00072 00073 extern int ar_sim(char* function_name); 00074 00075 00076 /* Fortran character index */ 00077 int 00078 ar_index (ar_data *result, const AR_TYPE *resulttype, 00079 const char *str1, long len1, const char *str2, long len2, long backward) 00080 { 00081 int status; 00082 AR_TYPE type = AR_Logical; 00083 00084 status = ar_clear_sim_state(*resulttype); 00085 status |= ar_pass_fcd_address(str1, len1); 00086 status |= ar_pass_fcd_address(str2, len2); 00087 if(backward) 00088 status |= ar_pass_arg_address((ar_data*)&AR_const_true, &type); 00089 else 00090 status |= ar_pass_arg_address((ar_data*)&AR_const_false, &type); 00091 if(IS_ERROR_STATUS(status)) 00092 return status; 00093 00094 switch (*resulttype) { 00095 00096 case AR_Int_32_S: 00097 status = ar_sim("indexi"); 00098 break; 00099 00100 case AR_Int_46_S: 00101 case AR_Int_64_S: 00102 status = ar_sim("index"); 00103 break; 00104 00105 default: 00106 return AR_STAT_INVALID_TYPE; 00107 } 00108 00109 status &= AR_ERROR_STATUS; 00110 if(status) 00111 return status; 00112 00113 return ar_get_function_value(result, resulttype); 00114 } 00115 00116 00117 /* Fortran character scan */ 00118 int 00119 ar_scan (ar_data *result, const AR_TYPE *resulttype, 00120 const char *str1, long len1, const char *str2, long len2, long backward) 00121 { 00122 int status; 00123 AR_TYPE type = AR_Logical; 00124 00125 status = ar_clear_sim_state(*resulttype); 00126 status |= ar_pass_fcd_address(str1, len1); 00127 status |= ar_pass_fcd_address(str2, len2); 00128 if(backward) 00129 status |= ar_pass_arg_address((ar_data*)&AR_const_true, &type); 00130 else 00131 status |= ar_pass_arg_address((ar_data*)&AR_const_false, &type); 00132 if(IS_ERROR_STATUS(status)) 00133 return status; 00134 00135 switch (*resulttype) { 00136 00137 case AR_Int_32_S: 00138 status = ar_sim("scani"); 00139 break; 00140 00141 case AR_Int_46_S: 00142 case AR_Int_64_S: 00143 status = ar_sim("scan"); 00144 break; 00145 00146 default: 00147 return AR_STAT_INVALID_TYPE; 00148 } 00149 00150 status &= AR_ERROR_STATUS; 00151 if(status) 00152 return status; 00153 00154 return ar_get_function_value(result, resulttype); 00155 } 00156 00157 00158 /* Fortran character verify */ 00159 int 00160 ar_verify (ar_data *result, const AR_TYPE *resulttype, 00161 const char *str1, long len1, const char *str2, long len2, long backward) 00162 { 00163 int status; 00164 AR_TYPE type = AR_Logical; 00165 00166 status = ar_clear_sim_state(*resulttype); 00167 status |= ar_pass_fcd_address(str1, len1); 00168 status |= ar_pass_fcd_address(str2, len2); 00169 if(backward) 00170 status |= ar_pass_arg_address((ar_data*)&AR_const_true, &type); 00171 else 00172 status |= ar_pass_arg_address((ar_data*)&AR_const_false, &type); 00173 if(IS_ERROR_STATUS(status)) 00174 return status; 00175 00176 switch (*resulttype) { 00177 00178 case AR_Int_32_S: 00179 status = ar_sim("verifyi"); 00180 break; 00181 00182 case AR_Int_46_S: 00183 case AR_Int_64_S: 00184 status = ar_sim("verify"); 00185 break; 00186 00187 default: 00188 return AR_STAT_INVALID_TYPE; 00189 } 00190 00191 status &= AR_ERROR_STATUS; 00192 if(status) 00193 return status; 00194 00195 return ar_get_function_value(result, resulttype); 00196 } 00197 00198 00199 /* Fortran-90 reshape */ 00200 int 00201 ar_reshape (void *result, const void *source, const void *shape, 00202 const void *pad, const void *order) 00203 { 00204 int status; 00205 00206 char* addr; 00207 00208 long long resfcd1; 00209 long long srcfcd1; 00210 long long shpfcd1; 00211 00212 AR_INT_64 extaddr; 00213 00214 /* Grab the 1st word which is always the 1st word of an fcd */ 00215 memcpy((char*)&resfcd1, (char*)result, 8); 00216 memcpy((char*)&srcfcd1, (char*)source, 8); 00217 memcpy((char*)&shpfcd1, (char*)shape, 8); 00218 00219 if(srcfcd1 == 0 || shpfcd1 == 0) 00220 return AR_STAT_UNDEFINED; 00221 00222 status = ar_clear_sim_state(AR_Int_64_S); 00223 00224 /* If result baseaddr is not NULL, replace it with an ext addr desc */ 00225 if(resfcd1 != 0) { 00226 memcpy((char*)&addr, (char*)&resfcd1 + sizeof(long long) - 00227 sizeof(char*), sizeof(char*)); 00228 ar_ext_address(&extaddr, (const void*)addr, 0x7ffffff); 00229 if(extaddr.part2) 00230 memcpy((char*)result, (char*)&extaddr, 8); 00231 else 00232 memcpy((char*)result+4, (char*)(&extaddr)+4, 4); 00233 } 00234 status |= ar_pass_ext_address(NULL, (const void*)result, MAX_DOPE_VECTOR_WORDS); 00235 00236 /* Replace baseaddr in source dope vector with an ext addr descriptor */ 00237 memcpy((char*)&addr, (char*)&srcfcd1 + sizeof(long long) - 00238 sizeof(char*), sizeof(char*)); 00239 ar_ext_address(&extaddr, (const void*)addr, 0x7ffffff); 00240 if(extaddr.part2) 00241 memcpy((char*)source, (char*)&extaddr, 8); 00242 else 00243 memcpy((char*)source+4, (char*)(&extaddr)+4, 4); 00244 status |= ar_pass_ext_address(NULL, source, MAX_DOPE_VECTOR_WORDS); 00245 00246 /* Replace baseaddr in shape dope vector with an ext addr descriptor */ 00247 memcpy((char*)&addr, (char*)&shpfcd1 + sizeof(long long) - 00248 sizeof(char*), sizeof(char*)); 00249 ar_ext_address(&extaddr, (const void*)addr, 0x7ffffff); 00250 if(extaddr.part2) 00251 memcpy((char*)shape, (char*)&extaddr, 8); 00252 else 00253 memcpy((char*)shape+4, (char*)(&extaddr)+4, 4); 00254 status |= ar_pass_ext_address(NULL, shape, MAX_DOPE_VECTOR_WORDS); 00255 00256 /* Replace baseaddr in pad dope vector with an ext addr descriptor */ 00257 if(pad != NULL) { 00258 memcpy((char*)&addr, (char*)pad + sizeof(long long) - 00259 sizeof(char*), sizeof(char*)); 00260 ar_ext_address(&extaddr, (const void*)addr, 0x7ffffff); 00261 if(extaddr.part2) 00262 memcpy((char*)pad, (char*)&extaddr, 8); 00263 else 00264 memcpy((char*)pad+4, (char*)(&extaddr)+4, 4); 00265 } 00266 status |= ar_pass_ext_address(NULL, pad, MAX_DOPE_VECTOR_WORDS); 00267 00268 /* Replace baseaddr in order dope vector with an ext addr descriptor */ 00269 if(order != NULL) { 00270 memcpy((char*)&addr, (char*)order + sizeof(long long) - 00271 sizeof(char*), sizeof(char*)); 00272 ar_ext_address(&extaddr, (const void*)addr, 0x7ffffff); 00273 if(extaddr.part2) 00274 memcpy((char*)order, (char*)&extaddr, 8); 00275 else 00276 memcpy((char*)order+4, (char*)(&extaddr)+4, 4); 00277 } 00278 status |= ar_pass_ext_address(NULL, order, MAX_DOPE_VECTOR_WORDS); 00279 00280 if(IS_ERROR_STATUS(status)) 00281 return status; 00282 00283 status = ar_sim("reshape"); 00284 00285 /* Restore baseaddr fields in dope vectors */ 00286 memcpy((char*)source, (char*)&srcfcd1, 8); 00287 memcpy((char*)shape, (char*)&shpfcd1, 8); 00288 00289 if(IS_ERROR_STATUS(status)) 00290 return status; 00291 00292 return ar_put_real_address((AR_INT_64*)result); 00293 } 00294 00295 00296 /* Fortran-90 transfer */ 00297 int 00298 ar_transfer (void *result, const void *source, const void *mold, long *size) 00299 { 00300 int status; 00301 00302 char* addr; 00303 00304 long long resfcd1; 00305 long long srcfcd1; 00306 long long mldfcd1; 00307 00308 AR_INT_64 extaddr; 00309 AR_INT_64 length; 00310 00311 AR_TYPE inttype = AR_Int_64_S; 00312 00313 /* Grab the 1st word which is always the 1st word of an fcd */ 00314 memcpy((char*)&resfcd1, (char*)result, 8); 00315 memcpy((char*)&srcfcd1, (char*)source, 8); 00316 memcpy((char*)&mldfcd1, (char*)mold, 8); 00317 00318 if(srcfcd1 == 0 || mldfcd1 == 0) 00319 return AR_STAT_UNDEFINED; 00320 00321 status = ar_clear_sim_state(AR_Int_64_S); 00322 00323 /* If result baseaddr is not NULL, replace it with an ext addr desc */ 00324 if(resfcd1 != 0) { 00325 memcpy((char*)&addr, (char*)&resfcd1 + sizeof(long long) - 00326 sizeof(char*), sizeof(char*)); 00327 ar_ext_address(&extaddr, (const void*)addr, 0x7ffffff); 00328 if(extaddr.part2) 00329 memcpy((char*)result, (char*)&extaddr, 8); 00330 else 00331 memcpy((char*)result+4, (char*)(&extaddr)+4, 4); 00332 } 00333 status |= ar_pass_ext_address(NULL, (const void*)result, MAX_DOPE_VECTOR_WORDS); 00334 00335 /* Replace baseaddr in source dope vector with an ext addr descriptor */ 00336 memcpy((char*)&addr, (char*)&srcfcd1 + sizeof(long long) - 00337 sizeof(char*), sizeof(char*)); 00338 ar_ext_address(&extaddr, (const void*)addr, 0x7ffffff); 00339 if(extaddr.part2) 00340 memcpy((char*)source, (char*)&extaddr, 8); 00341 else 00342 memcpy((char*)source+4, (char*)(&extaddr)+4, 4); 00343 status |= ar_pass_ext_address(NULL, source, MAX_DOPE_VECTOR_WORDS); 00344 00345 /* Replace baseaddr in mold dope vector with an ext addr descriptor */ 00346 memcpy((char*)&addr, (char*)&mldfcd1 + sizeof(long long) - 00347 sizeof(char*), sizeof(char*)); 00348 ar_ext_address(&extaddr, (const void*)addr, 0x7ffffff); 00349 if(extaddr.part2) 00350 memcpy((char*)mold, (char*)&extaddr, 8); 00351 else 00352 memcpy((char*)mold+4, (char*)(&extaddr)+4, 4); 00353 status |= ar_pass_ext_address(NULL, mold, MAX_DOPE_VECTOR_WORDS); 00354 00355 if(size != NULL) { 00356 length.part1 = length.part2 = 0; 00357 length.part3 = *size>>16; 00358 length.part4 = *size & 0xffff; 00359 status |= ar_pass_arg_address((ar_data*)&length, &inttype); 00360 } 00361 else 00362 status |= ar_pass_arg_address((ar_data*)size, &inttype); 00363 00364 if(IS_ERROR_STATUS(status)) 00365 return status; 00366 00367 status = ar_sim("transfer"); 00368 00369 /* Restore baseaddr fields in dope vectors */ 00370 memcpy((char*)source, (char*)&srcfcd1, 8); 00371 memcpy((char*)mold, (char*)&mldfcd1, 8); 00372 00373 if(IS_ERROR_STATUS(status)) 00374 return status; 00375 00376 return ar_put_real_address((AR_INT_64*)result); 00377 } 00378 00379 00380 /* Fortran-90 modulo */ 00381 int 00382 ar_modulo (ar_data *result, const AR_TYPE *resulttype, 00383 const ar_data *opnd1, const AR_TYPE *opnd1type, 00384 const ar_data *opnd2, const AR_TYPE *opnd2type) { 00385 00386 int status; 00387 00388 status = ar_clear_sim_state(*resulttype); 00389 status |= ar_pass_arg_address(opnd1, opnd1type); 00390 status |= ar_pass_arg_address(opnd2, opnd2type); 00391 if(IS_ERROR_STATUS(status)) 00392 return status; 00393 00394 switch (UNROUNDED_TYPE(*resulttype)) { 00395 00396 case IEEE_FLOAT_32: 00397 status = ar_sim("modulof"); 00398 break; 00399 00400 case CRAY_FLOAT_64: 00401 case IEEE_FLOAT_64: 00402 status = ar_sim("modulos"); 00403 break; 00404 00405 case CRAY_FLOAT_128: 00406 case IEEE_FLOAT_128: 00407 status = ar_sim("modulod"); 00408 break; 00409 00410 default: 00411 switch (*resulttype) { 00412 00413 case AR_Int_32_S: 00414 case AR_Int_46_S: 00415 status = ar_sim("moduloi"); 00416 break; 00417 00418 case AR_Int_64_S: 00419 status = ar_sim("moduloj"); 00420 break; 00421 00422 default: 00423 return AR_STAT_INVALID_TYPE; 00424 } 00425 00426 } 00427 00428 status &= AR_ERROR_STATUS; 00429 if(status) 00430 return status; 00431 00432 return ar_get_function_value(result, resulttype); 00433 } 00434 00435 00436 /* Fortran-90 selected_real_kind */ 00437 int 00438 ar_selected_real_kind (ar_data *result, const AR_TYPE *resulttype, 00439 const ar_data *opnd1, const AR_TYPE *opnd1type, 00440 const ar_data *opnd2, const AR_TYPE *opnd2type) { 00441 00442 int status; 00443 00444 status = ar_clear_sim_state(*resulttype); 00445 status |= ar_pass_arg_address(opnd1, opnd1type); 00446 status |= ar_pass_arg_address(opnd2, opnd2type); 00447 if(IS_ERROR_STATUS(status)) 00448 return status; 00449 00450 switch (*resulttype) { 00451 00452 case AR_Int_32_S: 00453 status = ar_sim("selreali"); 00454 break; 00455 00456 case AR_Int_46_S: 00457 case AR_Int_64_S: 00458 status = ar_sim("selrealk"); 00459 break; 00460 00461 default: 00462 return AR_STAT_INVALID_TYPE; 00463 } 00464 00465 status &= AR_ERROR_STATUS; 00466 if(status) 00467 return status; 00468 00469 return ar_get_function_value(result, resulttype); 00470 } 00471 00472 00473 /* Square root */ 00474 int 00475 ar_sqrt (ar_data *result, const AR_TYPE *resulttype, 00476 const ar_data *opnd, const AR_TYPE *opndtype) { 00477 00478 int status; 00479 00480 status = ar_clear_sim_state(*resulttype); 00481 status |= ar_pass_arg_value(opnd, opndtype); 00482 if(IS_ERROR_STATUS(status)) 00483 return status; 00484 00485 switch (UNROUNDED_TYPE(*resulttype)) { 00486 00487 case IEEE_FLOAT_32: 00488 status = ar_sim("hsqrt"); 00489 break; 00490 00491 case CRAY_FLOAT_64: 00492 case IEEE_FLOAT_64: 00493 status = ar_sim("sqrt"); 00494 break; 00495 00496 case CRAY_FLOAT_128: 00497 case IEEE_FLOAT_128: 00498 status = ar_sim("dsqrt"); 00499 break; 00500 00501 case CRAY_COMPLEX_64: 00502 case IEEE_COMPLEX_32: 00503 case IEEE_COMPLEX_64: 00504 status = ar_sim("csqrt"); 00505 break; 00506 00507 case CRAY_COMPLEX_128: 00508 case IEEE_COMPLEX_128: 00509 status = ar_sim("cdsqrt"); 00510 break; 00511 00512 default: 00513 return AR_STAT_INVALID_TYPE; 00514 } 00515 00516 status &= AR_ERROR_STATUS; 00517 if(status) 00518 return status; 00519 00520 return ar_get_function_value(result, resulttype); 00521 } 00522 00523 00524 /* Natural (base "e") logarithm */ 00525 int 00526 ar_log (ar_data *result, const AR_TYPE *resulttype, 00527 const ar_data *opnd, const AR_TYPE *opndtype) { 00528 00529 int status; 00530 00531 status = ar_clear_sim_state(*resulttype); 00532 status |= ar_pass_arg_value(opnd, opndtype); 00533 if(IS_ERROR_STATUS(status)) 00534 return status; 00535 00536 switch (UNROUNDED_TYPE(*resulttype)) { 00537 00538 case IEEE_FLOAT_32: 00539 status = ar_sim("hlog"); 00540 break; 00541 00542 case CRAY_FLOAT_64: 00543 case IEEE_FLOAT_64: 00544 status = ar_sim("alog"); 00545 break; 00546 00547 case CRAY_FLOAT_128: 00548 case IEEE_FLOAT_128: 00549 status = ar_sim("dlog"); 00550 break; 00551 00552 case CRAY_COMPLEX_64: 00553 case IEEE_COMPLEX_32: 00554 case IEEE_COMPLEX_64: 00555 status = ar_sim("clog"); 00556 break; 00557 00558 case CRAY_COMPLEX_128: 00559 case IEEE_COMPLEX_128: 00560 status = ar_sim("cdlog"); 00561 break; 00562 00563 default: 00564 return AR_STAT_INVALID_TYPE; 00565 } 00566 00567 status &= AR_ERROR_STATUS; 00568 if(status) 00569 return status; 00570 00571 return ar_get_function_value(result, resulttype); 00572 } 00573 00574 00575 /* Exponential ("e" ** x) function */ 00576 int 00577 ar_exp (ar_data *result, const AR_TYPE *resulttype, 00578 const ar_data *opnd, const AR_TYPE *opndtype) { 00579 00580 int status; 00581 00582 status = ar_clear_sim_state(*resulttype); 00583 status |= ar_pass_arg_value(opnd, opndtype); 00584 if(IS_ERROR_STATUS(status)) 00585 return status; 00586 00587 switch (UNROUNDED_TYPE(*resulttype)) { 00588 00589 case IEEE_FLOAT_32: 00590 status = ar_sim("hexp"); 00591 break; 00592 00593 case CRAY_FLOAT_64: 00594 case IEEE_FLOAT_64: 00595 status = ar_sim("exp"); 00596 break; 00597 00598 case CRAY_FLOAT_128: 00599 case IEEE_FLOAT_128: 00600 status = ar_sim("dexp"); 00601 break; 00602 00603 case CRAY_COMPLEX_64: 00604 case IEEE_COMPLEX_32: 00605 case IEEE_COMPLEX_64: 00606 status = ar_sim("cexp"); 00607 break; 00608 00609 case CRAY_COMPLEX_128: 00610 case IEEE_COMPLEX_128: 00611 status = ar_sim("cdexp"); 00612 break; 00613 00614 default: 00615 return AR_STAT_INVALID_TYPE; 00616 } 00617 00618 status &= AR_ERROR_STATUS; 00619 if(status) 00620 return status; 00621 00622 return ar_get_function_value(result, resulttype); 00623 } 00624 00625 00626 /* Complex absolute value */ 00627 int 00628 ar_cabs (ar_data *result, const AR_TYPE *resulttype, 00629 const ar_data *opnd, const AR_TYPE *opndtype) { 00630 00631 int status; 00632 00633 status = ar_clear_sim_state(*resulttype); 00634 status |= ar_pass_arg_value(opnd, opndtype); 00635 if(IS_ERROR_STATUS(status)) 00636 return status; 00637 00638 switch (UNROUNDED_TYPE(*resulttype)) { 00639 00640 case CRAY_FLOAT_64: 00641 case IEEE_FLOAT_32: 00642 case IEEE_FLOAT_64: 00643 status = ar_sim("cabs"); 00644 break; 00645 00646 case CRAY_FLOAT_128: 00647 case IEEE_FLOAT_128: 00648 status = ar_sim("cdabs"); 00649 break; 00650 00651 default: 00652 return AR_STAT_INVALID_TYPE; 00653 } 00654 00655 status &= AR_ERROR_STATUS; 00656 if(status) 00657 return status; 00658 00659 return ar_get_function_value(result, resulttype); 00660 } 00661 00662 00663 /* Exponentiation */ 00664 int 00665 ar_power(ar_data *result, const AR_TYPE *resulttype, 00666 const ar_data *base, const AR_TYPE *basetype, 00667 const ar_data *power, const AR_TYPE *powertype) 00668 { 00669 int status; 00670 ar_data temp; 00671 AR_TYPE btype, ptype; 00672 00673 /* Prepare for power function simulation by converting 00674 * base and power operand types to values supported by 00675 * the simulated power functions. 00676 */ 00677 00678 if(AR_CLASS(*basetype) == AR_CLASS_INT) 00679 00680 btype = ptype = *powertype; 00681 00682 else if(AR_CLASS(*powertype) == AR_CLASS_INT || 00683 (AR_FLOAT_SIZE(*powertype) <= AR_FLOAT_64 && 00684 AR_FLOAT_IS_COMPLEX(*powertype) != AR_FLOAT_COMPLEX)) { 00685 00686 /* base**I or base**R power functions */ 00687 00688 btype = *basetype; 00689 ptype = *powertype; 00690 } 00691 00692 /* Otherwise, process arg types to simulate power function with 00693 * base type == power type using the greatest precision and/or 00694 * generality required. 00695 */ 00696 00697 else { 00698 00699 /* Convert to base type == power type using the greatest 00700 * precision and/or generality required. 00701 */ 00702 00703 if(AR_FLOAT_SIZE(*basetype) > AR_FLOAT_SIZE(*powertype)) 00704 btype = (AR_TYPE) (*basetype | AR_FLOAT_IS_COMPLEX(*powertype)); 00705 else 00706 btype = (AR_TYPE) (*powertype | AR_FLOAT_IS_COMPLEX(*basetype)); 00707 00708 ptype = btype; 00709 } 00710 00711 /* 00712 * Verify that the resulttype matches the simulated function's 00713 * return type given by the expanded base type. 00714 */ 00715 00716 if(*resulttype != btype) 00717 return AR_STAT_INVALID_TYPE; 00718 00719 /* 00720 * Setup the operands to the power function converting to the 00721 * correct (expanded) type if necessary. 00722 */ 00723 00724 status = ar_clear_sim_state(*resulttype); 00725 if(*basetype != btype) { 00726 status |= AR_convert((AR_DATA*)&temp, &btype, (AR_DATA*)base, basetype); 00727 if(ptype == btype && 00728 AR_FLOAT_SIZE(btype) == AR_FLOAT_128 && 00729 AR_FLOAT_IS_COMPLEX(btype) == AR_FLOAT_COMPLEX) 00730 status |= ar_pass_arg_address(&temp, &btype); 00731 else 00732 status |= ar_pass_arg_value(&temp, &btype); 00733 } 00734 else 00735 if(ptype == btype && 00736 AR_FLOAT_SIZE(btype) == AR_FLOAT_128 && 00737 AR_FLOAT_IS_COMPLEX(btype) == AR_FLOAT_COMPLEX) 00738 status |= ar_pass_arg_address(base, basetype); 00739 else 00740 status |= ar_pass_arg_value(base, basetype); 00741 00742 if(*powertype != ptype) { 00743 status = AR_convert((AR_DATA*)&temp, &ptype, (AR_DATA*)power, powertype); 00744 if(ptype == btype && 00745 AR_FLOAT_SIZE(btype) == AR_FLOAT_128 && 00746 AR_FLOAT_IS_COMPLEX(btype) == AR_FLOAT_COMPLEX) 00747 status |= ar_pass_arg_address(&temp, &ptype); 00748 else 00749 status |= ar_pass_arg_value(&temp, &ptype); 00750 } 00751 else 00752 if(ptype == btype && 00753 AR_FLOAT_SIZE(btype) == AR_FLOAT_128 && 00754 AR_FLOAT_IS_COMPLEX(btype) == AR_FLOAT_COMPLEX) 00755 status |= ar_pass_arg_address(power, powertype); 00756 else 00757 status |= ar_pass_arg_value(power, powertype); 00758 00759 if(IS_ERROR_STATUS(status)) 00760 return status; 00761 00762 /* 00763 * Call (simulate) the correct power function determined by 00764 * the (expanded) base and power types. 00765 */ 00766 00767 switch (UNROUNDED_TYPE(btype)) { 00768 00769 case CRAY_FLOAT_64: 00770 case IEEE_FLOAT_32: 00771 case IEEE_FLOAT_64: 00772 if(AR_CLASS(ptype) == AR_CLASS_INT) 00773 status = ar_sim("rtoi"); 00774 else 00775 status = ar_sim("rtor"); 00776 break; 00777 00778 case CRAY_FLOAT_128: 00779 case IEEE_FLOAT_128: 00780 if(AR_CLASS(ptype) == AR_CLASS_INT) 00781 status = ar_sim("dtoi"); 00782 else if(AR_FLOAT_SIZE(ptype) <= AR_FLOAT_64) 00783 status = ar_sim("dtor"); 00784 else 00785 status = ar_sim("dtod"); 00786 break; 00787 00788 case CRAY_COMPLEX_64: 00789 case IEEE_COMPLEX_32: 00790 case IEEE_COMPLEX_64: 00791 if(AR_CLASS(ptype) == AR_CLASS_INT) 00792 status = ar_sim("ctoi"); 00793 else if(AR_FLOAT_IS_COMPLEX(ptype) != AR_FLOAT_COMPLEX) 00794 status = ar_sim("ctor"); 00795 else 00796 status = ar_sim("ctoc"); 00797 break; 00798 00799 case CRAY_COMPLEX_128: 00800 case IEEE_COMPLEX_128: 00801 if(AR_CLASS(ptype) == AR_CLASS_INT) 00802 status = ar_sim("cdtoi"); 00803 else 00804 status = ar_sim("cdtocd"); 00805 break; 00806 00807 default: 00808 switch (btype) { 00809 00810 case AR_Int_32_S: 00811 case AR_Int_46_S: 00812 case AR_Int_64_S: 00813 status = ar_sim("itoi"); 00814 break; 00815 00816 default: 00817 return AR_STAT_INVALID_TYPE; 00818 } 00819 } 00820 00821 status &= AR_ERROR_STATUS; 00822 if(status) 00823 return status; 00824 00825 return ar_get_function_value(result, resulttype); 00826 } 00827 00828 00829 /* Input conversion precision mode flags */ 00830 00831 #define MODESP 000 /* Single-precision (64-bit) flag */ 00832 #define MODEDP 004 /* Double-precision (128-bit) flag */ 00833 #define MODEHP 020 /* Half-precision (32-bit) flag */ 00834 00835 /* Input conversion exit values */ 00836 00837 #define EX_REAL64 3 /* 64-bit real */ 00838 #define EX_REAL128 4 /* 128-bit real */ 00839 #define EX_REAL32 5 /* 32-bit real */ 00840 #define EX_ILLCHAR -1 /* invalid character */ 00841 #define EX_EXPUFLO -3 /* floating-point underflow */ 00842 #define EX_EXPOFLO -4 /* floating-point overflow */ 00843 #define EX_NULLFLD -5 /* null field (no digits) */ 00844 00845 /* string -> floating point */ 00846 int 00847 ar_convert_str_to_float (ar_data *result, const AR_TYPE *resulttype, 00848 const char *str) 00849 { 00850 int status; 00851 00852 int i; 00853 00854 long w, d, p; 00855 00856 AR_INT_64 fw; 00857 AR_INT_64 lcap1; 00858 AR_INT_64 mode; 00859 AR_INT_64 stat; 00860 AR_INT_64 xd; 00861 AR_INT_64 xp; 00862 00863 long ichars[64]; 00864 AR_INT_64 unpacked_chars[64]; 00865 00866 extern int ar_unpack_float_str(); 00867 00868 /* Unpack char string into integer array 1 character per word */ 00869 00870 status = ar_unpack_float_str(ichars, 64, &w, &d, &p, str); 00871 if (IS_ERROR_STATUS(status)) 00872 return status; 00873 00874 if(status == AR_STAT_ZERO) { 00875 ZERO64(result[0].ar_i64); 00876 if(AR_FLOAT_SIZE(*resulttype) == AR_FLOAT_128) 00877 result[0].ar_i128.part5 = result[0].ar_i128.part6 = 00878 result[0].ar_i128.part7 = result[0].ar_i128.part8 = 0; 00879 return AR_STAT_ZERO; 00880 } 00881 00882 /* Set up 64-bit arguments for the simulated call */ 00883 00884 ZERO64(fw); 00885 fw.part4 = w; 00886 ZERO64(xd); 00887 xd.part4 = d; 00888 xp.part4 = p; 00889 if(p < 0) 00890 xp.part1 = xp.part2 = xp.part3 = 0xffff; 00891 else 00892 xp.part1 = xp.part2 = xp.part3 = 0; 00893 00894 /* Define the floating point mode of the numeric result */ 00895 00896 ZERO64(mode); 00897 if(UNROUNDED_TYPE(*resulttype) == IEEE_FLOAT_32) 00898 mode.part4 = MODEHP; /* = 32-bit */ 00899 else if(AR_FLOAT_SIZE(*resulttype) == AR_FLOAT_64) 00900 mode.part4 = MODESP; /* = 64-bit */ 00901 else if(AR_FLOAT_SIZE(*resulttype) == AR_FLOAT_128) 00902 mode.part4 = MODEDP; /* = 128-bit */ 00903 else 00904 return AR_STAT_INVALID_TYPE; 00905 00906 for(i=0; i<w; i++) { 00907 ZERO64(unpacked_chars[i]); 00908 unpacked_chars[i].part4 = ichars[i]; 00909 } 00910 00911 /* Define (call-by-address) argument list to: 00912 * 00913 * defgu2sd(fca, &fw, &lcap1, &mode, &result, &status, &d, &p) 00914 * 00915 */ 00916 00917 status = ar_clear_sim_state(*resulttype); 00918 status |= ar_pass_ext_address(&lcap1,(const void*)unpacked_chars, 64); 00919 status |= ar_pass_ext_address(NULL, (const void*)&fw, 1); 00920 status |= ar_pass_ext_address(NULL, (const void*)&lcap1, 1); 00921 status |= ar_pass_ext_address(NULL, (const void*)&mode, 1); 00922 status |= ar_pass_ext_address(NULL, (const void*)result, 4); 00923 status |= ar_pass_ext_address(NULL, (const void*)&stat, 1); 00924 status |= ar_pass_ext_address(NULL, (const void*)&xd, 1); 00925 status |= ar_pass_ext_address(NULL, (const void*)&xp, 1); 00926 00927 /* Store the unpacked last character address + 1 (into lcap1) 00928 * Note that lcap1.part4 was returned with shift count to convert 00929 * a 64-bit word offset/index into a address quantity. 00930 */ 00931 00932 lcap1.part4 = w<<lcap1.part4; 00933 00934 if (IS_ERROR_STATUS(status)) 00935 return status; 00936 00937 00938 /* 00939 * Solaris porting 00940 * The ported mfef90 causes "illegal instruction" error when running on Fortran 00941 * files containing floating-point number assignment. This error happens during 00942 * the following ar_sim("defgu2sd") call. 00943 */ 00944 /* Simulate low-level input conversion routine, defgu2sd */ 00945 status = ar_sim("defgu2sd"); 00946 if(IS_ERROR_STATUS(status)) 00947 return status; 00948 00949 /* 00950 * Process results returned by defgu2sd. Note that defgu2sd has 00951 * already stored the converted number into result. 00952 */ 00953 00954 memcpy(&status, (char*)(&stat)+8-sizeof(int), sizeof(int)); 00955 switch (status) { 00956 case EX_REAL32: 00957 result[0].ar_i64.part3 = result[0].ar_i64.part1; 00958 result[0].ar_i64.part4 = result[0].ar_i64.part2; 00959 result[0].ar_i64.part1 = result[0].ar_i64.part2 = 0; 00960 case EX_REAL64: 00961 case EX_REAL128: 00962 status = AR_status((AR_DATA*)result, resulttype); 00963 break; 00964 00965 case EX_EXPUFLO: 00966 ZERO64(result[0].ar_i64); 00967 if(AR_FLOAT_SIZE(*resulttype) == AR_FLOAT_128) 00968 result[0].ar_i128.part5 = result[0].ar_i128.part6 = 00969 result[0].ar_i128.part7 = result[0].ar_i128.part8 = 0; 00970 status = AR_STAT_UNDERFLOW|AR_STAT_ZERO; 00971 break; 00972 00973 case EX_EXPOFLO: 00974 status = AR_STAT_OVERFLOW; 00975 break; 00976 00977 default: 00978 status = AR_STAT_UNDEFINED; 00979 break; 00980 } 00981 00982 return status; 00983 } 00984 00985 00986 /* "Normal" complex division algorithm */ 00987 int 00988 ar_divide_complex (ar_data *result, const AR_TYPE *resulttype, 00989 const ar_data *opnd1, const AR_TYPE *opnd1type, 00990 const ar_data *opnd2, const AR_TYPE *opnd2type) 00991 { 00992 00993 /* Assume types all match (see logic in AR_divide) */ 00994 00995 AR_DATA a, b, c, d, ac, bd, bc, ad, cc, dd, acbd, bcad, ccdd, re, im; 00996 AR_TYPE reimtype1, reimtype2, temptype; 00997 int status, restat, imstat; 00998 00999 status = ar_decompose_complex ((ar_data*)&a, (ar_data*)&b, &reimtype1, 01000 opnd1, opnd1type); 01001 status |= ar_decompose_complex ((ar_data*)&c, (ar_data*)&d, &reimtype2, 01002 opnd2, opnd2type); 01003 01004 /* PDGCS requests that a different sequence be used when the 01005 * imaginary part of the denominator is zero. A meeting of 01006 * managers on 11/30/93 decided in favor of this expediency. 01007 * Note that we do NOT apply special-case processing when 01008 * the real part of the denominator is zero. 01009 */ 01010 01011 imstat = AR_status (&d, &reimtype2); 01012 if (imstat & AR_STAT_ZERO) { 01013 01014 /* zero imaginary part, use short sequence */ 01015 restat = AR_divide (&re, &reimtype1, 01016 &a, &reimtype1, &c, &reimtype2); 01017 imstat = AR_divide (&im, &reimtype1, 01018 &b, &reimtype1, &c, &reimtype2); 01019 01020 } else { 01021 01022 /* 01023 * general sequence: 01024 * 01025 * a + bi (a + bi)(c - di) (ac + bd) (bc - ad)i 01026 * ------ = ---------------- = --------- + ---------- 01027 * c + di (c + di)(c - di) c*c + d*d c*c + d*d 01028 */ 01029 01030 status |= AR_multiply (&ac, &reimtype1, 01031 &a, &reimtype1, &c, &reimtype2); 01032 status |= AR_multiply (&bd, &reimtype1, &b, 01033 &reimtype1, &d, &reimtype2); 01034 status |= AR_multiply (&bc, &reimtype1, 01035 &b, &reimtype1, &c, &reimtype2); 01036 status |= AR_multiply (&ad, &reimtype1, 01037 &a, &reimtype1, &d, &reimtype2); 01038 status |= AR_multiply (&cc, &reimtype2, 01039 &c, &reimtype2, &c, &reimtype2); 01040 status |= AR_multiply (&dd, &reimtype2, 01041 &d, &reimtype2, &d, &reimtype2); 01042 status |= AR_add (&acbd, &reimtype1, 01043 &ac, &reimtype1, &bd, &reimtype1); 01044 status |= AR_subtract (&bcad, &reimtype1, 01045 &bc, &reimtype1, &ad, &reimtype1); 01046 status |= AR_add (&ccdd, &reimtype1, 01047 &cc, &reimtype1, &dd, &reimtype1); 01048 01049 restat = AR_divide (&re, &reimtype1, 01050 &acbd, &reimtype1, &ccdd, &reimtype1); 01051 imstat = AR_divide (&im, &reimtype1, 01052 &bcad, &reimtype1, &ccdd, &reimtype1); 01053 } 01054 01055 status |= ar_compose_complex (result, &temptype, 01056 (ar_data*)&re, (ar_data*)&im, &reimtype1); 01057 status |= restat | imstat; 01058 status &= ~(AR_STAT_ZERO | AR_STAT_NEGATIVE); 01059 status |= restat & imstat & AR_STAT_ZERO; 01060 return status; 01061 } 01062 01063 01064 #if defined(__sparc__) || defined(__mips) 01065 char *strnstrn(char *str1, long n1, char *str2, long n2) 01066 { 01067 int i = 0; 01068 int imax = n1-n2; 01069 01070 while(i <= imax) { 01071 if(str1[i] == str2[0] && 01072 strncmp(&str1[i], str2, n2) == 0) 01073 return &str1[i]; 01074 i++; 01075 } 01076 01077 return NULL; 01078 } 01079 #endif 01080 01081 static char USMID [] = "\n%Z%%M% %I% %G% %U%\n";
1.7.6.1 
