|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
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/rdfmt.c 92.6 06/21/99 10:37:55" 00039 00040 #include <memory.h> 00041 #include <stdlib.h> 00042 #include <string.h> 00043 #include <fortran.h> 00044 #include <cray/fmtconv.h> 00045 #include <cray/format.h> 00046 #include <cray/nassert.h> 00047 #ifdef _CRAYT3D 00048 #include <cray/mppsdd.h> 00049 #define MAXSH 512 00050 #else 00051 #define MAXSH 1 00052 #endif 00053 #include "fio.h" 00054 #include "fmt.h" 00055 #include "f90io.h" 00056 #include "lio.h" 00057 00058 extern const ic_func *_iconvtab[LAST_DATA_ED + 1]; 00059 extern const short _idedtab[DVTYPE_NTYPES]; 00060 00061 /* 00062 * _rdfmt() Read format processing 00063 * 00064 * css Current Fortran I/O statement state pointer 00065 * cup Unit pointer 00066 * dptr Pointer to data 00067 * tip Type information packet 00068 * 00069 * Return value 00070 * 00071 * 0 normal return. 00072 * 00073 * FEEORCND if end of record condition and IOSTAT= or 00074 * EOR= is specified. 00075 * 00076 * other <0 if end of file condition and IOSTAT= or 00077 * END= is specified. 00078 * 00079 * >0 if error condition and IOSTAT= or ERR= is 00080 * specified. 00081 */ 00082 int 00083 _rdfmt( 00084 FIOSPTR css, /* Current Fortran I/O statement state */ 00085 unit *cup, /* Unit pointer */ 00086 void *dptr, /* Pointer to data */ 00087 type_packet *tip, /* Type information packet */ 00088 int _Unused /* Unused by this routine */ 00089 ) 00090 { 00091 register short cswitch; /* 1 if complex data; else zero */ 00092 register short fmtop; /* Current format operator */ 00093 register short part; /* Part of datum (complex is 2-part) */ 00094 register ftype_t type; /* Fortran data type */ 00095 register int32 chxfer; /* Chars xferred by data edit descriptors */ 00096 register int32 delta; /* Length/field width difference */ 00097 register int32 field; /* Consecutive conversion field size */ 00098 register int32 i; /* Scratch loop variable */ 00099 register int32 itemch; /* Number of chars available for item */ 00100 register int32 kount; /* Number of consecutive conversions */ 00101 register int32 length; /* Length of datum in bytes */ 00102 register int32 padcnt; /* Number of pad bytes at end of item */ 00103 register int32 repcnt; /* Copy of *css->u.fmt.u.fe.pftocs */ 00104 int cinc[2]; /* Increments for datum parts */ 00105 register int stat; /* Error code */ 00106 register int stride; /* Stride between data in bytes */ 00107 register char *cptr; /* Character pointer to datum */ 00108 register char *ctmp; /* Temporary character pointer */ 00109 long digits; /* Digits field of edit-descriptor */ 00110 long mode; /* Mode word for conversion */ 00111 long *tptr; /* Temporary line buffer pointer */ 00112 long width; /* Width field of edit-descriptor */ 00113 register long count; /* Number of data items */ 00114 register long dfmode; /* MODEBZ or MODEBN mode bits */ 00115 fmt_type pfmt; /* Current parsed format entry */ 00116 #ifdef _CRAYT3D 00117 register short shared; /* Is variable shared? */ 00118 register int elwords; /* Number of words per item */ 00119 register int offset; /* Offset from address in item units */ 00120 register int32 tcount; /* Number of items to move */ 00121 long shrd[MAXSH]; /* Buffer for shared data */ 00122 #endif 00123 00124 int _nicverr( /* Map NICV-type errors to Fortran errors */ 00125 const int _Nicverror); 00126 00127 const ic_func *ngcf; /* Generic NICV-type conversion func */ 00128 00129 /* If these assertions are not all true, then we're in deep doo-doo. */ 00130 00131 assert (cup != NULL); 00132 assert (tip != NULL); 00133 00134 type = tip->type90; 00135 count = tip->count; 00136 00137 chxfer = 0; 00138 cswitch = 0; 00139 stat = 0; 00140 part = 1; 00141 00142 pfmt = *css->u.fmt.u.fe.pfcp; 00143 repcnt = *css->u.fmt.u.fe.pftocs; 00144 length = tip->elsize; 00145 stride = tip->stride * length; 00146 cinc[1] = stride; 00147 00148 /* If COMPLEX data type, set data length and increments */ 00149 00150 if (type == DVTYPE_COMPLEX) { 00151 length = length / 2; 00152 cinc[0] = length; 00153 cinc[1] = stride - length; 00154 cswitch = 1; 00155 part = 0; 00156 } 00157 00158 dfmode = ((css->u.fmt.blank0 == 1) ? MODEBZ : MODEBN); 00159 00160 #ifdef _CRAYT3D 00161 if (_issddptr(dptr)) { /* shared variable */ 00162 offset = 0; 00163 elwords = tip->elsize / sizeof(long); 00164 shared = 1; 00165 stride = tip->elsize; 00166 tcount = count; 00167 css->f_shrdput = 1; 00168 } 00169 else 00170 shared = 0; 00171 00172 do { 00173 if (shared) { /* shared variable */ 00174 /* 00175 * We read the data into local array shrd and later 00176 * distribute it to shared memory. We assume for now that 00177 * shared data never has a container size smaller than a word. 00178 */ 00179 count = MIN (MAXSH / elwords, (tcount - offset)); 00180 cptr = (char *) shrd; 00181 } 00182 else 00183 #endif 00184 { 00185 cptr = (char *) dptr; 00186 } 00187 00188 do { /* M A I N L O O P */ 00189 00190 fmtop = pfmt.op_code; /* Get operator */ 00191 width = pfmt.field_width; /* And main parameter */ 00192 digits = pfmt.digits_field; /* And secondary parameter */ 00193 00194 /* Basic sanity check on the parsed format */ 00195 00196 if (fmtop > LAST_OP || fmtop < FIRST_DATA_ED) { 00197 stat = FEINTIPF; /* Invalid parsed format */ 00198 goto done; 00199 } 00200 00201 if (fmtop <= LAST_DATA_ED) { 00202 00203 /* 00204 * We have a data edit-descriptor and if the count 00205 * is exhausted, then we're done for now. 00206 */ 00207 00208 if (count == 0) 00209 goto done; 00210 00211 /* 00212 * Validate the data edit-descriptor against the 00213 * data type and do the Fortran 90 mapping of the 00214 * G data edit-descriptor. 00215 */ 00216 00217 if (INVALID_RTYPE(fmtop, type)) { 00218 stat = FERDTYPE; /* Type mismatch */ 00219 goto done; 00220 } 00221 00222 if (fmtop == G_ED) { 00223 00224 fmtop = _idedtab[type]; 00225 00226 if (type != DVTYPE_REAL && 00227 type != DVTYPE_COMPLEX) 00228 digits = 1; 00229 } 00230 00231 if (type == DVTYPE_ASCII) 00232 mode = 0; 00233 else { 00234 mode = (long) _rd_ilchk[fmtop-1][length-1]; 00235 00236 if (mode == INVALID_INTLEN) { 00237 stat = FERDTYPE; /* Type mismatch */ 00238 goto done; 00239 } 00240 } 00241 00242 mode = mode | dfmode; 00243 00244 /* 00245 * Handle zero-width formats. 00246 */ 00247 00248 if (width == 0) { 00249 register int exp; 00250 00251 switch (fmtop) { 00252 00253 /* 00254 * For character (A/R) data edit- 00255 * descriptors, the width is the 00256 * length of the datum. 00257 */ 00258 case A_ED: 00259 case R_ED: 00260 width = length; 00261 break; 00262 00263 /* 00264 * For integer (B/I/O/Z) data edit-descriptors, 00265 * the width is the maximum number of "digits" 00266 * plus one for a leading blank and (I only) 00267 * one for an optional sign. 00268 */ 00269 case B_ED: 00270 case I_ED: 00271 case O_ED: 00272 case Z_ED: 00273 width = _rw_mxdgt[fmtop-1][length-1]; 00274 00275 /* Fix limitation in table */ 00276 00277 if (width == 127) 00278 width = 128; 00279 00280 /* Allow for blank and sign */ 00281 00282 width = width + 1; 00283 00284 if (fmtop == I_ED) 00285 width = width + 1; 00286 00287 if (pfmt.default_digits) 00288 digits = 1; 00289 break; 00290 00291 /* 00292 * For floating-point (D/E/EN/ES/F/G) data 00293 * edit-descriptors, the width is the number 00294 * of significant digits plus the maximum 00295 * size of the exponent plus six (for a 00296 * leading blank, an optional sign, an 00297 * optional leading zero, a decimal point, 00298 * the 'E' exponent designator, and the 00299 * exponent sign). 00300 */ 00301 case D_ED: 00302 case E_ED: 00303 case EN_ED: 00304 case ES_ED: 00305 case F_ED: 00306 case G_ED: 00307 if (pfmt.default_digits) 00308 digits = _rw_mxdgt[fmtop-1][length-1]; 00309 00310 if (length == 16) 00311 exp = DEXP16; 00312 #ifdef _F_REAL4 00313 else if (length == 4) 00314 exp = DEXP4; 00315 #endif 00316 else 00317 exp = DEXP8; 00318 00319 width = digits + exp + 6; 00320 break; 00321 00322 /* 00323 * For logical (L) data edit-descriptors, 00324 * the width is always two (one for the 'T' 00325 * or 'F' and the other for a leading blank). 00326 */ 00327 case L_ED: 00328 width = _rw_mxdgt[fmtop-1][length-1]; 00329 break; 00330 00331 /* 00332 * For Q data edit-descriptors, the 00333 * width is zero--no data is consumed. 00334 */ 00335 case Q_ED: 00336 width = 0; 00337 break; 00338 00339 /* 00340 * Should never arrive here. 00341 */ 00342 default: 00343 width = -1; 00344 break; 00345 } /* switch */ 00346 00347 /* 00348 * Sanity check for valid width. 00349 */ 00350 if (width < 0) { 00351 stat = FERDTYPE; /* Type mismatch */ 00352 goto done; 00353 } 00354 } 00355 00356 /* 00357 * Check end-of-file and end-of-record conditions. 00358 */ 00359 00360 if (cup->uend) { /* If at EOF */ 00361 stat = FERDPEOF; /* Read past EOF */ 00362 goto done; 00363 } 00364 00365 /* 00366 * Set the number of consecutive data items, and be 00367 * sure to adjust for the case when we're in the middle 00368 * of a complex datum. 00369 */ 00370 00371 kount = MIN(repcnt, 00372 ((count << cswitch) - (part & cswitch))); 00373 field = width * kount; 00374 00375 /* 00376 * See if processing the current batch of edit- 00377 * descriptors will exhaust the record. If so, 00378 * see if there's room for one more. 00379 */ 00380 00381 if (field > cup->ulinecnt) { 00382 00383 field = width; 00384 kount = 1; 00385 00386 if (width > cup->ulinecnt) { 00387 00388 /* 00389 * If ADVANCE='NO' and the current 00390 * edit descriptor requires data from 00391 * beyond end of record, we have an 00392 * EOR condition. However, the EOR 00393 * condition may be superseded by an 00394 * error during data input conversion. 00395 */ 00396 00397 if (css->u.fmt.nonadv) 00398 stat = FEEORCND; 00399 else 00400 if (cup->upad == OS_NO) 00401 stat = FERDPEOR; 00402 00403 /* 00404 * If there are no characters left in 00405 * the record and PAD='NO', then bypass 00406 * the data transfer altogether. 00407 */ 00408 00409 if (cup->ulinecnt <= 0 && 00410 cup->upad == OS_NO) 00411 goto done; 00412 } 00413 } 00414 } 00415 00416 switch (fmtop) { 00417 00418 /* Process numeric input */ 00419 00420 case B_ED: 00421 case D_ED: 00422 case E_ED: 00423 case EN_ED: 00424 case ES_ED: 00425 case F_ED: 00426 case G_ED: 00427 case I_ED: 00428 case L_ED: 00429 case O_ED: 00430 case Z_ED: 00431 00432 ngcf = _iconvtab[fmtop]; 00433 00434 #ifdef _CRAY 00435 #pragma _CRI align 00436 #endif 00437 00438 for (i = 0; i < kount; i++) { /* For consecutive items */ 00439 register short j; 00440 long nstat; 00441 00442 /* Clear subsequent words of a multi-word item */ 00443 00444 if (length > sizeof(int)) 00445 for (j = 1; j < (length/sizeof(int)); j++) 00446 ((int *) cptr)[j] = 0; 00447 00448 itemch = MIN(MAX(0, cup->ulinecnt), width); 00449 tptr = cup->ulineptr + itemch; /* end of field */ 00450 nstat = -1; 00451 00452 (void) ngcf(cup->ulineptr, &width, &tptr, &mode, 00453 cptr, &nstat, &digits, 00454 &css->u.fmt.u.fe.scale); 00455 00456 if (nstat < 0) { 00457 stat = _nicverr(nstat); 00458 if (stat > 0) 00459 goto done; 00460 } 00461 00462 /* Advance data addresses */ 00463 00464 cup->ulineptr = cup->ulineptr + itemch; 00465 cup->ulinecnt = cup->ulinecnt - itemch; 00466 chxfer = chxfer + itemch; 00467 count = count - part; 00468 cptr = cptr + cinc[part]; 00469 part = part ^ cswitch; 00470 } 00471 00472 repcnt = repcnt - kount; 00473 00474 break; 00475 00476 /* Process nonnumeric (character) input */ 00477 00478 case A_ED: 00479 case R_ED: 00480 00481 delta = length - width; 00482 00483 /* 00484 * Check if format width equals data length and we have 00485 * a stride of one. If so, then we can move all of the 00486 * data in one fell swoop. 00487 */ 00488 00489 if (delta == 0 && tip->stride == 1 && cswitch == 0) { 00490 00491 itemch = MIN(MAX(0, cup->ulinecnt), field); 00492 00493 (void) _pack(cup->ulineptr, cptr, itemch, -1); 00494 00495 padcnt = field - itemch; 00496 00497 if (padcnt > 0) /* If variable wider than field */ 00498 (void) memset(cptr + itemch, BLANK, (size_t) padcnt); 00499 00500 cup->ulineptr = cup->ulineptr + itemch; 00501 cup->ulinecnt = cup->ulinecnt - itemch; 00502 chxfer = chxfer + itemch; 00503 count = count - kount; 00504 cptr = cptr + (stride * kount); 00505 } 00506 else 00507 00508 #ifdef _CRAY 00509 #pragma _CRI align 00510 #endif 00511 00512 for (i = 0; i < kount; i++) { /* For consecutive items */ 00513 00514 ctmp = cptr; 00515 itemch = MIN(MAX(0, cup->ulinecnt), width); 00516 00517 /* 00518 * If the field width is wider than the length 00519 * of the variable, we need to skip over part 00520 * of the field. However, make sure we don't 00521 * skip past the end of the record. 00522 */ 00523 00524 if (delta < 0) { /* If field wider than variable */ 00525 itemch = itemch + delta; 00526 cup->ulinecnt = cup->ulinecnt + delta; 00527 cup->ulineptr = cup->ulineptr - delta; 00528 padcnt = (delta + width) - itemch; 00529 } 00530 00531 /* 00532 * If doing R format and the variable is larger 00533 * than the field, we need to right-justify the 00534 * data and fill-in the unused portion (we fill 00535 * with blanks for character variables and zeros 00536 * for all other data types). 00537 */ 00538 00539 else { 00540 padcnt = delta + (width - itemch); 00541 00542 if (fmtop == R_ED && delta > 0) { 00543 register int fill; 00544 00545 fill = (type == DVTYPE_ASCII) ? 00546 BLANK : 0; 00547 00548 (void) memset(ctmp, fill, (size_t) delta); 00549 00550 ctmp = ctmp + delta; 00551 padcnt = padcnt - delta; 00552 } 00553 } 00554 00555 /* Move the actual data */ 00556 00557 if (itemch > 0) 00558 (void) _pack(cup->ulineptr, ctmp, itemch, -1); 00559 00560 /* 00561 * If the variable is wider than the field, or if there 00562 * was insufficient data to satisfy the width, then pad 00563 * out the variable with blanks. 00564 */ 00565 00566 if (padcnt > 0) 00567 (void) memset(ctmp + itemch, BLANK, (size_t) padcnt); 00568 00569 /* Advance data addresses */ 00570 00571 cup->ulineptr = cup->ulineptr + itemch; 00572 cup->ulinecnt = cup->ulinecnt - itemch; 00573 chxfer = chxfer + itemch; 00574 count = count - part; 00575 cptr = cptr + cinc[part]; 00576 part = part ^ cswitch; 00577 } 00578 00579 repcnt = repcnt - kount; 00580 break; 00581 00582 case Q_ED: 00583 if (length == 4) 00584 *(_f_int4 *)cptr = MAX(cup->ulinecnt, 0); 00585 else if (length == 8) 00586 *(_f_int8 *)cptr = MAX(cup->ulinecnt, 0); 00587 else if (length == 2) 00588 *(_f_int2 *)cptr = MAX(cup->ulinecnt, 0); 00589 else /* Assume length == 1 */ 00590 *(_f_int1 *)cptr = MAX(cup->ulinecnt, 0); 00591 00592 /* Advance data addresses */ 00593 00594 count = count - part; 00595 cptr = cptr + cinc[part]; 00596 part = part ^ cswitch; 00597 repcnt = repcnt - 1; 00598 break; 00599 00600 case SLASH_ED: 00601 stat = (*css->u.fmt.endrec)(css, cup, width); 00602 repcnt = repcnt - 1; 00603 break; 00604 00605 case TR_ED: 00606 cup->ulineptr = cup->ulineptr + width; 00607 cup->ulinecnt = cup->ulinecnt - width; 00608 repcnt = repcnt - 1; 00609 break; 00610 00611 case T_ED: 00612 tptr = cup->ulineptr; /* Old pos. */ 00613 cup->ulineptr = css->u.fmt.leftablim + width - 1; 00614 cup->ulinecnt = cup->ulinecnt + (tptr - cup->ulineptr); 00615 repcnt = 0; /* Ignore repeat count */ 00616 break; 00617 00618 case TL_ED: 00619 cup->ulineptr = cup->ulineptr - width; 00620 cup->ulinecnt = cup->ulinecnt + width; 00621 /* 00622 * If tabbed off the beginning of the record, 00623 * move back to column 1. 00624 */ 00625 if (cup->ulineptr < css->u.fmt.leftablim) { 00626 cup->ulinecnt = cup->ulinecnt - 00627 (css->u.fmt.leftablim - cup->ulineptr); 00628 cup->ulineptr = css->u.fmt.leftablim; 00629 } 00630 repcnt = repcnt - 1; 00631 break; 00632 00633 case STRING_ED: 00634 /* 00635 * Literals and H edit-descriptors are invalid in 00636 * input formats. 00637 */ 00638 stat = FEFMTLII; 00639 repcnt = repcnt - 1; 00640 break; 00641 00642 case BN_ED: 00643 css->u.fmt.blank0 = 0; 00644 dfmode = dfmode & ~MODEBZ; 00645 dfmode = dfmode | MODEBN; 00646 repcnt = 0; /* Ignore repeat count */ 00647 break; 00648 00649 case BZ_ED: 00650 css->u.fmt.blank0 = 1; 00651 dfmode = dfmode & ~MODEBN; 00652 dfmode = dfmode | MODEBZ; 00653 repcnt = 0; /* Ignore repeat count */ 00654 break; 00655 00656 case DOLLAR_ED: /* $ has no effect on input */ 00657 case S_ED: /* S, SS, SP have no effect on input */ 00658 case SS_ED: 00659 case SP_ED: 00660 repcnt = 0; /* Ignore repeat count */ 00661 break; 00662 00663 case P_ED: 00664 css->u.fmt.u.fe.scale = pfmt.rep_count; 00665 repcnt = 0; /* Force advancement */ 00666 break; 00667 00668 case COLON_ED: 00669 /* 00670 * We have a colon edit-descriptor and, if the count 00671 * is zero, we're done for now. 00672 */ 00673 if (count == 0) 00674 goto done; 00675 00676 repcnt = 0; /* Ignore repeat count */ 00677 break; 00678 00679 case REPEAT_OP: 00680 /* 00681 * Start of repeated format group. Stack the repeat 00682 * count and advance to the next format token. 00683 */ 00684 *css->u.fmt.u.fe.pftocs++ = pfmt.rep_count; 00685 repcnt = 0; /* Force advance*/ 00686 break; 00687 00688 case ENDREP_OP: 00689 /* 00690 * End of repeated format group. Decrement the 00691 * stacked count. If the repeat count has not 00692 * been satisfied then proceed to the first format 00693 * token of the repeat group; otherwise unstack 00694 * the repeat count and advance to the next format 00695 * token. 00696 */ 00697 if ( --(*(css->u.fmt.u.fe.pftocs - 1)) < 1) 00698 css->u.fmt.u.fe.pftocs--; /* Pop the rep cnt */ 00699 else 00700 css->u.fmt.u.fe.pfcp = css->u.fmt.u.fe.pfcp + 00701 pfmt.rep_count; 00702 00703 repcnt = repcnt - 1; 00704 00705 break; 00706 00707 case REVERT_OP: 00708 /* 00709 * If the revert group does not contain any data 00710 * edit-descriptors and iolist items remain 00711 * (defined as a nonzero count), then we have an 00712 * infinite format loop. 00713 */ 00714 if (pfmt.rgcdedf == 0 && count > 0) 00715 stat = FEFMTILF; /* Infinite format loop */ 00716 else { 00717 /* 00718 * If the count is zero, then we exit with 00719 * the format positioned at the REVERT_OP 00720 * entry and subsequent calls can continue 00721 * from there, if necessary. If there are 00722 * data items remaining (count > 0) then 00723 * we flush the record, position the format 00724 * to the reversion point, and continue 00725 * processing. 00726 */ 00727 00728 if (count == 0) 00729 goto done; 00730 00731 /* Read the next record */ 00732 00733 stat = (*css->u.fmt.endrec)(css, cup, 1); 00734 repcnt = 0; /* Force advancement */ 00735 00736 /* Position format to reversion point */ 00737 00738 css->u.fmt.u.fe.pfcp = css->u.fmt.u.fe.pfcp + 00739 pfmt.rep_count - 1; 00740 } 00741 break; 00742 00743 default: 00744 stat = FEINTIPF; /* Invalid parsed format */ 00745 break; 00746 00747 } /* switch (fmtop) */ 00748 00749 /* 00750 * If the repeat count has been exhausted then advance to 00751 * the next format token. 00752 */ 00753 00754 if (stat == 0 && repcnt < 1) { 00755 00756 if (fmtop == STRING_ED) 00757 css->u.fmt.u.fe.pfcp = css->u.fmt.u.fe.pfcp + 00758 ((width + 00759 FMT_ENTRY_BYTE_SIZE - 1) / 00760 FMT_ENTRY_BYTE_SIZE); 00761 00762 css->u.fmt.u.fe.pfcp = css->u.fmt.u.fe.pfcp + 1; 00763 pfmt = *css->u.fmt.u.fe.pfcp; 00764 repcnt = pfmt.rep_count; 00765 css->u.fmt.u.fe.fmtcol = pfmt.offset; /* New position*/ 00766 } 00767 00768 } while (stat == 0); 00769 done: 00770 00771 #ifdef _CRAYT3D 00772 if (shared && ((long *) cptr != shrd)) { 00773 register int items; 00774 00775 /* Move the data to shared memory, see if there is more to do */ 00776 00777 items = ((long *) cptr - shrd) / elwords; 00778 (void) _cpytosdd(dptr, shrd, items, elwords, tip->stride, offset); 00779 offset = offset + items; 00780 } 00781 00782 } while (stat == 0 && shared && offset < tcount); 00783 #endif 00784 00785 /* Update unit table and statement state fields */ 00786 00787 *css->u.fmt.u.fe.pftocs = repcnt; 00788 00789 if (css->u.fmt.nonadv) /* Increment the SIZE value */ 00790 css->u.fmt.u.fe.charcnt = css->u.fmt.u.fe.charcnt + chxfer; 00791 00792 /* Process any error which occurred */ 00793 00794 if (stat == FEEORCND) { 00795 if ((cup->uflag & (_UEORF | _UIOSTF)) == 0) 00796 _ferr(css, stat); /* end of record condition */ 00797 00798 cup->pnonadv = 0; /* flag no more current rec */ 00799 } 00800 else if (stat > 0) { 00801 if ((cup->uflag & (_UERRF | _UIOSTF)) == 0) 00802 _ferr(css, stat); /* Run-time error */ 00803 } 00804 else if (stat < 0) { 00805 if ((cup->uflag & (_UENDF | _UIOSTF)) == 0) 00806 _ferr(css, stat); /* EOF-type error */ 00807 } 00808 00809 return(stat); 00810 } 00811 00812 #if defined(__mips) || (defined(_LITTLE_ENDIAN) && defined(__sv2)) 00813 #include <ieeefp.h> 00814 #elif defined(_LITTLE_ENDIAN) && !(__sv2) 00815 #include <fpu_control.h> 00816 #endif 00817 /* 00818 * _nicverr() Map NICV-type errors to Fortran error codes. 00819 * 00820 * On mips with overflow and underflow, allow the return of zero 00821 * or infinity if the csr is off for these two interrupts. The 00822 * conversion routines return the correct value but also return 00823 * a negative value to indicate overflow or underflow. Return a 00824 * zero as the function result if the error is not to be given. 00825 * 00826 */ 00827 int 00828 _nicverr(const int nicverror) 00829 { 00830 int errn; 00831 00832 switch (nicverror) { 00833 case EX_ILLCHAR: /* Invalid (nonnumeric) character */ 00834 errn = FENICVIC; 00835 break; 00836 case EX_FIXOFLO: /* Fixed-point overflow */ 00837 errn = FENICVOF; 00838 break; 00839 case EX_EXPUFLO: /* Floating-point underflow */ 00840 errn = FENICVEU; 00841 #if defined(__mips) || (defined(_LITTLE_ENDIAN) && defined(__sv2)) 00842 /* this returns only the mask bits */ 00843 if ((fpgetmask() & FP_X_UFL) == 0) 00844 errn = 0; 00845 #elif defined (_LITTLE_ENDIAN) && !defined(__sv2) 00846 #endif 00847 break; 00848 case EX_EXPOFLO: /* Floating-point overflow */ 00849 errn = FENICVEO; 00850 #if defined(__mips) || (defined(_LITTLE_ENDIAN) && defined(__sv2)) 00851 /* this returns only the mask bits */ 00852 if ((fpgetmask() & FP_X_OFL) == 0) 00853 errn = 0; 00854 #elif defined (_LITTLE_ENDIAN) && !defined(__sv2) 00855 #endif 00856 break; 00857 case EX_NULLFLD: /* Null field */ 00858 errn = FENICVBK; 00859 break; 00860 case EX_INVLOGI: /* Invalid logical input */ 00861 errn = FERDIVLG; 00862 break; 00863 default: /* Unknown (internal) error */ 00864 errn = FEINTUNK; 00865 break; 00866 } 00867 00868 return(errn); 00869 }
1.7.6.1 
