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/fwwd.c 92.3 09/29/99 19:50:24" 00039 00040 #include <errno.h> 00041 #include <fortran.h> 00042 #include <liberrno.h> 00043 #include <cray/nassert.h> 00044 #include "fio.h" 00045 #ifdef _ABSOFT 00046 #include "ac_sysdep.h" 00047 #else 00048 00049 #if defined(_LITTLE_ENDIAN) && !defined(__sv2) 00050 #ifndef FILE_FLAG 00051 #define FILE_FLAG(__f) (__f)->_flags 00052 #endif 00053 00054 #ifndef IOREAD 00055 #define IOREAD = _IO_CURRENTLY_APPENDING 00056 #endif 00057 #ifndef IORW 00058 #define IORW = _IO_TIED_PUTGET 00059 #endif 00060 00061 #else /* LITTLE_ENDIAN and not sv2 */ 00062 00063 00064 #ifndef FILE_FLAG 00065 #define FILE_FLAG(__f) (__f)->_flag 00066 #endif 00067 00068 #endif /* LITTLE_ENDIAN and not sv2 */ 00069 #endif 00070 00071 #define TBFSZ (4096 * sizeof(long)) /* Size of temporary buffer (bytes) */ 00072 00073 /* 00074 * _fwwd 00075 * Write binary data to a record of a Fortran file. 00076 * 00077 * Side effects 00078 * 00079 * Increments cup->urecpos by the change in bit position within 00080 * the record, including pad bits. 00081 * 00082 * Clears cup->uend if the file supports multiple endfiles. 00083 * 00084 * Return value 00085 * items on success. On error, -1 is returned, with errno set to 00086 * the specific error status. 00087 */ 00088 long 00089 _fwwd( 00090 unit *cup, /* Unit pointer */ 00091 void *uda, /* User data address */ 00092 type_packet *tip, /* Data conversion function index (0 if none) */ 00093 int mode, /* FULL or PARTIAL record mode */ 00094 int *ubcret, /* If non-NULL, pointer to unused bit count in 00095 * the last item. Normal item alignment 00096 * (normally at word boundaries) is disabled 00097 * when this parameter is passed. */ 00098 long *unused_6, /* Unused by _fwwd() */ 00099 int *status) /* Status return is either CNT or EOR */ 00100 { 00101 register int buflim; 00102 register int fdsize; /* item size (bits) in file */ 00103 register int padbyts; 00104 register long elsize; 00105 register long items; 00106 register ftype_t type; 00107 register size_t breq; 00108 register ssize_t ret; 00109 int padubc; 00110 int padval; 00111 int ubc; 00112 FILE *fptr; 00113 00114 /* Assertions */ 00115 00116 #ifdef _UNICOS 00117 assert ( _numargs() == 7); 00118 #endif 00119 assert ( mode == FULL || mode == PARTIAL ); 00120 assert ( tip != NULL ); 00121 assert ( status != NULL ); 00122 00123 /* 00124 * If positioned after an endfile, and the file does not support 00125 * multiple endfiles, a write is invalid. 00126 */ 00127 00128 if (cup->uend && !cup->umultfil) { 00129 errno = FEWRAFEN; 00130 return(IOERR); 00131 } 00132 00133 type = tip->type90; 00134 elsize = tip->elsize; 00135 items = tip->count; 00136 breq = elsize * items; 00137 padbyts = 0; 00138 padubc = 0; 00139 ubc = 0; 00140 00141 if (ubcret != NULL) { 00142 00143 if ((*ubcret % 8) != 0 && cup->ufs != FS_FDC) { 00144 errno = FEUBCINV; 00145 return (IOERR); 00146 } 00147 00148 if (type != DVTYPE_TYPELESS) { 00149 errno = FEINTUNK; 00150 return (IOERR); 00151 } 00152 /* 00153 * Be sure to handle (ubc > 7) 00154 */ 00155 breq = breq - (*ubcret >> 3); 00156 ubc = *ubcret % 8; 00157 } 00158 #if NUMERIC_DATA_CONVERSION_ENABLED 00159 else { 00160 /* 00161 * Pad word-aligned numeric data on word boundaries within 00162 * the record for CRI and some foreign data formats. Note 00163 * that the elsize expression needs to be cleaned up to be 00164 * something like: external_size > granularity. 00165 */ 00166 if ((cup->urecpos & cup->ualignmask) != 0 && 00167 type != DVTYPE_ASCII && 00168 items > 0 && 00169 #if defined(__mips) || defined(_LITTLE_ENDIAN) 00170 elsize > 2 ) 00171 #else 00172 elsize > 4 ) 00173 #endif 00174 COMPADD(cup, padbyts, padubc, padval); 00175 } 00176 #endif /* NUMERIC_DATA_CONVERSION_ENABLED */ 00177 00178 cup->ulastyp = type; 00179 00180 if (mode == FULL) { 00181 cup->ulastyp = DVTYPE_TYPELESS; 00182 cup->urecpos = 0; 00183 } 00184 /* 00185 * According to the file structure make the appropriate 00186 * write request. 00187 */ 00188 *status = CNT; 00189 00190 switch ( cup->ufs ) { 00191 00192 case FS_FDC: 00193 /* 00194 * If a logical endfile record had just been read, 00195 * replace it with a physical endfile record before 00196 * starting the current data record. 00197 */ 00198 if (cup->uend == LOGICAL_ENDFILE) { 00199 if (XRCALL(cup->ufp.fdc, weofrtn)cup->ufp.fdc, 00200 &cup->uffsw) < 0){ 00201 errno = cup->uffsw.sw_error; 00202 return(IOERR); 00203 } 00204 } 00205 00206 cup->uend = BEFORE_ENDFILE; 00207 /* 00208 * If no items, still may have to terminate record 00209 */ 00210 if (items == 0) { 00211 if (mode == FULL) { 00212 long end; 00213 00214 ret = XRCALL(cup->ufp.fdc, writertn) 00215 cup->ufp.fdc, 00216 CPTR2BP(&end), 0, &cup->uffsw, 00217 mode, &ubc); 00218 00219 if (ret < 0) { /* if an error */ 00220 errno = cup->uffsw.sw_error; 00221 return(IOERR); 00222 } 00223 00224 *status = EOR; 00225 } 00226 00227 /* recpos does not change! */ 00228 00229 return(EOR); 00230 } 00231 /* 00232 * Align the data to a word boundary if required. 00233 */ 00234 if (padbyts > 0) { 00235 00236 ret = XRCALL(cup->ufp.fdc, writertn) cup->ufp.fdc, 00237 CPTR2BP(&padval), 00238 padbyts, &cup->uffsw, PARTIAL, &padubc); 00239 00240 if (ret < 0) { /* if an error */ 00241 errno = cup->uffsw.sw_error; 00242 return(IOERR); 00243 } 00244 if (mode != FULL) 00245 cup->urecpos += ((uint64)ret << 3) - padubc; 00246 } 00247 /* 00248 * If no conversion to be done, just write out the data 00249 */ 00250 if (tip->cnvindx == 0) { 00251 00252 ubc = 0; 00253 00254 ret = XRCALL(cup->ufp.fdc, writertn) cup->ufp.fdc, 00255 CPTR2BP(uda), 00256 breq, &cup->uffsw, mode, &ubc); 00257 00258 if (ret < 0) { /* if an error */ 00259 errno = cup->uffsw.sw_error; 00260 return(IOERR); 00261 } 00262 00263 if (mode == FULL) 00264 *status = EOR; 00265 else 00266 cup->urecpos += ((uint64)ret << 3) - ubc; 00267 00268 return(items); /* return number of items written */ 00269 } 00270 00271 #if NUMERIC_DATA_CONVERSION_ENABLED 00272 /* 00273 * Figure out the item size on the foreign side. 00274 * First, change the conversion routine if character type 00275 */ 00276 { 00277 register int uoff; 00278 register int64 bits; 00279 register int64 totbits; 00280 unsigned char tbuf[TBFSZ], *tp; /* Conversion buffer */ 00281 _f_int dctype; 00282 int (* cvt_fun)(); /* Conversion function */ 00283 00284 cvt_fun = __fndc_ncfunc[tip->cnvindx].to_foreign; 00285 00286 #if !defined(__mips) && !defined(_LITTLE_ENDIAN) 00287 if (!_loaded(cvt_fun)) { 00288 errno = FELDDCNV; 00289 return(IOERR); 00290 } 00291 #endif 00292 00293 fdsize = tip->extlen; 00294 dctype = tip->cnvtype; 00295 00296 if (fdsize == 0) { 00297 errno = FDC_ERR_NCVRT; 00298 return(IOERR); 00299 } 00300 00301 tp = tbuf; 00302 buflim = ((TBFSZ << 3) / fdsize) * fdsize; 00303 00304 /* 00305 * totbits gets the total size of the foreign data which will 00306 * be written out to the file. 00307 * Convert the data by slicing it into parts and converting it 00308 * into a working space, then write the resultant bits out. 00309 * Note that character data is handled as a contiguous stream 00310 * of bytes with no regard for the character element 00311 * boundaries. 00312 */ 00313 totbits = (items * fdsize) - ubc; 00314 00315 if (type == DVTYPE_ASCII) 00316 totbits = totbits * elsize; /* must factor in char length */ 00317 00318 bits = 0; 00319 uoff = 0; 00320 00321 while (bits < totbits) { 00322 register int slice; 00323 register _f_int numerr; 00324 int locubc; 00325 int locmode; 00326 _f_int icount; 00327 const _f_int bitoff = 0; 00328 const _f_int stride = 1; 00329 #ifdef _CRAY 00330 _fcd craychr; 00331 #endif 00332 00333 slice = totbits - bits; 00334 locmode = mode; 00335 00336 if (slice > buflim) { 00337 slice = buflim; 00338 locmode = PARTIAL; 00339 } 00340 00341 /* slice is number of bits in whole items */ 00342 00343 breq = (slice + 7) >> 3; 00344 locubc = (breq << 3) - slice; 00345 /* 00346 * convert the data. slice/fdsize is the number of items 00347 * to convert. 00348 */ 00349 icount = slice / fdsize; 00350 00351 #ifdef _CRAY 00352 craychr = _cptofcd((char *)uda + uoff, icount); 00353 #endif 00354 00355 if (tip->newfunc) { 00356 _f_int flen; /* Foreign length, in bits */ 00357 _f_int nlen; /* Native length, in bits */ 00358 00359 flen = fdsize; 00360 nlen = tip->intlen; 00361 00362 numerr = cvt_fun(&dctype, &icount, (void *)tp, 00363 &bitoff, (char *)uda + uoff, 00364 &stride, &nlen, &flen, 00365 #ifdef _CRAY 00366 craychr); 00367 #else 00368 (char *) uda + uoff, icount); 00369 #endif 00370 } 00371 else 00372 numerr = cvt_fun(&dctype, &icount, (void *)tp, 00373 &bitoff, (char *)uda + uoff, 00374 &stride, 00375 #ifdef _CRAY 00376 craychr); 00377 #else 00378 (char *) uda + uoff, icount); 00379 #endif 00380 00381 if (numerr != 0) { 00382 errno = (numerr < 0) ? FEINTUNK : FDC_ERR_NCVRT; 00383 return(IOERR); 00384 } 00385 /* 00386 * write out the data 00387 */ 00388 ret = XRCALL(cup->ufp.fdc, writertn) cup->ufp.fdc, 00389 CPTR2BP(tp), breq, &cup->uffsw, 00390 locmode, &locubc); 00391 00392 if (ret < 0) { /* if an error */ 00393 errno = cup->uffsw.sw_error; 00394 return(IOERR); 00395 } 00396 00397 bits = bits + slice; 00398 uoff = uoff + (icount * elsize); 00399 } 00400 00401 if (mode == FULL) 00402 *status = EOR; 00403 00404 cup->urecpos = cup->urecpos + totbits; 00405 00406 break; 00407 00408 } 00409 #endif /* NUMERIC_DATA_CONVERSION_ENABLED */ 00410 00411 case STD: 00412 { 00413 00414 fptr = cup->ufp.std; /* Get FILE pointer */ 00415 /* 00416 * Switch the FILE structure out of read mode and into neutral. 00417 */ 00418 #if !defined(_LITTLE_ENDIAN) || (defined(_LITTLE_ENDIAN) && defined(__sv2)) 00419 if ((FILE_FLAG(fptr) & (_IOREAD | _IORW)) == (_IOREAD | _IORW) ) 00420 (void) fseek(fptr, 0, SEEK_CUR); 00421 #endif 00422 /* 00423 * If number of items to write is zero return to caller. 00424 */ 00425 if (items == 0) 00426 return(EOR); 00427 /* 00428 * we must align on word boundaries sometimes 00429 */ 00430 if (padbyts > 0) { 00431 00432 ret = fwrite(" ", 1, padbyts, fptr); 00433 00434 if (ret <= 0) { 00435 if (errno == 0) 00436 errno = FESTIOER; 00437 return(IOERR); 00438 } 00439 00440 cup->urecpos += (uint64)ret << 3; 00441 } 00442 00443 /* 00444 * Use low-level binary i/o routine to write the requested 00445 * amount of data. 00446 */ 00447 00448 ret = fwrite(uda, 1, breq, fptr); 00449 00450 if (ret != breq) { 00451 if (ret > 0 || errno == 0) 00452 errno = FESTIOER; 00453 return(IOERR); 00454 } 00455 00456 cup->urecpos += (uint64)ret << 3; 00457 00458 } 00459 break; 00460 00461 case FS_AUX: 00462 errno = FEMIXAUX; 00463 return (IOERR); 00464 default: 00465 errno = FEINTFST; 00466 return (IOERR); 00467 } 00468 /* 00469 * Normal return: return number of items written. 00470 */ 00471 if (mode == FULL) 00472 cup->urecpos = 0; 00473 00474 return(items); 00475 }