Open64: osprey/arith/simulate.c Source File

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   /* Simulate low-level input conversion routine, defgu2sd */
00938 
00939   status = ar_sim("defgu2sd");
00940   if(IS_ERROR_STATUS(status))
00941     return status;
00942 
00943   /* 
00944    * Process results returned by defgu2sd.  Note that defgu2sd has
00945    * already stored the converted number into result.
00946    */
00947 
00948   memcpy(&status, (char*)(&stat)+8-sizeof(int), sizeof(int));
00949   switch (status) {
00950   case EX_REAL32:
00951     result[0].ar_i64.part3 = result[0].ar_i64.part1;
00952     result[0].ar_i64.part4 = result[0].ar_i64.part2;
00953     result[0].ar_i64.part1 = result[0].ar_i64.part2 = 0;
00954   case EX_REAL64:
00955   case EX_REAL128:
00956     status = AR_status((AR_DATA*)result, resulttype);
00957     break;
00958 
00959   case EX_EXPUFLO:
00960     ZERO64(result[0].ar_i64);
00961     if(AR_FLOAT_SIZE(*resulttype) == AR_FLOAT_128)
00962       result[0].ar_i128.part5 = result[0].ar_i128.part6 =
00963       result[0].ar_i128.part7 = result[0].ar_i128.part8 = 0;
00964     status = AR_STAT_UNDERFLOW|AR_STAT_ZERO;
00965     break;
00966 
00967   case EX_EXPOFLO:
00968     status = AR_STAT_OVERFLOW;
00969     break;
00970   
00971   default:
00972     status = AR_STAT_UNDEFINED;
00973     break;
00974   }
00975 
00976   return status;
00977 }
00978 
00979 
00980 /* "Normal" complex division algorithm */
00981 int
00982 ar_divide_complex (ar_data *result, const AR_TYPE *resulttype,
00983        const ar_data *opnd1, const AR_TYPE *opnd1type,
00984        const ar_data *opnd2, const AR_TYPE *opnd2type)
00985 {
00986 
00987   /* Assume types all match (see logic in AR_divide) */
00988 
00989   AR_DATA a, b, c, d, ac, bd, bc, ad, cc, dd, acbd, bcad, ccdd, re, im;
00990   AR_TYPE reimtype1, reimtype2, temptype;
00991   int status, restat, imstat;
00992 
00993   status  = ar_decompose_complex ((ar_data*)&a, (ar_data*)&b, &reimtype1,
00994                   opnd1, opnd1type);
00995   status |= ar_decompose_complex ((ar_data*)&c, (ar_data*)&d, &reimtype2,
00996                   opnd2, opnd2type);
00997 
00998   /*  PDGCS requests that a different sequence be used when the
00999    *  imaginary part of the denominator is zero. A meeting of
01000    *  managers on 11/30/93 decided in favor of this expediency.
01001    *  Note that we do NOT apply special-case processing when
01002    *  the real part of the denominator is zero.
01003    */
01004 
01005   imstat = AR_status (&d, &reimtype2);
01006   if (imstat & AR_STAT_ZERO) {
01007 
01008     /* zero imaginary part, use short sequence */
01009     restat = AR_divide (&re, &reimtype1,
01010             &a, &reimtype1, &c, &reimtype2);
01011     imstat = AR_divide (&im, &reimtype1,
01012             &b, &reimtype1, &c, &reimtype2);
01013 
01014   } else {
01015 
01016     /*
01017      *  general sequence:
01018      *
01019      *      a + bi     (a + bi)(c - di)     (ac + bd)   (bc - ad)i
01020      *      ------  =  ----------------  =  --------- + ----------
01021      *      c + di     (c + di)(c - di)     c*c + d*d   c*c + d*d
01022      */
01023 
01024     status |= AR_multiply (&ac, &reimtype1,
01025                &a, &reimtype1, &c, &reimtype2);
01026     status |= AR_multiply (&bd, &reimtype1, &b,
01027                &reimtype1, &d, &reimtype2);
01028     status |= AR_multiply (&bc, &reimtype1,
01029                &b, &reimtype1, &c, &reimtype2);
01030     status |= AR_multiply (&ad, &reimtype1,
01031                &a, &reimtype1, &d, &reimtype2);
01032     status |= AR_multiply (&cc, &reimtype2,
01033                &c, &reimtype2, &c, &reimtype2);
01034     status |= AR_multiply (&dd, &reimtype2,
01035                &d, &reimtype2, &d, &reimtype2);
01036     status |= AR_add (&acbd, &reimtype1,
01037           &ac, &reimtype1, &bd, &reimtype1);
01038     status |= AR_subtract (&bcad, &reimtype1,
01039                &bc, &reimtype1, &ad, &reimtype1);
01040     status |= AR_add (&ccdd, &reimtype1,
01041           &cc, &reimtype1, &dd, &reimtype1);
01042 
01043     restat = AR_divide (&re, &reimtype1,
01044             &acbd, &reimtype1, &ccdd, &reimtype1);
01045     imstat = AR_divide (&im, &reimtype1,
01046             &bcad, &reimtype1, &ccdd, &reimtype1);
01047   }
01048 
01049   status |= ar_compose_complex (result, &temptype,
01050                   (ar_data*)&re, (ar_data*)&im, &reimtype1);
01051   status |= restat | imstat;
01052   status &= ~(AR_STAT_ZERO | AR_STAT_NEGATIVE);
01053   status |= restat & imstat & AR_STAT_ZERO;
01054   return status;
01055 }
01056 
01057 
01058 #if defined(__sparc__) || defined(__mips)
01059 char *strnstrn(char *str1, long n1, char *str2, long n2)
01060 {
01061   int i = 0;
01062   int imax = n1-n2;
01063 
01064   while(i <= imax) {
01065     if(str1[i] == str2[0] &&
01066        strncmp(&str1[i], str2, n2) == 0)
01067     return &str1[i];
01068     i++;
01069   }
01070 
01071   return NULL;
01072 }
01073 #endif
01074 
01075 static char USMID [] = "\n%Z%%M%  %I% %G% %U%\n";
01076 static char rcsid [] = "$Id: simulate.c,v 1.1.1.1 2005/10/21 19:00:00 marcel Exp $";