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.1 of the GNU Lesser General Public License 00007 as 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 Lesser General Public 00021 License along with this program; if not, write the Free Software 00022 Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 00023 USA. 00024 00025 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00026 Mountain View, CA 94043, or: 00027 00028 http://www.sgi.com 00029 00030 For further information regarding this notice, see: 00031 00032 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00033 00034 */ 00035 00036 00037 00038 #pragma ident "@(#) libf/fio/getdcparam.c 92.6 10/07/99 13:07:09" 00039 00040 #include <fortran.h> 00041 #include <cray/nassert.h> 00042 #include <cray/dopevec.h> 00043 #include "fio.h" 00044 00045 #define DT_SPECREAL 8 /* type code for converting single precision 00046 * data to double precision data */ 00047 00048 /* 00049 * Define native sizes of the basic default types (in bits). 00050 */ 00051 00052 #define INTEGER_SZ (sizeof(_f_int) << 3) /* INTEGER */ 00053 #define REAL_SZ (sizeof(_f_real) << 3) /* REAL */ 00054 #define DOUBLE_SZ (sizeof(_f_dble) << 3) /* DOUBLE */ 00055 #define COMPLEX_SZ (sizeof(_f_comp) << 3) /* COMPLEX */ 00056 #define LOGICAL_SZ (sizeof(_f_log) << 3) /* LOGICAL */ 00057 00058 /* 00059 * Forward references. 00060 */ 00061 00062 static void 00063 _gdc_abort(FIOSPTR css, unit *cup, struct f90_type ts); 00064 00065 int 00066 _gdc_dflt2len(int ncindex, struct f90_type ts, short dp); 00067 00068 int 00069 _gdc_kind2len(int ncindex, struct f90_type ts); 00070 00071 int 00072 _gdc_star2len(int ncindex, struct f90_type ts); 00073 00074 /* 00075 * Return value 00076 * 00077 * 0 If OK 00078 * >0 Error code. 00079 */ 00080 00081 int 00082 _get_dc_param( 00083 FIOSPTR css, /* Fortran statement state */ 00084 unit *cup, /* Unit pointer */ 00085 struct f90_type ts, /* Type descriptor word */ 00086 type_packet *tip) /* Type information packet */ 00087 { 00088 register ftype_t type90; /* Fortran 90/95 data type */ 00089 register short type77; /* Fortran 77 data type */ 00090 register short cvtype; /* Pseudo-type conversion index */ 00091 register short newkind; /* Set if new-style conversion */ 00092 register short dpflag; /* Set if DOUBLE PRECISION decl.*/ 00093 register int forlen; /* Bit length of foreign data */ 00094 register int natlen; /* Bit length of native data */ 00095 register int ncindex; /* Numeric conversion index */ 00096 00097 /* Assertions */ 00098 00099 assert ( ts.type >= DVTYPE_TYPELESS && ts.type <= DVTYPE_ASCII ); 00100 00101 type90 = tip->type90; 00102 type77 = tip->type77; 00103 natlen = tip->intlen; 00104 forlen = 0; /* Assume foreign size is unknown */ 00105 cvtype = -1; /* Assume no available conversion */ 00106 dpflag = (ts.dpflag || (ts.kind_or_star == DVD_KIND_DOUBLE)) ? 1 : 0; 00107 00108 if (type90 == DVTYPE_ASCII) 00109 ncindex = _charset_cnvt[cup->ucharset]; 00110 else 00111 ncindex = cup->unumcvrt; 00112 00113 if (ncindex == 0) 00114 goto done; 00115 00116 newkind = __fndc_ncfunc[ncindex].new_style_func; 00117 00118 if ( !newkind && type77 == -1) { 00119 00120 /* 00121 * Create a f77 type code when we've been called from f90 00122 * and we are using an old-style conversion function. At 00123 * this point, we only want to try to identify variables 00124 * declared as double precision (or f90 equivalent) and 00125 * declared-size integers that map to short integers. Any 00126 * REAL KIND/star declaractions that map to a foreign 00127 * double precision will be handled at the end of this 00128 * routine. 00129 */ 00130 00131 type77 = _f90_to_f77_type_cnvt[type90]; 00132 00133 switch (ts.kind_or_star) { 00134 00135 case DVD_DEFAULT: 00136 case DVD_KIND_DOUBLE: 00137 00138 /* 00139 * If "default" type REAL, then map to 00140 * DOUBLE PRECISION if declared as such. 00141 */ 00142 00143 if (type77 == DT_REAL && dpflag) 00144 type77 = DT_DBLE; 00145 break; 00146 00147 case DVD_STAR: 00148 case DVD_KIND_CONST: 00149 00150 /* 00151 * Map declared-size integers to short 00152 * integers if their declared size is 00153 * less than the foreign default integer 00154 * size. 00155 */ 00156 00157 if (type77 == DT_INT && (ts.dec_len << 3) < 00158 __fndc_f77sz[ncindex]->typlen[DT_INT]) 00159 type77 = DT_SINT; 00160 break; 00161 00162 default: 00163 break; 00164 } /* switch (ts.kind_or_star) */ 00165 } 00166 00167 #ifdef DEBUG_FDC 00168 printf("\n"); 00169 switch (ts.type) { 00170 case DVTYPE_TYPELESS: printf("declaration: typeless"); break; 00171 case DVTYPE_INTEGER: printf("declaration: INTEGER"); break; 00172 case DVTYPE_REAL: printf("declaration: REAL"); break; 00173 case DVTYPE_COMPLEX: printf("declaration: COMPLEX"); break; 00174 case DVTYPE_LOGICAL: printf("declaration: LOGICAL"); break; 00175 case DVTYPE_ASCII: printf("declaration: CHARACTER"); break; 00176 } /* switch */ 00177 if (ts.dpflag) 00178 printf(", dpflag (DOUBLE) set\n"); 00179 else 00180 printf("\n"); 00181 switch (ts.kind_or_star) { 00182 case DVD_DEFAULT: printf("KIND type: DEFAULT\n"); break; 00183 case DVD_KIND: printf("KIND type: KIND=expression\n"); break; 00184 case DVD_STAR: printf("KIND type: *%d (bytes)\n", ts.dec_len); break; 00185 case DVD_KIND_CONST: printf("KIND type: KIND=%d\n", ts.dec_len); break; 00186 case DVD_KIND_DOUBLE: printf("KIND type: KIND DOUBLE\n"); break; 00187 } /* switch */ 00188 printf(" Internal length = %d bits\n", ts.int_len); 00189 #endif 00190 00191 switch (ts.kind_or_star) { 00192 00193 case DVD_DEFAULT: 00194 /* 00195 * The variable is default KIND. 00196 */ 00197 if (newkind) { 00198 forlen = _gdc_dflt2len(ncindex, ts, dpflag); 00199 00200 if (forlen != 0) 00201 cvtype = type90; 00202 } 00203 else { 00204 cvtype = type77; 00205 forlen = __fndc_f77sz[ncindex]->typlen[cvtype]; 00206 } 00207 break; 00208 00209 case DVD_KIND_DOUBLE: 00210 /* 00211 * The variable is either REAL (KIND=KIND(1.0D0)) or 00212 * COMPLEX (KIND=KIND(1.0D0)). Currently, double complex 00213 * is not supported in the old F77-style numeric data 00214 * conversion routines and will be diagnosed as such. 00215 */ 00216 00217 if (newkind) { 00218 forlen = _gdc_dflt2len(ncindex, ts, 1); 00219 00220 if (forlen != 0) 00221 cvtype = type90; 00222 } 00223 else 00224 if (type90 == DVTYPE_REAL) { 00225 cvtype = DT_DBLE; 00226 forlen = __fndc_f77sz[ncindex]->typlen[cvtype]; 00227 } 00228 break; 00229 00230 case DVD_STAR: 00231 /* 00232 * The variable is declared as *N, where N is the size of 00233 * the datum in bytes. 00234 */ 00235 00236 forlen = _gdc_star2len(ncindex, ts); 00237 00238 if (newkind) { 00239 cvtype = type90; 00240 00241 if (forlen == 0) 00242 forlen = ts.dec_len << 3; 00243 } 00244 else { 00245 cvtype = type77; 00246 00247 if (forlen == 0) 00248 forlen = __fndc_f77sz[ncindex]->typlen[cvtype]; 00249 } 00250 break; 00251 00252 case DVD_KIND_CONST: 00253 /* 00254 * The variable is declared as KIND=N, where N is the 00255 * size of the datum in bytes. Note that for COMPLEX, 00256 * N is the size of each half. The _gdc_kind2len routine 00257 * will handle some special cases, otherwise the foreign 00258 * length is equal to the KIND= expression. 00259 */ 00260 00261 forlen = _gdc_kind2len(ncindex, ts); 00262 00263 if (newkind) { 00264 cvtype = type90; 00265 00266 if (forlen == 0) { 00267 00268 forlen = ts.dec_len << 3; 00269 00270 if (cvtype == DVTYPE_COMPLEX) 00271 forlen = forlen << 1; 00272 } 00273 } 00274 else { 00275 cvtype = type77; 00276 00277 if (forlen == 0) 00278 forlen = __fndc_f77sz[ncindex]->typlen[cvtype]; 00279 } 00280 break; 00281 00282 case DVD_KIND: 00283 /* 00284 * These are cases for which we cannot do foreign data 00285 * conversion because the KIND= value might vary from 00286 * one implementation to another. We would need to 00287 * simulate the foreign vendor's KIND() function to 00288 * determine what the foreign length is; and basically, 00289 * we don't want to go there. 00290 */ 00291 break; 00292 } /* switch */ 00293 00294 #ifdef DEBUG_FDC 00295 printf(" Foreign length = %d bits\n", forlen); 00296 #endif 00297 00298 /* 00299 * Special case integer if: 00300 * 1) foreign size and native size are equal 00301 * and 2) foreign integers are native compatible (twos complement, 00302 * big endian) 00303 */ 00304 if (type90 == DVTYPE_INTEGER && forlen == natlen && 00305 __fndc_ncfunc[ncindex].cray_int_compat ) { 00306 ncindex = 0; /* data needs no conversion */ 00307 goto done; 00308 } 00309 00310 #ifdef __mips 00311 /* 00312 * Special case ieee conversion on mips. No conversion required except 00313 * for double double floating-point data or a size change. 00314 */ 00315 if (ncindex == NCV_IEG && 00316 forlen == natlen && 00317 !(type90 == DVTYPE_REAL && natlen == (REAL_SZ << 1)) && 00318 !(type90 == DVTYPE_COMPLEX && natlen == (COMPLEX_SZ << 1)) ) { 00319 ncindex = 0; /* data needs no conversion */ 00320 goto done; 00321 } 00322 #endif 00323 00324 #if !defined(__mips) && !defined(_LITTLE_ENDIAN) 00325 /* 00326 * For the old-style conversion routines, there are generally two 00327 * variants of REAL and INTEGER conversions available. Map to the 00328 * alternate choice if the foreign data size matches. If none of the 00329 * possibilities matches the foreign length (forlen) then return 00330 * a type code of -1 to indicate that we don't know how to convert 00331 * this item. 00332 */ 00333 if ( !newkind && forlen != __fndc_f77sz[ncindex]->typlen[cvtype]) { 00334 register int oldcvt = cvtype; 00335 cvtype = -1; 00336 if (oldcvt == DT_INT) { 00337 if (forlen == __fndc_f77sz[ncindex]->typlen[DT_SINT]) 00338 cvtype = DT_SINT; 00339 } 00340 else if (oldcvt == DT_REAL) { 00341 if (__fndc_f77sz[ncindex]->numtypes > DT_SPECREAL && 00342 forlen == __fndc_f77sz[ncindex]->typlen[DT_SPECREAL]) 00343 cvtype = DT_SPECREAL; 00344 /* 00345 * The internal length must match the basic f77 type 00346 * length to utilize the old-style data conversion 00347 * routines. 00348 */ 00349 if (ts.int_len != 00350 (_f77_type_len[(cvtype == DT_SPECREAL) ? DT_REAL : cvtype] << 3)) 00351 cvtype = -1; 00352 00353 } 00354 } 00355 #endif 00356 00357 done: 00358 #ifdef DEBUG_FDC 00359 printf(" Conversion type = %d (%s conversion function type)\n", cvtype, 00360 newkind ? "new" : "old f77"); 00361 printf(" Conversion index = %d\n", ncindex); 00362 #endif 00363 00364 if (ncindex > 0) { 00365 00366 tip->extlen = forlen; 00367 tip->cnvindx = ncindex; 00368 tip->newfunc = newkind; 00369 tip->cnvtype = cvtype; 00370 00371 if (cup->uwrt) 00372 tip->cnvfunc = __fndc_ncfunc[ncindex].to_foreign; 00373 else 00374 tip->cnvfunc = __fndc_ncfunc[ncindex].to_native; 00375 00376 if (cvtype < 0) { 00377 if (ABORT_ON_ERROR) 00378 _gdc_abort(css, cup, ts); 00379 00380 return(FENCNV90); 00381 } 00382 } 00383 00384 return(0); 00385 } 00386 /* 00387 * _gdc_dflt2len - map default kinds to foreign lengths 00388 * 00389 */ 00390 00391 int 00392 _gdc_dflt2len( 00393 int ncindex, 00394 struct f90_type ts, /* Type descriptor word */ 00395 short dpflag) /* One if double-precision, else zero */ 00396 { 00397 register int forlen; 00398 00399 forlen = 0; 00400 00401 switch (ncindex) { 00402 00403 case NCV_T3D: /* CRAY MPP (T3D/T3E) */ 00404 forlen = ts.int_len; 00405 00406 if (ts.type == DVTYPE_COMPLEX) 00407 forlen = 128; 00408 else 00409 if (ts.type > DVTYPE_TYPELESS && ts.type < DVTYPE_ASCII) 00410 forlen = 64; 00411 break; 00412 00413 case NCV_CRAY: /* CRAY classic */ 00414 case NCV_IEL: /* CRAY 64-bit IEEE */ 00415 switch (ts.type) { 00416 00417 case DVTYPE_INTEGER: 00418 case DVTYPE_LOGICAL: 00419 forlen = 64; 00420 break; 00421 00422 case DVTYPE_REAL: 00423 forlen = (ts.int_len <= REAL_SZ) ? 64 : 128; 00424 break; 00425 00426 case DVTYPE_COMPLEX: 00427 forlen = (ts.int_len <= COMPLEX_SZ) ? 128 : 256; 00428 break; 00429 00430 case DVTYPE_TYPELESS: 00431 case DVTYPE_ASCII: 00432 forlen = ts.int_len; 00433 break; 00434 } /* switch (ts.type) */ 00435 00436 break; 00437 00438 case NCV_IBM: /* IBM classic */ 00439 case NCV_IEG: /* IEEE generic */ 00440 case NCV_IEU: /* IEEE little-endian */ 00441 case NCV_MIPS: /* MIPS IEEE (128-bit is double double) */ 00442 case NCV_VMS: /* DEC VAX/VMS */ 00443 #ifdef _CRAY 00444 /* 00445 * Basically, foreign size equals one-half of internal size. 00446 */ 00447 00448 if (ts.type != DVTYPE_TYPELESS && ts.type != DVTYPE_ASCII) 00449 forlen = ts.int_len >> 1; 00450 else 00451 forlen = ts.int_len; 00452 #else 00453 /* 00454 * Foreign size equals internal size; except variables 00455 * that got promoted via -i8/-r8 are treated as if they 00456 * had not been promoted. 00457 */ 00458 00459 switch (ts.type) { 00460 00461 case DVTYPE_INTEGER: 00462 case DVTYPE_LOGICAL: 00463 00464 assert ( INTEGER_SZ == LOGICAL_SZ ); 00465 00466 forlen = MIN(ts.int_len, INTEGER_SZ); 00467 break; 00468 00469 case DVTYPE_REAL: 00470 forlen = MIN(ts.int_len, (REAL_SZ << dpflag)); 00471 break; 00472 00473 case DVTYPE_COMPLEX: 00474 forlen = MIN(ts.int_len, (COMPLEX_SZ << dpflag)); 00475 break; 00476 00477 case DVTYPE_TYPELESS: 00478 case DVTYPE_ASCII: 00479 forlen = ts.int_len; 00480 break; 00481 } /* switch (ts.type) */ 00482 #endif 00483 break; 00484 00485 case NCV_IED: /* IEEE_dp */ 00486 #ifdef _CRAY 00487 if (ts.type == DVTYPE_INTEGER || ts.type == DVTYPE_LOGICAL) 00488 forlen = ts.int_len >> 1; 00489 else 00490 #endif 00491 forlen = ts.int_len; 00492 break; 00493 00494 default: 00495 break; 00496 } 00497 00498 return(forlen); 00499 } 00500 00501 /* 00502 * _gdc_star2len - find special cases for foreign *N lengths 00503 * 00504 * _gdc_kind2len - find special cases for foreign KIND=N lengths 00505 * 00506 * Special case any supported datatypes *N or constant KIND=N 00507 * which do not have foreign data lengths equal to N x character 00508 * size. For example, since INTEGER*2 on IBM has foreign length of 00509 * 2 bytes or 16 bits, we do not need to special case it here 00510 * because it is handled in the default forlen calculation. 00511 * 00512 * Note: *N and KIND=N are equivalent for all data types except 00513 * complex. 00514 */ 00515 00516 int 00517 _gdc_star2len( 00518 int ncindex, 00519 struct f90_type ts) /* Type descriptor word */ 00520 { 00521 register int forlen; 00522 00523 forlen = 0; 00524 00525 switch (ncindex) { 00526 00527 case NCV_CDC: 00528 if (ts.type == DVTYPE_INTEGER && 00529 (ts.dec_len == 2 || ts.dec_len == 4)) 00530 forlen = 60; /* cdc INTEGER*2/4 is 60 bits long */ 00531 00532 else if (ts.type == DVTYPE_REAL && ts.dec_len == 8) 00533 forlen = 60; /* cdc REAL*8 is 10 short bytes long */ 00534 00535 else if (ts.type == DVTYPE_COMPLEX && ts.dec_len == 16) 00536 forlen = 120; /* cdc COMPLEX*16 is 20 short bytes long */ 00537 00538 break; 00539 00540 case NCV_NVE: 00541 if (ts.type == DVTYPE_INTEGER && 00542 (ts.dec_len == 2 || ts.dec_len == 4)) 00543 forlen = 64; /* nosve INTEGER*2/4 is 64 bits long */ 00544 break; 00545 00546 case NCV_IEL: /* CRAY 64-bit IEEE */ 00547 case NCV_CRAY: /* CRAY Classic */ 00548 if (ts.type == DVTYPE_INTEGER || ts.type == DVTYPE_LOGICAL || 00549 (ts.type == DVTYPE_REAL && ts.dec_len < 8)) 00550 forlen = 64; 00551 00552 if (ts.type == DVTYPE_COMPLEX && ts.dec_len < 16) 00553 forlen = 128; 00554 break; 00555 00556 case NCV_T3D: /* CRAY MPP (T3D/T3E) */ 00557 if ((ts.type == DVTYPE_INTEGER || ts.type == DVTYPE_LOGICAL) && 00558 ts.dec_len < 4) 00559 forlen = 32; 00560 00561 if (ts.type == DVTYPE_REAL && ts.dec_len > 8) 00562 forlen = 64; 00563 00564 if (ts.type == DVTYPE_COMPLEX && ts.dec_len > 16) 00565 forlen = 128; 00566 break; 00567 00568 default: 00569 break; 00570 } 00571 00572 return(forlen); 00573 } 00574 00575 int 00576 _gdc_kind2len( 00577 int ncindex, 00578 struct f90_type ts) /* Type descriptor word */ 00579 { 00580 register int forlen; 00581 00582 forlen = 0; 00583 00584 /* special cases would be added here */ 00585 00586 switch (ncindex) { 00587 00588 case NCV_CRAY: /* CRAY classic */ 00589 case NCV_IEL: /* CRAY 64-bit IEEE */ 00590 if (ts.type == DVTYPE_INTEGER || ts.type == DVTYPE_LOGICAL || 00591 (ts.type == DVTYPE_REAL && ts.dec_len < 8)) 00592 forlen = 64; 00593 00594 if (ts.type == DVTYPE_COMPLEX && ts.dec_len < 8) 00595 forlen = 128; 00596 break; 00597 00598 case NCV_T3D: /* CRAY MPP (T3D/T3E) */ 00599 if ((ts.type == DVTYPE_INTEGER || ts.type == DVTYPE_LOGICAL) && 00600 ts.dec_len < 4) 00601 forlen = 32; 00602 00603 if (ts.type == DVTYPE_REAL && ts.dec_len > 8) 00604 forlen = 64; 00605 00606 if (ts.type == DVTYPE_COMPLEX && ts.dec_len > 8) 00607 forlen = 128; 00608 break; 00609 00610 default: 00611 break; 00612 } 00613 00614 return(forlen); 00615 } 00616 00617 /* 00618 * _gdc_abort 00619 * 00620 * Abort with error FENCNV90 and appropriate error diagnostics. 00621 */ 00622 00623 static void 00624 _gdc_abort( 00625 FIOSPTR css, /* Fortran statement state */ 00626 unit *cup, /* Unit pointer */ 00627 struct f90_type ts) /* Type descriptor word */ 00628 { 00629 char *tn; 00630 char txt_decl[30]; /* fits largest possible declaration */ 00631 char *txt_dp; 00632 00633 if (ts.kind_or_star == DVD_STAR) 00634 tn = "%s*%d"; 00635 else if (ts.kind_or_star == DVD_KIND) 00636 tn = "%s(KIND=%d)"; 00637 else if (ts.kind_or_star == 3) /* TEMPORARY: the compiler is setting */ 00638 tn = "%s*%d"; /* kind_or_star to 3 instead of 2 */ 00639 else 00640 tn = "%s"; 00641 00642 (void) sprintf(txt_decl, tn, _f90_type_name[ts.type], ts.dec_len); 00643 00644 txt_dp = ""; 00645 00646 if (ts.dpflag && ts.int_len == sizeof(_f_real) << 3) 00647 txt_dp = "\n which was mapped to single precision with the -dp compiler option\n"; 00648 00649 _ferr(css, FENCNV90, txt_decl, txt_dp); 00650 00651 return; 00652 }