/* * _wrfmt() Write format processing * * uss Current Fortran I/O statement state pointer * cup Unit pointer * dptr Pointer to data * tip Type information packet */ int _wrfmt( FIOSPTR css, /* Current Fortran I/O statement state */ unit *cup, /* Unit pointer */ void *dptr, /* Pointer to data */ type_packet *tip, /* Type information packet */ int _Unused /* Unused by this routine */ ) { register short cswitch; /* 1 if complex data; else zero */ register short fmtop; /* Current format operator */ register short part; /* Part of datum (complex is 2-part) */ register short supflg; /* Is variable eligible to be suppressed */ register ftype_t type; /* Fortran data type */ register int32 delta; /* Length/field width difference */ register int32 field; /* Consecutive conversion field size */ register int32 i; /* Scratch loop variable */ register int32 kount; /* Number of consecutive conversions */ register int32 length; /* Length of datum in bytes */ register int32 repcnt; /* Local copy of *css->u.fmt.pftocs */ int cinc[2]; /* Increments for datum parts */ register int stat; /* Error code */ register int stride; /* Stride between data in bytes */ register char *cptr; /* Character pointer to datum */ register char *ctmp; /* Temporary character pointer */ long digits; /* Digits field of edit-descriptor */ long exp; /* Exponent field of edit-descriptor */ long mode; /* Mode word for conversion */ long width; /* Width field of edit-descriptor */ register long count; /* Number of data items */ register long dfmode; /* MODESN/MODE77 mode bits */ fmt_type pfmt; /* Current parsed format entry */ #ifdef _CRAYT3D register short shared; /* Is variable shared? */ register int elwords; /* Number of words per item */ register int offset; /* Offset from address in item units */ register int32 tcount; /* Number of items to move */ long shrd[MAXSH]; /* Buffer for shared data */ #endif #ifndef KEY /* this causes wrong function being called when compiled by gcc */ const #endif oc_func *ngcf; /* Generic NOCV-type conversion func */ /* If these assertions are not all true, then we're in deep doo-doo */ assert (cup != NULL); assert (tip != NULL); type = tip->type90; count = tip->count; cswitch = 0; stat = 0; part = 1; pfmt = *css->u.fmt.u.fe.pfcp; repcnt = *css->u.fmt.u.fe.pftocs; length = tip->elsize; stride = tip->stride * length; cinc[1] = stride; supflg = _o_sup_flg_tab[type] && (length == sizeof(long)); #ifdef KEY register short width_zero_flag = FALSE; #endif /* If COMPLEX data type, adjust data length and increments */ if (type == DVTYPE_COMPLEX) { length = length / 2; cinc[0] = length; cinc[1] = stride - length; cswitch = 1; part = 0; } dfmode = ((cup->uft90 == 0) ? MODE77 : 0) | ((css->u.fmt.cplus == 1) ? MODESN : 0); #ifdef _CRAYT3D if (_issddptr(dptr)) { offset = 0; elwords = tip->elsize / sizeof(long); shared = 1; stride = tip->elsize; tcount = count; } else shared = 0; do { if (shared) { /* we copy the data into local array shrd, and write */ /* from there */ count = MIN(MAXSH/elwords, (tcount - offset)); cptr = (char *) shrd; (void) _cpyfrmsdd(dptr, shrd, count, elwords, tip->stride, offset); offset = offset + count; } else #endif { cptr = (char *) dptr; } do { /* M A I N L O O P */ fmtop = pfmt.op_code; /* Get operator */ width = pfmt.field_width; /* And main parameter */ digits = pfmt.digits_field; /* And secondary parameter */ exp = pfmt.exponent; /* Basic sanity check on the parsed format */ if (fmtop > LAST_OP || fmtop < FIRST_DATA_ED) { stat = FEINTIPF; /* Invalid parsed format */ goto done; } if (fmtop <= LAST_DATA_ED || fmtop == STRING_ED) { if (fmtop == STRING_ED) kount = repcnt; else { /* fmtop <= LAST_DATA_ED */ /* * We have a data-edit descriptor and if the * count is exhausted, then we're done (for * the time being). */ if (count == 0) goto done; /* * Validate the data edit-descriptor against * the data type and do the Fortran 90 mapping * G data edit-descriptor. */ if (INVALID_WTYPE(fmtop, type)) { /* Type mismatch */ stat = FEWRTYPE; goto done; } if (fmtop == G_ED) { fmtop = _odedtab[type]; if (type != DVTYPE_REAL && type != DVTYPE_COMPLEX) digits = 1; } /* * Set (or reset) the default mode for the * numeric conversion routines. */ if (type == DVTYPE_ASCII) mode = 0; else { mode = (long) _wr_ilchk[fmtop-1][length-1]; if (mode == INVALID_INTLEN) { /* Type mismatch */ stat = FEWRTYPE; goto done; } } /* if real and the flag to skip write * of minus sign of -0.0 is set, set * mode bit for conversion routines. */ if ((type == DVTYPE_REAL || type == DVTYPE_COMPLEX) && cup->ufnegzero != 0) mode = mode | MODEMSN; mode = mode | dfmode; /* Add defaults */ /* * Handle zero-width formats. */ if (width == 0) { switch (fmtop) { /* * For character (A/R) data edit- * descriptors, the width is the * length of the datum. */ case A_ED: case R_ED: width = length; break; /* * For integer (B/I/O/Z) data edit- * descriptors, the width is the * maximum number of "digits" plus * one for a leading blank and (I * only) one for an optional sign. */ case B_ED: case I_ED: case O_ED: case Z_ED: #ifdef KEY width_zero_flag = TRUE; #endif width = _rw_mxdgt[fmtop-1][length-1]; /* Fix limitation in table */ if (width == 127) width = 128; if (pfmt.default_digits) digits = 1; else if (width < digits) width = digits; /* Allow for blank and sign */ width = width + 1; if (fmtop == I_ED) width = width + 1; /* * The (f95) standard explicitly * requires that {B|I|O|Z}0.0 * format with a zero datum * produce exactly one blank. * The only practical way to do * this is to peek at the datum * now and--if it's zero--adjust * the field width accordingly. */ if (digits == 0) { register int64 datum; switch (length) { case 8: datum = *(int64 *) cptr; break; #ifndef _CRAY1 case 4: datum = *(int32 *) cptr; break; #endif /* KEY: this should probably be #if _F_INT2 */ #if defined(__mips) || defined(_SOLARIS) || defined(_LITTLE_ENDIAN) case 2: datum = *(short *) cptr; break; case 1: datum = *cptr; break; #endif } /* switch */ #ifdef KEY if (datum == 0) { width = 1; width_zero_flag = FALSE; } #else if (datum == 0) width = 1; #endif /* KEY */ } break; /* * For floating-point (D/E/EN/ES/F/G) * data edit-descriptors, the width * is the number of significant digits * plus the max. size of the exponent * plus six (for a leading blank, an * optional sign, an optional leading * zero, a decimal point, the 'E' * exponent designator, and the * exponent sign). */ case D_ED: case E_ED: case EN_ED: case ES_ED: case F_ED: case G_ED: #ifdef KEY width_zero_flag = TRUE; #endif if (pfmt.default_digits) digits = _rw_mxdgt[fmtop-1][length-1]; if (exp == 0) { if (length == 16) exp = DEXP16; #ifdef _F_REAL4 else if (length == 4) exp = DEXP4; #endif else exp = DEXP8; } width = digits + exp + 6; break; /* * For logical (L) data edit- * descriptors, the width is always * two (one for the 'T' or 'F' and * the other for a leading blank). */ case L_ED: width = _rw_mxdgt[fmtop-1][length-1]; break; /* * For Q data edit-descriptors, the * width is zero--no data is consumed. */ case Q_ED: width = 0; break; /* * Should never arrive here. */ default: width = -1; break; } /* switch */ /* * Sanity check for valid width. */ if (width < 0) { stat = FEWRTYPE; goto done; } } /* * Set the number of consecutive data items, and be * sure to adjust for the case when we're in the * middle of a complex datum. */ kount = MIN(repcnt, ((count << cswitch) - (part & cswitch))); } field = width * kount; /* * Check to see if we have an outstanding TR condition. * If so, then blank fill that portion of the record * which extends beyond the existing highwater mark * (cup->ulinemax); but in no case go beyond the end of * the line buffer (cup->urecsize). */ if (cup->ulinecnt > cup->ulinemax) { register short j, k; if (cup->ulinecnt > cup->urecsize) { stat = FEWRLONG; /* Record too long*/ goto done; } k = cup->ulinecnt; /* The following loop should vectorize */ for (j = cup->ulinemax; j < k; j++) cup->ulinebuf[j] = BLANK; /* Update highwater mark */ cup->ulinemax = cup->ulinecnt; } /* * See if processing the current batch of edit- * descriptors will overflow the line. If so, * see if there's room for one more. */ if ((cup->ulinecnt + field) > cup->urecsize) { if ((cup->ulinecnt + width) > cup->urecsize) { stat = FEWRLONG; /* Record too long */ goto done; } else { /* Do one item */ kount = 1; field = width; } } } switch (fmtop) { /* Process numeric-type output */ case B_ED: case O_ED: case Z_ED: case D_ED: case E_ED: case EN_ED: case ES_ED: case F_ED: case G_ED: case I_ED: case L_ED: ngcf = _oconvtab[fmtop]; #ifdef _CRAY #pragma _CRI align #endif for (i = 0; i < kount; i++) { /* For consecutive items */ /* Convert next item */ if (supflg && (_o_sup_val_tab[type] == *(long *) cptr)) { register short j; #ifdef _CRAY1 #pragma _CRI ivdep #endif for (j = 0; j < width; j++) cup->ulineptr[j] = BLANK; } else{ (void) ngcf(cptr, cup->ulineptr, &mode, &width, &digits, &exp, &css->u.fmt.u.fe.scale); #ifdef KEY // Fix bug 573 (zero width problem) if (width_zero_flag){ long *p = cup->ulineptr; register short counter = 0; register short k; long linebuf[100]; for ( k = 0; k < width; k++, p++) { if (*p == BLANK) continue; linebuf[counter++] = *p; } if (width > counter) width = counter; p = cup->ulineptr; for (k = 0; counter; counter--,p++,k++) *p = linebuf[k]; for (; *p ; p++) *p = 0; // Bug 3992 field = width; } #endif } /* Advance data addresses */ cup->ulineptr = cup->ulineptr + width; count = count - part; cptr = cptr + cinc[part]; part = part ^ cswitch; } cup->ulinecnt = cup->ulinecnt + field; /* Set new highwater mark, if necessary */ if (cup->ulinecnt > cup->ulinemax) cup->ulinemax = cup->ulinecnt; repcnt = repcnt - kount; break; /* Process nonnumeric (character) output */ case A_ED: case R_ED: delta = width - length; /* * Check if format width equals data length and we have * a stride of one. If so, then we can move all of the * data in one fell swoop. */ if (delta == 0 && tip->stride == 1) { register short knt; (void) _unpack(cptr, cup->ulineptr, field, -1); cup->ulineptr = cup->ulineptr + field; knt = kount >> cswitch; if (cswitch != 0 && ((kount & 01) != 0)) { /* If complex and odd count */ count = count - part; cptr = cptr + cinc[part]; part = part ^ 1; } count = count - knt; cptr = cptr + (stride * knt); } else #ifdef _CRAY #pragma _CRI align #endif for (i = 0; i < kount; i++) { /* For consecutive items */ ctmp = cptr; /* * If the field width is wider than the length * of the variable, we need to generate blanks * for part of the field. */ if (delta > 0) { register short j; /* The following loop should vectorize */ for (j = 0; j < delta; j++) cup->ulineptr[j] = BLANK; /* Move the actual data */ (void) _unpack(ctmp, cup->ulineptr + delta, length, -1); } else { /* * If doing R format and the variable is * larger than the field, we need to * right-justify the data in the field. */ if (fmtop == R_ED) ctmp = ctmp - delta; /* Move the actual data */ (void) _unpack(ctmp, cup->ulineptr, width, -1); } /* Advance data addresses */ cup->ulineptr = cup->ulineptr + width; count = count - part; cptr = cptr + cinc[part]; part = part ^ cswitch; } cup->ulinecnt = cup->ulinecnt + field; /* Set new highwater mark, if necessary */ if (cup->ulinecnt > cup->ulinemax) cup->ulinemax = cup->ulinecnt; repcnt = repcnt - kount; break; case SLASH_ED: stat = (*css->u.fmt.endrec)(css, cup, width); repcnt = repcnt - 1; break; case TR_ED: cup->ulinecnt = cup->ulinecnt + width; cup->ulineptr = cup->ulineptr + width; repcnt = repcnt - 1; break; case T_ED: cup->ulinecnt = width - 1; cup->ulineptr = cup->ulinebuf + (width - 1); repcnt = 1; /* Ingore repeat count */ goto check_left; case TL_ED: cup->ulinecnt = cup->ulinecnt - width; cup->ulineptr = cup->ulineptr - width; check_left: /* * If tabbed off the beginning of the record, then * move back to column 1 (relative to left tab limit). */ if (cup->ulineptr < css->u.fmt.leftablim) { cup->ulineptr = css->u.fmt.leftablim; cup->ulinecnt = cup->ulineptr - cup->ulinebuf; } repcnt = repcnt - 1; break; case STRING_ED: ctmp = (char *) (css->u.fmt.u.fe.pfcp + 1); if (width > 0) { /* Copy literal to line buffer */ for (i = 0; i < kount; i++) { (void) _unpack(ctmp, cup->ulineptr, width, -1); cup->ulineptr = cup->ulineptr + width; } cup->ulinecnt = cup->ulinecnt + field; /* Set new highwater mark, if necessary */ if (cup->ulinecnt > cup->ulinemax) cup->ulinemax = cup->ulinecnt; } repcnt = repcnt - kount; break; case BN_ED: /* BN and BZ have no effect on output */ case BZ_ED: repcnt = 0; /* Ignore repeat count */ break; case S_ED: case SS_ED: css->u.fmt.cplus = 0; dfmode = dfmode & ~MODESN; repcnt = 0; /* Ignore repeat count*/ break; case SP_ED: css->u.fmt.cplus = 1; dfmode = dfmode | MODESN; repcnt = 0; /* Ignore repeat count*/ break; case P_ED: css->u.fmt.u.fe.scale = pfmt.rep_count; repcnt = 0; /* No repeat cnt for P*/ break; case Q_ED: /* * The Q edit-descriptor is invalid on output. */ stat = FEFMTQIO; repcnt = repcnt - 1; break; case COLON_ED: /* * We have a colon edit-descriptor and, if the count * is zero, we're done for now. */ if (count == 0) goto done; repcnt = 0; /* Ignore repeat count */ break; case DOLLAR_ED: css->u.fmt.nonl = 1; repcnt = 0; /* Ignore repeat count */ break; case REPEAT_OP: /* * Start of repeated format group. Stack the repeat * count and advance to the next format token. */ *css->u.fmt.u.fe.pftocs++ = pfmt.rep_count; repcnt = 0; /* Force advance */ break; case ENDREP_OP: /* * End of repeated format group. Decrement the * stacked count. If the repeat count has not * been satisfied then proceed to the first format * token of the repeat group; otherwise unstack * the repeat count and advance to the next format * token. */ if ( --(*(css->u.fmt.u.fe.pftocs - 1)) < 1) css->u.fmt.u.fe.pftocs--; /* Pop repeat count */ else css->u.fmt.u.fe.pfcp = css->u.fmt.u.fe.pfcp + pfmt.rep_count; repcnt = repcnt - 1; break; case REVERT_OP: /* * If the revert group does not contain any data * edit-descriptors and iolist items remain * (defined as a nonzero count), then we have an * infinite format loop. */ if (pfmt.rgcdedf == 0 && count > 0) stat = FEFMTILF; /* Infinite format loop */ else { /* * If the count is zero, then we exit with * the format positioned at the REVERT_OP * entry and subsequent calls can continue * from there, if necessary. If there are * data items remaining (count > 0) then * we flush the record, position the format * to the reversion point, and continue * processing. */ if (count == 0) goto done; /* Write the record */ stat = (*css->u.fmt.endrec)(css, cup, 1); repcnt = 0; /* Force advancement */ /* Position format to reversion point */ css->u.fmt.u.fe.pfcp = css->u.fmt.u.fe.pfcp + pfmt.rep_count - 1; } break; default: stat = FEINTIPF; /* Invalid parsed format */ break; } /* switch (fmtop) */ /* * If the repeat count has been exhausted then advance to * the next format token. */ if (stat == 0 && repcnt < 1) { if (fmtop == STRING_ED) css->u.fmt.u.fe.pfcp = css->u.fmt.u.fe.pfcp + ((width + FMT_ENTRY_BYTE_SIZE - 1) / FMT_ENTRY_BYTE_SIZE); css->u.fmt.u.fe.pfcp = css->u.fmt.u.fe.pfcp + 1; pfmt = *css->u.fmt.u.fe.pfcp; fmtop = pfmt.op_code; width = pfmt.field_width; repcnt = pfmt.rep_count; css->u.fmt.u.fe.fmtcol = pfmt.offset; /* pos in fmt */ } } while (stat == 0); done: #ifdef _CRAYT3D continue; } while (stat == 0 && shared && offset < tcount);
static void _rb( FIOSPTR css, /* Current Fortran I/O state */ unit *cup, /* Unit pointer */ _f_int *recmode, /* Mode */ gfptr_t bloc, /* Beginning location */ gfptr_t eloc, /* Ending location */ type_packet *tip) /* Type information packet */ { register int bytshft; register int mode; register long bytes; register long elsize; register long itemlen; register long items; register long stat; register ftype_t type90; int state; char *uda, *udax; #ifdef _CRAYT3D register short shared; register long ntot; register long numleft; long shrd[MAXSH]; #endif if (cup->useq == 0) /* If direct access file */ _ferr(css, FEBIONDA, "BUFFER IN"); if (cup->ufmt) /* If formatted file */ _ferr(css, FEBIONFM, "BUFFER IN"); if (cup->uerr && !cup->unitchk) _ferr(css, cup->uffsw.sw_error); /* * This check taken out temporarily because we'd like to be able to * follow an ENDFILE statement or a READ which encounters an endfile * record with a BUFFER IN statement. The sticky EOF principle should * permit such a BUFFER IN to simply return an EOF status. But what * really happens is the preceding ENDFILE or READ statement sets * cup->uend, triggering an error here. We really need a flag to * store the status of the previous BUFFER IN/OUT statement which is * separate from cup->uend. * * if (cup->uend && !cup->unitchk) * _ferr(css, FERDPEOF); */ cup->unitchk = 0; cup->uerr = 0; elsize = tip->elsize; /* Data size in bytes */ type90 = tip->type90; /* * Adjust the word count depending on the type. */ bytshft = ((sizeof(elsize) << 3) - 1) - _leadz(elsize); /* log2(elsize) */ if (type90 == DVTYPE_ASCII) { /* If character item */ uda = _fcdtocp(bloc.fcd); udax = _fcdtocp(eloc.fcd); itemlen = _fcdlen (eloc.fcd); } else { #ifdef _CRAYT3D shared = 0; if (_issddptr(bloc.v)) { int *tmpptr; /* Shared data */ if (!_issddptr(eloc.v)) { _ferr(css, FEINTUNK); } shared = 1; ntot = 0; if ((cup->ufs == FS_FDC) && (cup->uflagword & FFC_ASYNC)) { /* When we can do I/O from shared memory */ /* we can support this. */ _ferr(css, FESHRSUP); } /* * When compiler spr 76429 (on T3D) is closed, we can try replacing * the lines that use tmpptr with this. * items = _sdd_read_offset((void *)eloc.v) - * _sdd_read_offset((void *)bloc.v) + 1; */ uda = bloc.v; /* temporary */ udax = eloc.v; tmpptr = (int *)((int)udax & 0x7fffffffffffffff); items = *(tmpptr + 1); tmpptr = (int *)((int)uda & 0x7fffffffffffffff); items = items - *(tmpptr + 1) + 1; } else #endif /* _CRAYT3D */ { uda = bloc.v; udax = eloc.v; } itemlen = elsize; } #ifdef _CRAYT3D if (shared) { bytes = items << bytshft; } else #endif { bytes = (udax - uda) + itemlen; items = bytes >> bytshft; } if (bytes < 0) _ferr(css, FEBIOFWA, "BUFFER IN"); mode = (*recmode < 0) ? PARTIAL : FULL; cup->urecmode = mode; cup->uwrt = 0; state = CNT; if ((items << bytshft) != bytes) _ferr(css, FEBIOFWD); #ifdef _CRAYT3D if ( !shared && cup->uasync ) { #else if (cup->uasync) { #endif int ubc = 0; WAITIO(cup, _ferr(css, cup->uffsw.sw_error)); #if defined(_UNICOS) || defined(NUMERIC_DATA_CONVERSION_ENABLED) /* * Pad word-aligned numeric data on word boundaries within * the record for CRI and some foreign data formats. */ if ((cup->urecpos & cup->ualignmask) != 0 && type90 != DVTYPE_ASCII && elsize > 4 ) { int padubc; register int pbytes; int padval; COMPADD(cup, pbytes, padubc, padval); if (pbytes != 0) { stat = XRCALL(cup->ufp.fdc, readrtn) cup->ufp.fdc, WPTR2BP(&padval), pbytes, &cup->uffsw, PARTIAL, &padubc); if (stat != pbytes || FFSTAT(cup->uffsw) != FFCNT) { cup->uerr = 1; goto badpart; } cup->urecpos += (stat << 3) - padubc; } }
int _wrunf( #endif FIOSPTR css, /* Current Fortran I/O statement state */ unit *cup, /* Unit pointer */ void *ptr, /* Pointer to data */ type_packet *tip, /* Type information packet */ int mode /* Mode argument to _fwwd() */ ) { register short shared; /* 1 iff ptr points to sdd */ register int errn; /* Error number */ register int64 fillen; /* bit size of each element, on disk */ register long count; /* Number of data items */ register long elsize; /* element size in bytes */ register long i; register long incb; /* inc (in units of bytes) */ register long items; long lbuf[LOCBUFLN]; void *fwwdbuf; /* ptr to buffer passed to _fwwd */ #ifdef _CRAYT3D register long elwords; /* element size in words */ #endif errn = 0; shared = 0; count = tip->count; elsize = tip->elsize; fillen = tip->extlen; if (count == 0) return(0); if (tip->type90 == DVTYPE_ASCII) fillen = fillen * elsize; incb = tip->stride * elsize; /* Stride in bytes */ if (cup->useq == 0) { /* If direct access file */ register int64 newpos; register int64 recl; newpos = cup->urecpos + count * fillen; /* in bits */ recl = (int64) (cup->urecl); if ((recl << 3) < newpos) { errn = FEWRLONG; /* output record too long */ goto done; } } #ifdef _CRAYT3D if (_issddptr(ptr)) { /* ptr points to a shared data descriptor */ /* If we have a layer that handles sdds someday, we */ /* could check for that here and not set shared to one. */ /* We'd also probably want to make sure that we're not */ /* doing foreign data converion */ shared = 1; elwords = elsize / sizeof(long); } #endif /* * If only one item, or stride is such that data is contiguous, * do it all at once */ if ((shared == 0) && ((count == 1) || (incb == elsize))) { register long ret; int status; if (mode == FULL) cup->f_lastwritten = 1; ret = _fwwd(cup, ptr, tip, mode, (int *) NULL, (long *) NULL, &status); if ( ret == IOERR ) { errn = errno; goto done; } return(0); } /* * Stride is such that memory is not contiguous, break the request * into chunks and do a gaterh on the items before writing. */ items = (LOCBUFLN * sizeof(long)) / elsize; /* chop it in chunks */ assert( ! (shared && items == 0) ); /* don't support shared char */ if (items == 0) items = 1; /* must be character*BIG array*/ fwwdbuf = lbuf; for ( i = 0; i < count; i = i + items ) { register long ret; int status; /* trim the item count if not a full buffer's worth */ if (items > count - i) items = count - i; tip->count = items; /* * Gather items from user array into lbuf, and then write * out a chunk. If items == 1, we suppress the extra data * copy for performance and because it might not fit in the * lbuf if it is character*BIG data. * * We don't have to worry about shared data not fitting * in lbuf since character data is never shared. */ #ifdef _CRAYT3D if (shared) _cpyfrmsdd(ptr, lbuf, items, elwords, tip->stride, i); else #endif { if (items > 1) _gather_data (lbuf, items, incb, elsize, ptr); else fwwdbuf = ptr; } if ( mode == FULL && (i+items >= count)) { cup->f_lastwritten = 1; ret = _fwwd(cup, fwwdbuf, tip, FULL, (int *) NULL, (long *) NULL, &status); } else ret = _fwwd(cup, fwwdbuf, tip, PARTIAL, (int *) NULL, (long *) NULL, &status); if ( ret == IOERR ) { errn = errno; goto done; } if (!shared) ptr = (char *)ptr + (ret * incb); } done: if (errn > 0) { if ((cup->uflag & (_UERRF | _UIOSTF)) == 0) _ferr(css, errn); /* Run-time error */ } return(errn); }
int _rdunf( #endif FIOSPTR css, /* Current Fortran I/O statement state */ unit *cup, /* Unit pointer */ void *ptr, /* Pointer to data */ type_packet *tip, /* Type information packet */ int _Unused /* Unused by this routine */ ) { register short shared; /* 1 iff ptr points to shared data */ register int errn; /* Error number */ register int64 fillen; /* bit size of each element, on disk */ register long count; /* Number of data items */ register long elsize; /* element size in bytes */ register long i; register long incb; /* inc (in units of bytes) */ register long items; int status; long lbuf[LOCBUFLN]; void *frwdbuf; /* ptr to buffer passed to _frwd */ #ifdef _CRAYT3D register long elwords; /* element size in words */ #endif errn = 0; /* Clear error number */ shared = 0; /* Assume data is not shared */ count = tip->count; elsize = tip->elsize; fillen = tip->extlen; if (count == 0) return(0); if (tip->type90 == DVTYPE_ASCII) fillen = fillen * elsize; incb = tip->stride * elsize; /* Stride in bytes */ if ( cup->ueor_found ) { errn = FERDPEOR; goto done; } if (cup->useq == 0) { /* If direct access file */ register int64 newpos; register int64 recl; newpos = cup->urecpos + count * fillen; /* in bits */ recl = (int64) (cup->urecl); if ((recl << 3) < newpos) { /* * The user is asking for more data than can fit in a * RECL-sized record, so we abort here. */ errn = FERDPEOR; goto done; } } #ifdef _CRAYT3D if (_issddptr(ptr)) { /* ptr points to shared data descriptor. */ /* If we have a layer that handles sdds someday, we */ /* could check for that here and not set shared. */ /* We'd also probably want to make sure that we are */ /* not doing foreign data conversion */ css->f_shrdput = 1; shared = 1; elwords = elsize / sizeof(long); } #endif /* * If contiguous memory, transfer all data at once. */ if ((shared == 0) && ((count == 1) || (incb == elsize))) { register long ret; ret = _frwd(cup, ptr, tip, PARTIAL, (int *) NULL, (long *) NULL, &status); if ( ret == IOERR ) { errn = errno; goto done; } if ( status == EOR ) { cup->ueor_found = YES; cup->uend = BEFORE_ENDFILE; } else if ( status == CNT ) cup->uend = BEFORE_ENDFILE; if ( ret < count ) { if (status == EOF || status == EOD) goto endfile_record; errn = FERDPEOR; goto done; } return(0); } /* * Stride is such that memory is not contiguous, break the request * into chunks and do a scatter on the items when read. */ items = (LOCBUFLN * sizeof(long)) / elsize; /* chop it into chunks */ assert( ! (shared && items == 0) ); /* don't support shared char */ if (items == 0) items = 1; /* must be character*BIG array*/ frwdbuf = lbuf; for ( i = 0; i < count; i += items ) { register long ret; /* trim the item count if not a full buffer's worth */ if (items > count - i) items = count - i; tip->count = items; /* * Read data into lbuf, scatter items from lbuf into the * user array, and then write out a chunk. If items == 1, * we suppress the extra data copy for performance and because * it might not fit in the lbuf if it is character*BIG data. * * We don't have to worry about shared data not fitting in * lbuf since character data is never shared. */ if ((items == 1) && (shared == 0)) frwdbuf = ptr; /* read directly to user array */ ret = _frwd(cup, frwdbuf, tip, PARTIAL, (int *) NULL, (long *) NULL, &status); #ifdef _CRAYT3D if (shared) _cpytosdd(ptr, lbuf, items, elwords, tip->stride, i); else #endif if (items > 1) _scatter_data (ptr, items, incb, elsize, lbuf); if ( ret == IOERR ) { errn = errno; goto done; } if ( status == EOR ) { cup->ueor_found = YES; /* If not last iteration, this is an error */ if ((i + ret) < count) { errn = FERDPEOR; goto done; } } if (i == 0) if (status == EOR || status == CNT) cup->uend = BEFORE_ENDFILE; /* * We know that items > 0 */ if ( ret < items ) { if (status == EOF || status == EOD) goto endfile_record; errn = FERDPEOR; goto done; } if (!shared) ptr = (char *) ptr + (ret * incb); } done: /* Process any error which occurred */ if (errn > 0) { if ((cup->uflag & (_UERRF | _UIOSTF)) == 0) _ferr(css, errn); /* Run-time error */ } else if (errn < 0) { if ((cup->uflag & (_UENDF | _UIOSTF)) == 0) _ferr(css, errn); /* EOF-type error */ } return(errn); endfile_record: /* * EOF/EOD is an error on direct access, an end * condition on sequential access. */ if (status == EOF) { cup->uend = PHYSICAL_ENDFILE; errn = FERDPEOF; } else { /* End of data */ if (cup->uend == 0) { cup->uend = LOGICAL_ENDFILE; errn = FERDPEOF; } else errn = FERDENDR; } if (!(cup->useq)) /* If direct access */ errn = FENORECN; /* Record does not exist */ goto done; }