static int
lw_A(
FIOSPTR css,
char *ptr, /* Points to character data to be output */
int charlen,/* Length of data to be output */
long recsize,/* Number of characters per line for REPFLUSH */
unit *cup, /* Unit table pointer */
int errf, /* Error flag */
struct BUFFERS *bptr /* Structure containing formatting buffers */
)
{
int m;
char *aposptr;
int ss;
int fflag;
int recmax;
/*
* Copy the data into the formatting buffer. The data is
* surrounded by apostrophes. If there is an apostrophe in
* the data it must be output as two apostrophes.
*/
fflag = 0;
*bptr->f_lbufptr++ = (long) '\'';
bptr->f_lbufcnt++;
for (; charlen > 0; ) {
if (fflag == 0) {
recmax = recsize - 2;
m = MIN(charlen, recmax - bptr->f_lbufcnt);
}
else {
recmax = recsize - 1;
m = MIN(charlen, recmax - bptr->f_lbufcnt);
}
/* Is there an apostrophe in the data? */
aposptr = memchr(ptr, '\'', m);
if (aposptr != 0) {
/* aposptr points to next apostrophe */
m = aposptr + 1 - ptr;
/* Move everything up to, and including, apostrophe */
(void) _unpack(ptr, bptr->f_lbufptr, m, -1);
*(bptr->f_lbufptr + m) = '\''; /* Double apostrophe */
ptr = ptr + m;
charlen = charlen - m;
m++;
}
else {
/* Move everything */
(void) _unpack(ptr, bptr->f_lbufptr, m, -1);
ptr = ptr + m;
charlen = charlen - m;
}
bptr->f_lbufptr += m;
bptr->f_lbufcnt += m;
/*
* If we've filled a record, write it out.
*/
if (bptr->f_lbufcnt >= recmax) {
if (bptr->outcnt <= bptr->f_lbufcnt) {
REPFLUSH();
/* If this is a continuation of one */
/* character variable, start it in col. 2 */
/* Otherwise, start it in col. 3 */
if (fflag == 1) {
bptr->outptr--; /* start in col. 2 */
bptr->outcnt++;
}
fflag = 1;
}
bptr->f_lbufptr = bptr->f_lbuf;
_memwcpy(bptr->outptr, bptr->f_lbufptr,
bptr->f_lbufcnt);
bptr->outptr += bptr->f_lbufcnt;
bptr->outcnt -= bptr->f_lbufcnt;
bptr->f_lbufptr = bptr->f_lbuf;
bptr->f_lbufcnt = 0;
}
} /* for */
*bptr->f_lbufptr++ = (long) '\'';
bptr->f_lbufcnt++;
LPUT(OUT_SEP);
LPUT(' ');
LPUT(' ');
bptr->lcomma = 1;
if (bptr->outcnt <= bptr->f_lbufcnt) {
/* If there is not enough room in outbuff to copy
* in the contents of f_lbuf,
* write what's in outbuff
*/
REPFLUSH();
/* If this is a continuation of 1 character variable, */
/* start it in col. 2. Otherwise, start it in col. 3*/
if (fflag == 1) {
bptr->outptr--;
bptr->outcnt++;
}
}
bptr->f_lbufptr = bptr->f_lbuf;
_memwcpy(bptr->outptr, bptr->f_lbufptr, bptr->f_lbufcnt);
bptr->outptr += bptr->f_lbufcnt;
bptr->outcnt -= bptr->f_lbufcnt;
bptr->f_lbufptr = bptr->f_lbuf;
bptr->f_lbufcnt = 0;
return(0);
ret:
return(ss);
}
/*
* _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 int
l_write(
FIOSPTR css,
unit *cup, /* Current unit pointer */
void *dptr, /* Address of data */
unsigned elsize, /* Bytes per element (used for char type only)*/
int count, /* Number of elements */
int inc, /* Number of words per element */
int type, /* Type of data */
long recsize,/* Number of characters to output per line */
int errf,
struct BUFFERS *bptr /* Structure containing formatting buffers */
)
{
unsigned int len77;
char *cp; /* points to data if type is DT_CHAR */
long *ptr; /* points to data if type is not DT_CHAR */
long ugly[ITEMBUFSIZ]; /* temporary buffer used for numeric output */
long dig;
long exp;
long mod;
long scl;
long ss;
long wid;
long *ib_ptr; /* pointer into the current item buffer */
long *newp;
int lcount; /* repeat count of current input data group */
oc_func *gcf; /* Generic NOCV-type conversion func */
ftype_t f90type;
if (type == DT_CHAR) {
/*
* Character data is unique in that one value may span
* more than one record when output.
* When we can handle opening the output file with a
* 'DELIM=' descriptor (see Ansi 8x Fortran standard), this
* code will need to change. For now, delimit the constant
* with apostrophes, and double all internal apostrophes.
*/
cp = dptr;
len77 = elsize;
for (; count > 0; count-- ) {
bptr->lcomma = 0;
if (count > 1) {
/*
* If we have an array of character data,
* determine if any values are repeated.
*/
cp = char_rep(cp, count, len77, &lcount,
bptr);
count = count - (lcount - 1);
}
/* Write the character constant */
ss = lw_A(css, cp, len77, recsize, cup, errf, bptr);
if (ss != 0) {
RERR(css, ss);
}
cp = cp + len77;
} /* for */
return(0);
} /* if (type == DT_CHAR) */
/* Noncharacter data */
ptr = (long *)dptr;
f90type = _f77_to_f90_type_cnvt[type];
if ((type == DT_DBLE) || (type == DT_CMPLX))
inc = inc + inc;
for (; count > 0; count--, ptr += inc) {
if (count > 1) { /* find repeat values */
ptr = find_rep(ptr, count, inc, type, &lcount,
bptr);
count = count - (lcount - 1);
}
ib_ptr = bptr->f_lbufptr;
switch (type) { /* set up for each data type */
case DT_NONE:
gcf = _s2uo; mod = MODEUN; wid = WOCTWRD;
dig = WOCTWRD; exp = 0; scl = 0;
break;
case DT_SINT:
case DT_INT:
gcf = _s2ui; mod = 0; wid = WINT;
dig = 1; exp = 0; scl = 0;
break;
case DT_REAL:
case DT_CMPLX:
gcf = _sd2uge; mod = 0; wid = WREAL8;
dig = _dreal8; exp = DEXP8; scl = 1;
if (YMP80) dig = 9;
break;
case DT_DBLE:
/*
* When printing with D format, decrease
* the digits by one because we are setting
* the scale factor to 1. This ensures that
* _dreal16 digits of precision are printed.
*/
gcf = _sd2udee; mod = MODEDP; wid = WREAL16;
dig = _dreal16-1; exp = DEXP16; scl = 1;
if (YMP80) dig = 25;
break;
}
/*
* Perform the output conversion.
*/
switch (type) { /* set up for each data type */
default: /* Integer, Short Integer, Real, or Double */
#if _F_REAL16 == 1 /* suppress if _f_dble is not fully supported */
if (YMP80 && !cup->uft90 && type == DT_DBLE &&
*(_f_dble *)ptr == 0.0) {
static const char *zero_dp = "0.0E+00";
ib_ptr += _unpack(zero_dp, ib_ptr,
strlen(zero_dp), -1);
break;
}
#endif
newp = gcf(ptr, ugly, &mod, &wid, &dig, &exp, &scl);
if (type == DT_NONE)
*newp++ = 'B';
ib_ptr = ib_ptr + _wnl_beautify(f90type, ugly, newp,
ib_ptr, cup->uft90);
break;
case DT_CMPLX:
*ib_ptr++ = '(';
newp = gcf(ptr, ugly, &mod, &wid, &dig, &exp, &scl);
ib_ptr = ib_ptr + _wnl_beautify(f90type, ugly, newp,
ib_ptr, cup->uft90);
*ib_ptr++ = COMMA;
newp = gcf((_f_real *)ptr + 1, ugly,
&mod, &wid, &dig, &exp, &scl);
ib_ptr = ib_ptr + _wnl_beautify(f90type, ugly, newp,
ib_ptr, cup->uft90);
*ib_ptr++ = ')';
break;
case DT_LOG:
*ib_ptr++ = _lvtob(*(_f_log8 *)ptr)? 'T':'F';
break;
} /* switch */
/*
* Update the item buffer pointers before using LPUT again.
*/
bptr->f_lbufcnt += ib_ptr - bptr->f_lbufptr;
bptr->f_lbufptr = ib_ptr;
LPUT(OUT_SEP);
LPUT(' '); /* put 2 blanks between items */
LPUT(' ');
if (bptr->outcnt <= bptr->f_lbufcnt) {
/*
* If there is not enough room in the line buffer
* to copy the next output value, flush out the line
* and start a new line.
*/
REPFLUSH();
}
bptr->f_lbufptr = bptr->f_lbuf;
_memwcpy(bptr->outptr, bptr->f_lbufptr, bptr->f_lbufcnt);
bptr->outptr += bptr->f_lbufcnt;
bptr->outcnt -= bptr->f_lbufcnt;
bptr->f_lbufptr = bptr->f_lbuf;
bptr->f_lbufcnt = 0;
}
return(0);
ret:
return(ss);
}
long
_frch(
unit *cup,
long *uda,
long chars,
int mode,
long *status)
{
register int bytsiz;
register int chr;
register long nchr;
register long ncnt;
unsigned char tbuf[TBUFSZB], *tp; /* Line buffer */
FILE *fptr;
struct ffsw stat;
struct fdinfo *fio;
#if defined(_SOLARIS) || (defined(_LITTLE_ENDIAN) && !defined(__sv2))
register long count;
char *tpinterim;
#endif
switch (cup->ufs) {
case FS_TEXT:
case STD:
fptr = cup->ufp.std;
/*
* Switch the FILE structure into read mode
*/
#if !defined(_LITTLE_ENDIAN) || (defined(_LITTLE_ENDIAN) && defined(__sv2))
if ((FILE_FLAG(fptr) & (_IOREAD | _IORW)) == _IORW) {
if (FILE_FLAG(fptr) & _IOWRT)
(void) fseek(fptr, 0, SEEK_CUR);
FILE_FLAG(fptr) |= _IOREAD;
}
#endif
/*
* Loop on getc until the character count has been
* exhausted, an end of file is encountered, or end
* of record.
*/
nchr = 0;
#if defined(_SOLARIS) || (defined(_LITTLE_ENDIAN) && !defined(__sv2))
while (nchr < chars) {
fill:
errno = 0;
count = chars - nchr;
tp = tbuf;
count = MIN(TBUFSZB, (count + 1));
tpinterim = fgets((char *)tp, count, fptr);
if (tpinterim == NULL) {
/*
* Search for the newline char in the buffer, but
* search only the number of characters left in
* the request, plus one in case it is the
* newline (if it is in the buffer). If we find
* newline, we're done.
*/
/* EOF here means incomplete record. */
if (ferror(fptr)) {
if ( errno == EINTR && _GINTIO == 0) {
clearerr(fptr);
goto fill;
}
if (errno == 0)
errno = FESTIOER;
return(IOERR);
}
/*
* If nchr > zero, file has no newline.
* Make sure we handle it properly.
*/
if (feof(fptr)) {
if (nchr == 0) {
*status = EOD;
return(0);
}
*status = CNT;
return(nchr);
}
} else {
unsigned char *tmpptr;
ncnt = count - 1;
#ifdef KEY /* Bug 3797 */
/* no newline if fgets encountered eof */
tmpptr = strchr(tp, '\n');
#ifdef KEY /* Bug 3975 */
char *nlptr = memchr(tp, '\n', ncnt);
/* Temporary fix to deal with the situation
* in which nulls appear before the newline.
* Correct fix is to eliminate those nulls.
*/
if (NULL == tmpptr && NULL != nlptr) {
tmpptr = nlptr;
}
#endif /* KEY Bug 3975 */
#else
tmpptr = memchr(tp, '\n', ncnt);
#endif /* KEY Bug 3797 */
if (tmpptr != NULL) { /* eor */
*status = EOR;
ncnt = tmpptr - tp;
nchr += ncnt;
_unpack(tp, uda, ncnt, -1);
/* Return number of chars read */
return(nchr);
}
#ifdef KEY /* Bug 3797 */
/* fgets got chars ending in eof, not newline */
else if (feof(fptr)) {
*status = EOR;
ncnt = strlen(tp);
nchr += ncnt;
_unpack(tp, uda, ncnt, -1);
return nchr;
}
#endif /* KEY Bug 3797 */
_unpack(tp, uda, ncnt, -1);
nchr += ncnt;
uda += ncnt;
/* go refill the buffer */
}
}
#else
while (nchr < chars) {
if (FILE_CNT(fptr) <= 0) {
fill:
errno = 0;
chr = _filbuf(fptr);
/* EOF here means incomplete record. */
if (chr == EOF) {
if (ferror(fptr)) {
if ( errno == EINTR &&
_GINTIO == 0 ) {
clearerr(fptr);
goto fill;
}
if (errno == 0)
errno = FESTIOER;
return(IOERR);
}
/*
* If nchr > zero, file has no newline.
* Make sure we handle it properly.
*/
if (nchr == 0) {
*status = EOD;
return(0);
}
*status = CNT;
return(nchr);
}
/*
* Put character returned by filbuf() back
*/
FILE_CNT(fptr)++;
FILE_PTR(fptr)--;
}
/*
* Search for a newline char in the buffer, but search
* only the number of characters left in the request,
* plus one in case it is the newline (if it is in
* the buffer). If we find the newline, we're done.
*/
if ((chars - nchr) < FILE_CNT(fptr)) {
ncnt = chars - nchr;
tp = memchr(FILE_PTR(fptr), '\n', ncnt + 1);
}
else {
ncnt = FILE_CNT(fptr); /* assume no EOR yet */
tp = memchr(FILE_PTR(fptr), '\n', ncnt);
}
if (tp != NULL) { /* Found end of record */
*status = EOR;
ncnt = tp - FILE_PTR(fptr);
nchr += ncnt;
_unpack((char *)FILE_PTR(fptr), uda, ncnt, -1);
FILE_CNT(fptr) -= ncnt + 1;
FILE_PTR(fptr) += ncnt + 1;
return(nchr); /* Return number of characters read */
}
_unpack((char *)FILE_PTR(fptr), uda, ncnt, -1);
FILE_CNT(fptr) -= ncnt;
FILE_PTR(fptr) += ncnt;
nchr += ncnt;
uda += ncnt;
/* go refill the buffer */
}
#endif
/*
* Get the next character to see if at end of record.
* Set the user's status word accordingly.
*/
chr = getc(fptr);
*status = CNT;
if (chr == '\n' ) {
*status = EOR;
return(nchr); /* Return number of characters read */
}
/*
* We are not at end of record. Thus if reading in full
* record mode skip until EOR is found. If reading in
* partial record mode, unget the last character read.
*/
if (mode == FULL)
#if defined(_SOLARIS) || (defined(_LITTLE_ENDIAN) && !defined(__sv2))
{
fill2:
count = TBUFSZB;
tp = tbuf;
tpinterim = fgets((char *)tp, count, fptr);
if (tpinterim == NULL) {
/* EOF means incomplete record. */
if (ferror(fptr)) {
if ( errno == EINTR && _GINTIO == 0 ) {
clearerr(fptr);
goto fill2;
}
}
/* Return number of chars read. */
return(nchr);
} else {
unsigned char *tmpptr;
ncnt = count - 1;
tmpptr = memchr(tp, '\n', ncnt);
if (tmpptr != NULL) { /* Found eor */
/* Return number of chars read */
return(nchr);
} else
goto fill2;
}
}
#else
while (1) {
if (FILE_CNT(fptr) <= 0) {
fill2:
chr = _filbuf(fptr);
/* EOF here means incomplete record. */
if (chr == EOF) {
if (ferror(fptr)) {
if ( errno == EINTR &&
_GINTIO == 0 ) {
clearerr(fptr);
goto fill2;
}
}
/* Return number of characters read */
return(nchr);
}
FILE_CNT(fptr)++;
FILE_PTR(fptr)--;
}
tp = memchr(FILE_PTR(fptr), '\n', FILE_CNT(fptr));
if (tp != NULL) {
tp++;
FILE_CNT(fptr) -= tp - FILE_PTR(fptr);
FILE_PTR(fptr) = tp;
return(nchr);
}
else
FILE_CNT(fptr) = 0;
}
#endif
else {
ungetc ((char) chr, fptr);
}
return(nchr); /* return number of character read */
case FS_FDC:
nchr = 0;
fio = cup->ufp.fdc;
/*
* If no conversion is to be done, or no characters requested
* (usually for null request, FULL mode), make it simple and direct.
*/
if (cup->ucharset == 0 || chars == 0) {
register long breq;
register int ffstat;
register int ret;
/*
* If file is direct access, we know that all reads are
* going to be whole records in FULL mode. We also
* know that the open code would not let us get this far
* if we were not dealing with a stream layer.
*/
breq = chars;
ret = XRCALL(fio, readcrtn) fio, CPTR2BP(uda),
breq, &stat, mode);
if (ret < 0) {
errno = stat.sw_error;
return(IOERR);
}
ffstat = FFSTAT(stat);
if (!cup->useq && !cup->ublkd && ffstat == FFCNT)
ffstat = FFEOR;
*status = FF2FTNST(ffstat);
nchr = ret;
return(nchr); /* Return number of characters read */
}
/*
* Get proper byte size (might not be 8-bits if doing conversion).
*/
#if NUMERIC_DATA_CONVERSION_ENABLED
bytsiz = __fndc_charsz[cup->ucharset];
#else
bytsiz = 8;
#endif
FFSTAT(cup->uffsw) = FFCNT;
*status = CNT;
while (nchr < chars && FFSTAT(cup->uffsw) != FFEOR) {
register long bgot;
register long breq;
register long padc;
register int ret;
register long totbits;
int ubc;
/*
* Calculate the number of bits that need to be taken
* from the foreign data stream.
*
* ncnt = number of resultant bytes
*/
ncnt = chars - nchr;
if (ncnt > TBUFSZB)
ncnt = TBUFSZB;
totbits = bytsiz * ncnt; /* bit count */
breq = (totbits + 7) >> 3; /* full 8-bit bytes */
ubc = (breq << 3) - totbits;/* unused bits */
ret = XRCALL(fio, readrtn) fio, CPTR2BP(tbuf),
breq, &cup->uffsw, PARTIAL, &ubc);
if (ret < 0) { /* if an error */
errno = cup->uffsw.sw_error;
return(IOERR);
}
/* if end of file */
if (ret == 0) {
if (nchr == 0)
*status = FF2FTNST(FFSTAT(stat));
return(nchr); /* Return number of characters read */
}
/*
* how many bits did we get? Convert back to foreign
* character count.
*/
totbits = (ret << 3) - ubc;
bgot = totbits / bytsiz; /* foreign bytes */
ubc = totbits - (bgot * bytsiz);
if (ubc != 0) {
errno = FEINTUNK;
return(IOERR);
}
padc = 0;
if (FFSTAT(cup->uffsw) == FFEOR) {
padc = chars - (bgot + nchr);
*status = EOR;
}
if (_fdc_unpackc(tbuf, &uda[nchr], bgot, padc,
cup->ucharset) < 0) {
return(IOERR);
}
nchr += bgot;
}
/* check for null request, non-EOR */
if (FFSTAT(cup->uffsw) == FFCNT && mode == FULL) {
register int ret;
int ubc;
ret = XRCALL(fio, readrtn) fio, CPTR2BP(tbuf), 0,
&cup->uffsw, FULL, &ubc);
if (ret < 0) { /* if an error */
errno = cup->uffsw.sw_error;
return(IOERR);
}
}
return(nchr);
case FS_AUX:
errno = FEMIXAUX;
return(IOERR);
default:
errno = FEINTFST;
return(IOERR);
}
