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 /* Primary arith entry points for intrinsic/library function evaluation */ 00037 00038 #include <math.h> 00039 #include <signal.h> 00040 #include <errno.h> 00041 #include <setjmp.h> 00042 #include <stdio.h> 00043 00044 #include "arith.internal.h" 00045 #include "int64.h" 00046 00047 00048 /* Fortran character index function */ 00049 int 00050 AR_index(AR_DATA *result, const AR_TYPE *resulttype, 00051 const char* str1, const AR_DATA *str1len, const AR_TYPE *str1lentype, 00052 const char* str2, const AR_DATA *str2len, const AR_TYPE *str2lentype, 00053 const AR_DATA *backward, const AR_TYPE *backwardtype) 00054 { 00055 int status; 00056 long len1 = str1len->ar_internal_data_item1; 00057 long len2 = str2len->ar_internal_data_item1; 00058 long back; 00059 00060 if (AR_CLASS(*resulttype) != AR_CLASS_INT || 00061 AR_INT_SIZE(*resulttype) != AR_Int_8_S && 00062 AR_INT_SIZE(*resulttype) != AR_Int_16_S && 00063 AR_INT_SIZE(*resulttype) != AR_Int_32_S && 00064 AR_INT_SIZE(*resulttype) != AR_Int_64_S || 00065 *resulttype != *str1lentype || 00066 *resulttype != *str2lentype || 00067 (backward != NULL && *backwardtype != AR_Logical)) 00068 status = AR_STAT_INVALID_TYPE; 00069 else if(len1 < 0 || len2 < 0) 00070 status = AR_STAT_UNDEFINED; 00071 else { 00072 if(backward == NULL || (AR_status(backward, backwardtype)&AR_STAT_ZERO)) 00073 back = 0; 00074 else 00075 back = 1; 00076 status = ar_index((ar_data*)result, resulttype, 00077 str1, len1, str2, len2, back); 00078 } 00079 00080 if (IS_ERROR_STATUS(status)) 00081 ar_set_invalid_result((ar_data*)result, resulttype); 00082 00083 return status; 00084 } 00085 00086 00087 /* Fortran character scan function */ 00088 int 00089 AR_scan(AR_DATA *result, const AR_TYPE *resulttype, 00090 const char* str1, const AR_DATA *str1len, const AR_TYPE *str1lentype, 00091 const char* str2, const AR_DATA *str2len, const AR_TYPE *str2lentype, 00092 const AR_DATA *backward, const AR_TYPE *backwardtype) 00093 { 00094 int status; 00095 long len1 = str1len->ar_internal_data_item1; 00096 long len2 = str2len->ar_internal_data_item1; 00097 long back; 00098 00099 if (AR_CLASS(*resulttype) != AR_CLASS_INT || 00100 AR_INT_SIZE(*resulttype) != AR_Int_8_S && 00101 AR_INT_SIZE(*resulttype) != AR_Int_16_S && 00102 AR_INT_SIZE(*resulttype) != AR_Int_32_S && 00103 AR_INT_SIZE(*resulttype) != AR_Int_64_S || 00104 *resulttype != *str1lentype || 00105 *resulttype != *str2lentype || 00106 (backward != NULL && *backwardtype != AR_Logical)) 00107 status = AR_STAT_INVALID_TYPE; 00108 else if(len1 < 0 || len2 < 0) 00109 status = AR_STAT_UNDEFINED; 00110 else { 00111 if(backward == NULL || (AR_status(backward, backwardtype)&AR_STAT_ZERO)) 00112 back = 0; 00113 else 00114 back = 1; 00115 status = ar_scan((ar_data*)result, resulttype, 00116 str1, len1, str2, len2, back); 00117 } 00118 00119 if (IS_ERROR_STATUS(status)) 00120 ar_set_invalid_result((ar_data*)result, resulttype); 00121 00122 return status; 00123 } 00124 00125 00126 /* Fortran character verify function */ 00127 int 00128 AR_verify(AR_DATA *result, const AR_TYPE *resulttype, 00129 const char* str1, const AR_DATA *str1len, const AR_TYPE *str1lentype, 00130 const char* str2, const AR_DATA *str2len, const AR_TYPE *str2lentype, 00131 const AR_DATA *backward, const AR_TYPE *backwardtype) 00132 { 00133 int status; 00134 long len1 = str1len->ar_internal_data_item1; 00135 long len2 = str2len->ar_internal_data_item1; 00136 long back; 00137 00138 if (AR_CLASS(*resulttype) != AR_CLASS_INT || 00139 AR_INT_SIZE(*resulttype) != AR_Int_8_S && 00140 AR_INT_SIZE(*resulttype) != AR_Int_16_S && 00141 AR_INT_SIZE(*resulttype) != AR_Int_32_S && 00142 AR_INT_SIZE(*resulttype) != AR_Int_64_S || 00143 *resulttype != *str1lentype || 00144 *resulttype != *str2lentype || 00145 (backward != NULL && *backwardtype != AR_Logical)) 00146 status = AR_STAT_INVALID_TYPE; 00147 else if(len1 < 0 || len2 < 0) 00148 status = AR_STAT_UNDEFINED; 00149 else { 00150 if(backward == NULL || (AR_status(backward, backwardtype)&AR_STAT_ZERO)) 00151 back = 0; 00152 else 00153 back = 1; 00154 status = ar_verify((ar_data*)result, resulttype, 00155 str1, len1, str2, len2, back); 00156 } 00157 00158 if (IS_ERROR_STATUS(status)) 00159 ar_set_invalid_result((ar_data*)result, resulttype); 00160 00161 return status; 00162 } 00163 00164 00165 /* Fortran-90 reshape function */ 00166 int 00167 AR_reshape(void *result, const void *source, const void *shape, 00168 const void *pad, const void *order) 00169 { 00170 if (result == NULL || source == NULL || shape == NULL) 00171 return AR_STAT_UNDEFINED; 00172 00173 return ar_reshape(result, source, shape, pad, order); 00174 } 00175 00176 00177 /* Fortran-90 transfer function */ 00178 int 00179 AR_transfer(void *result, const void *source, const void *mold, 00180 const AR_DATA *size, const AR_TYPE *sizetype) 00181 { 00182 long length; 00183 00184 if (result == NULL || source == NULL || mold == NULL) 00185 return AR_STAT_UNDEFINED; 00186 00187 if (size != NULL) { 00188 if(AR_INT_SIZE(*sizetype) != AR_Int_8_S && 00189 AR_INT_SIZE(*sizetype) != AR_Int_16_S && 00190 AR_INT_SIZE(*sizetype) != AR_Int_32_S && 00191 AR_INT_SIZE(*sizetype) != AR_Int_64_S) 00192 return AR_STAT_INVALID_TYPE; 00193 length = size->ar_internal_data_item1; 00194 if(length <= 0) 00195 return AR_STAT_UNDEFINED; 00196 return ar_transfer(result, source, mold, &length); 00197 } 00198 00199 return ar_transfer(result, source, mold, (long*)NULL); 00200 00201 } 00202 00203 00204 /* Fortran-90 Modulo */ 00205 int 00206 AR_Modulo (AR_DATA *result, const AR_TYPE *resulttype, 00207 const AR_DATA *opnd1, const AR_TYPE *opnd1type, 00208 const AR_DATA *opnd2, const AR_TYPE *opnd2type) 00209 { 00210 int status; 00211 00212 if (*resulttype != *opnd1type || *resulttype != *opnd2type || 00213 (AR_status(opnd1, opnd1type) & AR_STAT_INVALID_TYPE) || 00214 (AR_status(opnd2, opnd2type) & AR_STAT_INVALID_TYPE)) 00215 status = AR_STAT_INVALID_TYPE; 00216 else 00217 status = ar_modulo((ar_data*)result, resulttype, 00218 (const ar_data*)opnd1, opnd1type, 00219 (const ar_data*)opnd2, opnd2type); 00220 00221 if (IS_ERROR_STATUS(status)) 00222 ar_set_invalid_result((ar_data*)result, resulttype); 00223 00224 return status; 00225 } 00226 00227 /* Selected_real_kind */ 00228 int 00229 AR_selected_real_kind (AR_DATA *result, const AR_TYPE *resulttype, 00230 const AR_DATA *opnd1, const AR_TYPE *opnd1type, 00231 const AR_DATA *opnd2, const AR_TYPE *opnd2type) 00232 { 00233 int status; 00234 00235 if (*resulttype != *opnd1type || *resulttype != *opnd2type || 00236 AR_CLASS(*resulttype) != AR_CLASS_INT || 00237 AR_INT_SIZE(*resulttype) != AR_Int_8_S && 00238 AR_INT_SIZE(*resulttype) != AR_Int_16_S && 00239 AR_INT_SIZE(*resulttype) != AR_Int_32_S && 00240 AR_INT_SIZE(*resulttype) != AR_Int_64_S) 00241 status = AR_STAT_INVALID_TYPE; 00242 else 00243 status = ar_selected_real_kind((ar_data*)result, resulttype, 00244 (const ar_data*)opnd1, opnd1type, 00245 (const ar_data*)opnd2, opnd2type); 00246 00247 if (IS_ERROR_STATUS(status)) 00248 ar_set_invalid_result((ar_data*)result, resulttype); 00249 00250 return status; 00251 } 00252 00253 /* Square root */ 00254 int 00255 AR_sqrt (AR_DATA *result, const AR_TYPE *resulttype, 00256 const AR_DATA *opnd, const AR_TYPE *opndtype) 00257 { 00258 int status; 00259 00260 if (*resulttype != *opndtype || 00261 (AR_CLASS (*resulttype) != AR_CLASS_FLOAT) || 00262 (AR_status(opnd, opndtype) & AR_STAT_INVALID_TYPE)) 00263 status = AR_STAT_INVALID_TYPE; 00264 else 00265 status = ar_sqrt((ar_data*)result, resulttype, 00266 (const ar_data*)opnd, opndtype); 00267 00268 if(IS_ERROR_STATUS(status)) 00269 ar_set_invalid_result((ar_data*)result, resulttype); 00270 00271 return status; 00272 } 00273 00274 00275 /* Natural (base "e") logarithm */ 00276 int 00277 AR_log (AR_DATA *result, const AR_TYPE *resulttype, 00278 const AR_DATA *opnd, const AR_TYPE *opndtype) 00279 { 00280 int status; 00281 00282 if (*resulttype != *opndtype || 00283 (AR_CLASS(*resulttype) != AR_CLASS_FLOAT) || 00284 (AR_status(opnd, opndtype) & AR_STAT_INVALID_TYPE)) 00285 status = AR_STAT_INVALID_TYPE; 00286 else 00287 status = ar_log((ar_data*)result, resulttype, 00288 (const ar_data*)opnd, opndtype); 00289 00290 if(IS_ERROR_STATUS(status)) 00291 ar_set_invalid_result((ar_data*)result, resulttype); 00292 00293 return status; 00294 } 00295 00296 00297 /* Exponential ("e" ** x) function */ 00298 int 00299 AR_exp (AR_DATA *result, const AR_TYPE *resulttype, 00300 const AR_DATA *opnd, const AR_TYPE *opndtype) 00301 { 00302 int status; 00303 00304 if (*resulttype != *opndtype || 00305 (AR_CLASS (*resulttype) != AR_CLASS_FLOAT) || 00306 (AR_status(opnd, opndtype) & AR_STAT_INVALID_TYPE)) 00307 status = AR_STAT_INVALID_TYPE; 00308 else 00309 status = ar_exp((ar_data*)result, resulttype, 00310 (const ar_data*)opnd, opndtype); 00311 00312 if(IS_ERROR_STATUS(status)) 00313 ar_set_invalid_result((ar_data*)result, resulttype); 00314 00315 return status; 00316 } 00317 00318 00319 /* Complex absolute value */ 00320 int 00321 AR_cabs (AR_DATA *result, const AR_TYPE *resulttype, 00322 const AR_DATA *opnd, const AR_TYPE *opndtype) 00323 { 00324 int status; 00325 00326 if (AR_CLASS (*opndtype) != AR_CLASS_FLOAT || 00327 AR_FLOAT_IS_COMPLEX (*opndtype) != AR_FLOAT_COMPLEX || 00328 AR_FLOAT_IS_COMPLEX (*resulttype) == AR_FLOAT_COMPLEX) 00329 status = AR_STAT_INVALID_TYPE; 00330 else if(!((status = AR_status (opnd, opndtype)) & AR_STAT_OVERFLOW)) 00331 status = ar_cabs((ar_data*)result, resulttype, 00332 (const ar_data*)opnd, opndtype); 00333 00334 if(IS_ERROR_STATUS(status)) 00335 ar_set_invalid_result((ar_data*)result, resulttype); 00336 00337 return status; 00338 } 00339 00340 00341 /* Exponentiation */ 00342 int 00343 AR_power(AR_DATA *result, const AR_TYPE *resulttype, 00344 const AR_DATA *base, const AR_TYPE *basetype, 00345 const AR_DATA *power, const AR_TYPE *powertype) 00346 { 00347 int status; 00348 00349 if (AR_CLASS(*basetype) == AR_CLASS_INT && 00350 AR_CLASS(*powertype) == AR_CLASS_INT && 00351 *basetype != *powertype) 00352 status = AR_STAT_INVALID_TYPE; 00353 else 00354 status = ar_power((ar_data*)result, resulttype, 00355 (const ar_data*)base, basetype, 00356 (const ar_data*)power, powertype); 00357 00358 if(IS_ERROR_STATUS(status)) 00359 ar_set_invalid_result((ar_data*)result, resulttype); 00360 00361 return status; 00362 } 00363 00364 /* string -> floating point */ 00365 int 00366 AR_convert_str_to_float (AR_DATA *result, const AR_TYPE *resulttype, 00367 const char *str) 00368 { 00369 int status; 00370 00371 if(AR_CLASS(*resulttype) != AR_CLASS_FLOAT || 00372 AR_FLOAT_IS_COMPLEX(*resulttype) == AR_FLOAT_COMPLEX) 00373 status = AR_STAT_INVALID_TYPE; 00374 else 00375 status = ar_convert_str_to_float ((ar_data*)result, resulttype, str); 00376 00377 if(IS_ERROR_STATUS(status)) 00378 ar_set_invalid_result((ar_data*)result, resulttype); 00379 00380 return status; 00381 } 00382 00383 00384 static char USMID [] = "\n%Z%%M% %I% %G% %U%\n"; 00385 static char rcsid [] = "$Id: intrin.c,v 1.1.1.1 2002-05-22 20:06:19 dsystem Exp $";