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 #ifndef INLINE 00039 #pragma ident "@(#) libf/fio/rdunf.c 92.2 06/21/99 10:37:55" 00040 #endif 00041 00042 #include <errno.h> 00043 #include <liberrno.h> 00044 #include <fortran.h> 00045 #include <cray/nassert.h> 00046 #ifdef _CRAYT3D 00047 #include <cray/mppsdd.h> 00048 #endif 00049 #include "fio.h" 00050 #include "f90io.h" 00051 00052 #define LOCBUFLN 4096 00053 00054 /* 00055 * _rdunf() Read unformatted processing. 00056 * 00057 * Return value 00058 * 00059 * 0 normal return. 00060 * 00061 * <0 if end of file condition and IOSTAT= or END= 00062 * is specified. 00063 * 00064 * >0 if error condition and IOSTAT= or ERR= is 00065 * specified. 00066 */ 00067 00068 #ifdef INLINE 00069 static int 00070 _inline_rdunf( 00071 #else 00072 int 00073 _rdunf( 00074 #endif 00075 FIOSPTR css, /* Current Fortran I/O statement state */ 00076 unit *cup, /* Unit pointer */ 00077 void *ptr, /* Pointer to data */ 00078 type_packet *tip, /* Type information packet */ 00079 int _Unused /* Unused by this routine */ 00080 ) 00081 { 00082 register short shared; /* 1 iff ptr points to shared data */ 00083 register int errn; /* Error number */ 00084 register int64 fillen; /* bit size of each element, on disk */ 00085 register long count; /* Number of data items */ 00086 register long elsize; /* element size in bytes */ 00087 register long i; 00088 register long incb; /* inc (in units of bytes) */ 00089 register long items; 00090 int status; 00091 long lbuf[LOCBUFLN]; 00092 void *frwdbuf; /* ptr to buffer passed to _frwd */ 00093 #ifdef _CRAYT3D 00094 register long elwords; /* element size in words */ 00095 #endif 00096 00097 errn = 0; /* Clear error number */ 00098 shared = 0; /* Assume data is not shared */ 00099 count = tip->count; 00100 elsize = tip->elsize; 00101 fillen = tip->extlen; 00102 00103 if (count == 0) 00104 return(0); 00105 00106 if (tip->type90 == DVTYPE_ASCII) 00107 fillen = fillen * elsize; 00108 00109 incb = tip->stride * elsize; /* Stride in bytes */ 00110 00111 if ( cup->ueor_found ) { 00112 errn = FERDPEOR; 00113 goto done; 00114 } 00115 00116 if (cup->useq == 0) { /* If direct access file */ 00117 register int64 newpos; 00118 register int64 recl; 00119 00120 newpos = cup->urecpos + count * fillen; /* in bits */ 00121 recl = (int64) (cup->urecl); 00122 00123 if ((recl << 3) < newpos) { 00124 /* 00125 * The user is asking for more data than can fit in a 00126 * RECL-sized record, so we abort here. 00127 */ 00128 errn = FERDPEOR; 00129 goto done; 00130 } 00131 } 00132 00133 #ifdef _CRAYT3D 00134 if (_issddptr(ptr)) { 00135 /* ptr points to shared data descriptor. */ 00136 /* If we have a layer that handles sdds someday, we */ 00137 /* could check for that here and not set shared. */ 00138 /* We'd also probably want to make sure that we are */ 00139 /* not doing foreign data conversion */ 00140 css->f_shrdput = 1; 00141 shared = 1; 00142 elwords = elsize / sizeof(long); 00143 } 00144 #endif 00145 /* 00146 * If contiguous memory, transfer all data at once. 00147 */ 00148 if ((shared == 0) && ((count == 1) || (incb == elsize))) { 00149 register long ret; 00150 00151 ret = _frwd(cup, ptr, tip, PARTIAL, (int *) NULL, 00152 (long *) NULL, &status); 00153 00154 if ( ret == IOERR ) { 00155 errn = errno; 00156 goto done; 00157 } 00158 00159 if ( status == EOR ) { 00160 cup->ueor_found = YES; 00161 cup->uend = BEFORE_ENDFILE; 00162 } 00163 else if ( status == CNT ) 00164 cup->uend = BEFORE_ENDFILE; 00165 00166 if ( ret < count ) { 00167 if (status == EOF || status == EOD) 00168 goto endfile_record; 00169 errn = FERDPEOR; 00170 goto done; 00171 } 00172 00173 return(0); 00174 } 00175 /* 00176 * Stride is such that memory is not contiguous, break the request 00177 * into chunks and do a scatter on the items when read. 00178 */ 00179 items = (LOCBUFLN * sizeof(long)) / elsize; /* chop it into chunks */ 00180 00181 assert( ! (shared && items == 0) ); /* don't support shared char */ 00182 00183 if (items == 0) 00184 items = 1; /* must be character*BIG array*/ 00185 00186 frwdbuf = lbuf; 00187 00188 for ( i = 0; i < count; i += items ) { 00189 register long ret; 00190 00191 /* trim the item count if not a full buffer's worth */ 00192 00193 if (items > count - i) 00194 items = count - i; 00195 00196 tip->count = items; 00197 00198 /* 00199 * Read data into lbuf, scatter items from lbuf into the 00200 * user array, and then write out a chunk. If items == 1, 00201 * we suppress the extra data copy for performance and because 00202 * it might not fit in the lbuf if it is character*BIG data. 00203 * 00204 * We don't have to worry about shared data not fitting in 00205 * lbuf since character data is never shared. 00206 */ 00207 if ((items == 1) && (shared == 0)) 00208 frwdbuf = ptr; /* read directly to user array */ 00209 00210 ret = _frwd(cup, frwdbuf, tip, PARTIAL, (int *) NULL, 00211 (long *) NULL, &status); 00212 00213 #ifdef _CRAYT3D 00214 if (shared) 00215 _cpytosdd(ptr, lbuf, items, elwords, tip->stride, i); 00216 else 00217 #endif 00218 if (items > 1) 00219 _scatter_data (ptr, items, incb, elsize, lbuf); 00220 00221 if ( ret == IOERR ) { 00222 errn = errno; 00223 goto done; 00224 } 00225 if ( status == EOR ) { 00226 cup->ueor_found = YES; 00227 /* If not last iteration, this is an error */ 00228 if ((i + ret) < count) { 00229 errn = FERDPEOR; 00230 goto done; 00231 } 00232 } 00233 00234 if (i == 0) 00235 if (status == EOR || status == CNT) 00236 cup->uend = BEFORE_ENDFILE; 00237 00238 /* 00239 * We know that items > 0 00240 */ 00241 if ( ret < items ) { 00242 if (status == EOF || status == EOD) 00243 goto endfile_record; 00244 errn = FERDPEOR; 00245 goto done; 00246 } 00247 00248 if (!shared) 00249 ptr = (char *) ptr + (ret * incb); 00250 } 00251 00252 done: 00253 /* Process any error which occurred */ 00254 00255 if (errn > 0) { 00256 if ((cup->uflag & (_UERRF | _UIOSTF)) == 0) 00257 _ferr(css, errn); /* Run-time error */ 00258 } 00259 else if (errn < 0) { 00260 if ((cup->uflag & (_UENDF | _UIOSTF)) == 0) 00261 _ferr(css, errn); /* EOF-type error */ 00262 } 00263 00264 return(errn); 00265 00266 endfile_record: 00267 /* 00268 * EOF/EOD is an error on direct access, an end 00269 * condition on sequential access. 00270 */ 00271 if (status == EOF) { 00272 cup->uend = PHYSICAL_ENDFILE; 00273 errn = FERDPEOF; 00274 } 00275 else { /* End of data */ 00276 if (cup->uend == 0) { 00277 cup->uend = LOGICAL_ENDFILE; 00278 errn = FERDPEOF; 00279 } 00280 else 00281 errn = FERDENDR; 00282 } 00283 00284 if (!(cup->useq)) /* If direct access */ 00285 errn = FENORECN; /* Record does not exist */ 00286 00287 goto done; 00288 }