|
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/lread.c 92.3 06/18/99 15:49:57" 00039 00040 #include <limits.h> 00041 #include <ctype.h> 00042 #include <stdlib.h> 00043 #include <string.h> 00044 #include <fortran.h> 00045 #include <cray/fmtconv.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 "lio.h" 00055 #include "f90io.h" 00056 00057 /* 00058 * 16-byte real is not currently supported on MPP 00059 */ 00060 00061 #if defined(_CRAYMPP) || (defined(_ABSOFT) && defined(_LD64)) 00062 #if defined _F_REAL16 && _F_REAL16 == (-1) 00063 #define FAKE_REAL16 00064 #endif 00065 #endif 00066 00067 /* External functions */ 00068 00069 extern int 00070 _nicverr(const int _Nicverror); 00071 00072 extern void 00073 _set_stride(void *dest, void *src, long count, int elsize, long inc); 00074 00075 /* 00076 * This table is used to drive input conversion based on the type of the 00077 * data. 00078 */ 00079 extern const ic_func *_ilditab[DVTYPE_NTYPES]; 00080 00081 /* 00082 * _gen_real is a float (REAL) variable type of largest supported kind. 00083 * 00084 */ 00085 00086 #if !defined(_F_REAL16) || defined(FAKE_REAL16) 00087 typedef _f_real8 _gen_real; 00088 #else 00089 typedef _f_real16 _gen_real; 00090 #endif 00091 00092 /* 00093 * The repdata structure is used by scanning routines to manage repeated 00094 * list-directed input data. 00095 */ 00096 struct repdata { 00097 00098 long repcnt; /* The remaining repeat count */ 00099 00100 enum reptypes { 00101 00102 REPNONE = 0, /* Indicate no leftover repeat value */ 00103 REPLINE, /* Get input value from current line 00104 * buffer; the value does NOT span lines. */ 00105 REPCHAR, /* Get character value from packed buffer */ 00106 REPCPLX, /* Complex value is repeated */ 00107 REPNULL /* Null value is repeated */ 00108 00109 } reptype; /* type of repeated data */ 00110 00111 union { 00112 00113 struct { /* for REPLINE */ 00114 long *lptr; /* Pointer to input field */ 00115 int lcnt; /* Characters left in record */ 00116 } line; 00117 00118 struct { /* for REPCHAR */ 00119 char *repchr;/* Pointer to buffer containing a 00120 * packed copy of a repeated input 00121 * quoted character string; NULL 00122 * otherwise. */ 00123 long repsize;/* Number of characters in repeated 00124 * value */ 00125 } rchr; 00126 00127 struct { /* for REPCPLX */ 00128 _gen_real r[2]; /* Complex value */ 00129 } cplx; 00130 } u; 00131 }; 00132 00133 00134 /* Forward references for local functions */ 00135 00136 void 00137 _cmplx_convert(void *dest, int size, _gen_real src[2]); 00138 00139 long 00140 _get_repcount(long *ptr, int limit, long *width); 00141 00142 int 00143 _get_value( long *lptr, int lcnt, void *ptr, ftype_t type, int elsize, 00144 long *width); 00145 00146 int 00147 _mr_scan_char(FIOSPTR css, unit *cup, char *ptr, int elsize, 00148 char **chptr, long *slen); 00149 00150 int 00151 _mr_scan_complex(FIOSPTR css, unit *cup, void *cpxptr, int elsize, 00152 short is_mult); 00153 00154 int 00155 _s_scan_extensions(void *ptr, ftype_t type, int elsize, long *begin, 00156 int left, long *size, long cmode); 00157 00158 /* 00159 * Macros 00160 */ 00161 00162 /* 00163 * GENREALTO8 converts a _gen_real to a _f_real8. 00164 */ 00165 00166 #ifdef FAKE_REAL16 00167 #define GENREALTO8(x) (*x) 00168 00169 #elif !defined(_UNICOS) 00170 #define GENREALTO8(x) ((_f_real8)(*x)) /* cast to _f_real8 */ 00171 00172 #else 00173 #define SNGLR _SNGLR_ 00174 00175 #endif 00176 00177 #ifdef SNGLR 00178 #define GENREALTO8 SNGLR 00179 extern _f_real SNGLR(_f_real16 *); 00180 #endif 00181 00182 /* 00183 * GENREALTO4 converts a _gen_real to a _f_real4. 00184 */ 00185 00186 #ifdef _F_REAL4 00187 #define GENREALTO4(x) ((_f_real4)(*x)) /* cast to _f_real4 */ 00188 #endif 00189 00190 /* 00191 * ADVANCE_INPUT advances the file until it finds a non-whitespace 00192 * character. 00193 */ 00194 00195 #define ADVANCE_INPUT(css, cup, lptr, lcnt) \ 00196 for (;;) { \ 00197 while (lcnt == 0) { /* Find a non-empty line */ \ 00198 errn = css->u.fmt.endrec(css, cup, 1); \ 00199 if (errn != 0) { \ 00200 if (errn > 0) RERROR(errn); \ 00201 if (errn < 0) REND(errn); \ 00202 } \ 00203 lptr = cup->ulineptr; \ 00204 lcnt = cup->ulinecnt; \ 00205 } \ 00206 if (! IS_WHITESPACE(*lptr)) \ 00207 break; /* Eureka! */ \ 00208 lptr = lptr + 1; \ 00209 lcnt = lcnt - 1; \ 00210 } 00211 00212 /* 00213 * _ld_read - read list formatted input. 00214 * 00215 * return value: 00216 * <0 end-of-file return 00217 * 0 normal return 00218 * >0 error return 00219 * abort if error or end-of-file condition and user has not 00220 * specified IOSTAT=/ERR=/END= 00221 */ 00222 00223 int 00224 _ld_read( 00225 FIOSPTR css, /* Current Fortran I/O statement state */ 00226 unit *cup, /* Unit pointer */ 00227 void *dptr, /* Pointer to start of destination data area */ 00228 type_packet *tip, /* Type information packet */ 00229 int _Unused)/* Unused by this routine */ 00230 { 00231 register short reptype;/* Local copy of cup->urepdata->reptype */ 00232 register ftype_t type; /* Fortran data type */ 00233 register int elsize; /* Size of each data item (bytes) */ 00234 register int errn; /* Error code */ 00235 register int lcnt; /* Local copy of cup->ulinecnt */ 00236 register long count; /* Number of data items */ 00237 register long repcnt; /* Local copy of cup->urepdata->repcnt */ 00238 register long stride; /* Stride between data items (bytes) */ 00239 register long vinc; /* Virtual stride */ 00240 long *lptr; /* Local copy of cup->ulineptr */ 00241 char *cptr; /* Character pointer to datum */ 00242 struct repdata *rptr; /* Local copy of cup->urepdata */ 00243 #ifdef _CRAYT3D 00244 register short shared; /* Is variable shared? */ 00245 register int elwords;/* Number of words per data item */ 00246 register int offset; /* Offset from address in item units */ 00247 register int tcount; /* Number of items to move */ 00248 long shrd[MAXSH]; /* Shared data temp array */ 00249 #endif 00250 00251 /* Assertions */ 00252 00253 assert ( css != NULL ); 00254 assert ( cup != NULL ); 00255 assert ( dptr != NULL ); 00256 assert ( tip != NULL ); 00257 00258 cptr = (char *) dptr; 00259 errn = 0; 00260 00261 lcnt = cup->ulinecnt; 00262 lptr = cup->ulineptr; 00263 00264 type = tip->type90; 00265 count = tip->count; 00266 elsize = tip->elsize; 00267 vinc = tip->stride; 00268 00269 /* 00270 * u.fmt.lcomma is 0 only if this is the first _ld_read call for the 00271 * current list-directed READ statement. Use this clue to be sure 00272 * any old unexhausted repeat count is zeroed. 00273 */ 00274 00275 rptr = cup->urepdata; 00276 00277 if (css->u.fmt.lcomma == 0 && rptr != NULL) 00278 rptr->repcnt = 0; 00279 00280 if (rptr != NULL && rptr->repcnt != 0) { 00281 00282 /* 00283 * An unexhausted repeat count exists from a previous 00284 * iteration or call to _ld_read. 00285 */ 00286 00287 reptype = rptr->reptype; 00288 repcnt = rptr->repcnt; 00289 00290 assert ( reptype == REPNONE || reptype == REPLINE || 00291 reptype == REPCHAR || reptype == REPCPLX || 00292 reptype == REPNULL ); 00293 assert ( repcnt > 0 ); 00294 } 00295 else { 00296 reptype = REPNONE; /* Indicate no leftover repeat count */ 00297 repcnt = 1; 00298 } 00299 00300 #ifdef _CRAYT3D 00301 if (_issddptr(dptr)) { 00302 offset = 0; 00303 elwords = elsize / sizeof(long); 00304 tcount = count; 00305 vinc = 1; /* We now have a unit stride */ 00306 shared = 1; 00307 css->f_shrdput = 1; 00308 } 00309 else 00310 shared = 0; 00311 00312 do { 00313 if (shared) { /* shared variable */ 00314 /* we read the data into local array shrd */ 00315 /* and later distribute it to shared memory */ 00316 count = MIN(MAXSH / elwords, (tcount - offset)); 00317 cptr = (char *) shrd; 00318 } 00319 #endif 00320 00321 stride = elsize * vinc; 00322 00323 /* 00324 * M A I N L O O P 00325 */ 00326 00327 while (count > 0) { /* While more to read */ 00328 register short is_mult;/* Can complex scan advance? */ 00329 register short is_null;/* Is value a null value? */ 00330 register long nitems; /* Number of repeated data items */ 00331 long width; /* Field width of data */ 00332 00333 if (css->u.fmt.slash) /* If we've encountered a slash */ 00334 break; 00335 00336 is_null = 0; /* Assume a non-null value */ 00337 is_mult = 1; /* Complex scan may process multiple records */ 00338 00339 /* 00340 * If there is no outstanding repeat count, we must scan 00341 * ahead, past a possible new repeat count, to the first 00342 * character of the input data. 00343 */ 00344 00345 if (reptype == REPNONE) { 00346 00347 /* 00348 * Read until we find a record containing a non-blank 00349 * character. 00350 */ 00351 00352 advance: 00353 ADVANCE_INPUT(css, cup, lptr, lcnt); 00354 00355 /* 00356 * If css->u.fmt.lcomma == 1 then the next 00357 * comma would not imply a null value. 00358 */ 00359 00360 if (*lptr == COMMA && css->u.fmt.lcomma == 1) { 00361 css->u.fmt.lcomma = 0; 00362 lptr = lptr + 1; 00363 lcnt = lcnt - 1; 00364 goto advance; 00365 } 00366 00367 css->u.fmt.lcomma = 1; 00368 repcnt = 1; 00369 00370 if (*lptr == SLASH) { 00371 css->u.fmt.slash = 1; 00372 goto done; 00373 } 00374 00375 /* Check for a possible repeat count in the input */ 00376 00377 if (IS_DIGIT(*lptr)) { 00378 00379 repcnt = _get_repcount(lptr, lcnt, &width); 00380 00381 lcnt = lcnt - width; 00382 lptr = lptr + width; 00383 } 00384 } 00385 else if (reptype == REPLINE) { 00386 00387 /* 00388 * Reposition at the location of the repeated 00389 * data item. Then redo the usual input scan. 00390 */ 00391 00392 lptr = rptr->u.line.lptr; 00393 lcnt = rptr->u.line.lcnt; 00394 00395 /* Complex scan may not advance records */ 00396 00397 is_mult = 0; 00398 } 00399 00400 /* 00401 * Scan the data at the current position in the current 00402 * record. We do this if there is no outstanding repeat 00403 * count, or we are rescanning at the current record 00404 * position to satisfy an outstanding repeat count of 00405 * type REPLINE. 00406 */ 00407 00408 if (reptype == REPNONE || reptype == REPLINE) { 00409 00410 /* Check for a null value */ 00411 00412 if (lcnt == 0 || IS_SEPARATOR(*lptr)) 00413 is_null = 1; 00414 00415 if (repcnt <= count || reptype == REPLINE) { 00416 /* 00417 * Handle the case where this call to _ld_read 00418 * consumes all of the (optionally repeated) 00419 * data. 00420 */ 00421 00422 if (is_null) 00423 errn = 0; /* Do nothing */ 00424 else switch (type) { 00425 00426 default: 00427 errn = _get_value( 00428 lptr, 00429 lcnt, 00430 cptr, 00431 type, 00432 elsize, 00433 &width); 00434 00435 lcnt = lcnt - width; 00436 lptr = lptr + width; 00437 break; 00438 00439 case DVTYPE_COMPLEX: 00440 cup->ulinecnt = lcnt; 00441 cup->ulineptr = lptr; 00442 00443 errn = _mr_scan_complex( 00444 css, 00445 cup, 00446 cptr, 00447 elsize, 00448 is_mult); 00449 00450 lcnt = cup->ulinecnt; 00451 lptr = cup->ulineptr; 00452 break; 00453 00454 case DVTYPE_ASCII: 00455 cup->ulinecnt = lcnt; 00456 cup->ulineptr = lptr; 00457 00458 errn = _mr_scan_char( 00459 css, 00460 cup, 00461 cptr, 00462 elsize, 00463 NULL, 00464 NULL); 00465 00466 lcnt = cup->ulinecnt; 00467 lptr = cup->ulineptr; 00468 break; 00469 00470 } /* switch */ 00471 00472 if (errn != 0) /* If EOF or error */ 00473 goto done; 00474 } 00475 00476 /* 00477 * Else the repeat count exceeds the number of I/O 00478 * list items, so create the repdata data structure. 00479 * At the same time, read the data into the next I/O 00480 * list item. 00481 */ 00482 00483 else { 00484 if (rptr == NULL) { 00485 00486 rptr = (struct repdata *) 00487 malloc(sizeof(struct repdata)); 00488 00489 if (rptr == NULL) { 00490 errn = FENOMEMY; 00491 goto done; 00492 } 00493 00494 cup->urepdata = rptr; 00495 } 00496 00497 if (is_null) { 00498 errn = 0; 00499 reptype = REPNULL; 00500 } 00501 else switch (type) { 00502 00503 default: 00504 errn = _get_value( 00505 lptr, 00506 lcnt, 00507 cptr, 00508 type, 00509 elsize, 00510 &width); 00511 00512 reptype = REPLINE; 00513 rptr->u.line.lcnt = lcnt; 00514 rptr->u.line.lptr = lptr; 00515 lcnt = lcnt - width; 00516 lptr = lptr + width; 00517 break; 00518 00519 case DVTYPE_COMPLEX: 00520 reptype = REPCPLX; 00521 cup->ulinecnt = lcnt; 00522 cup->ulineptr = lptr; 00523 00524 errn = _mr_scan_complex( 00525 css, 00526 cup, 00527 &rptr->u.cplx, 00528 sizeof(rptr->u.cplx), 00529 is_mult); 00530 00531 lcnt = cup->ulinecnt; 00532 lptr = cup->ulineptr; 00533 00534 _cmplx_convert( 00535 cptr, 00536 elsize, 00537 rptr->u.cplx.r); 00538 break; 00539 00540 case DVTYPE_ASCII: 00541 rptr->u.rchr.repchr = NULL; 00542 cup->ulinecnt = lcnt; 00543 cup->ulineptr = lptr; 00544 00545 errn = _mr_scan_char( 00546 css, 00547 cup, 00548 cptr, 00549 elsize, 00550 &rptr->u.rchr.repchr, 00551 &rptr->u.rchr.repsize); 00552 00553 if (rptr->u.rchr.repchr != NULL) 00554 reptype = REPCHAR; 00555 else { 00556 reptype = REPLINE; 00557 rptr->u.line.lptr = lptr; 00558 rptr->u.line.lcnt = lcnt; 00559 } 00560 00561 lcnt = cup->ulinecnt; 00562 lptr = cup->ulineptr; 00563 break; 00564 00565 } /* switch */ 00566 00567 if (errn != 0) /* If EOR or error */ 00568 goto done; 00569 } 00570 } 00571 00572 /* 00573 * Else satisfy the first I/O list item from the leftover 00574 * repeat count from a previous call to _ld_read. 00575 */ 00576 00577 else { 00578 if (reptype == REPNULL) { 00579 errn = 0; 00580 is_null = 1; 00581 } 00582 else switch (type) { 00583 00584 case DVTYPE_COMPLEX: 00585 00586 if (reptype != REPCPLX) 00587 errn = FELDNOCX; 00588 else 00589 _cmplx_convert( 00590 cptr, 00591 elsize, 00592 rptr->u.cplx.r); 00593 break; 00594 00595 case DVTYPE_ASCII: 00596 if (reptype != REPCHAR) 00597 errn = FELDUNKI; 00598 else { 00599 register int xfersz; 00600 00601 xfersz = MIN(elsize, 00602 rptr->u.rchr.repsize); 00603 00604 if (xfersz > 0) 00605 (void) memcpy( 00606 cptr, 00607 rptr->u.rchr.repchr, 00608 xfersz); 00609 00610 if (xfersz < elsize) 00611 (void) memset( 00612 cptr + xfersz, 00613 BLANK, 00614 elsize - xfersz); 00615 } 00616 break; 00617 00618 default: 00619 errn = FELDUNKI; /* Deep weeds */ 00620 break; 00621 00622 } /* switch */ 00623 00624 if (errn != 0) /* If EOR or error */ 00625 goto done; 00626 } 00627 00628 /* 00629 * Repeat count processing is now wrapped up by distributing 00630 * copies of the first I/O list item to the rest of the 00631 * items. 00632 */ 00633 00634 nitems = MIN(repcnt, count); 00635 00636 if (nitems > 1 && is_null == 0) 00637 _set_stride(cptr + stride, cptr, nitems - 1, 00638 elsize, stride); 00639 00640 cptr = cptr + (nitems * stride); 00641 count = count - nitems; 00642 repcnt = repcnt - nitems; 00643 00644 if (repcnt == 0) { /* If repeat count exhausted */ 00645 00646 if (reptype == REPCHAR) 00647 free(rptr->u.rchr.repchr); 00648 00649 reptype = REPNONE; 00650 } 00651 } /* while */ 00652 00653 done: 00654 #ifdef _CRAYT3D 00655 if (shared && (long *)cptr != shrd) { 00656 register int items; 00657 00658 /* Move the data to shared memory */ 00659 00660 items = ((long *) cptr - shrd) / elwords; 00661 00662 _cpytosdd(dptr, shrd, items, elwords, tip->stride, offset); 00663 00664 offset = offset + items; 00665 } 00666 00667 if (css->u.fmt.slash) 00668 break; 00669 00670 } while (errn == 0 && shared && offset < tcount); 00671 #endif 00672 00673 /* 00674 * Update fields in unit table. 00675 */ 00676 00677 cup->ulinecnt = lcnt; 00678 cup->ulineptr = lptr; 00679 00680 if (rptr != NULL) { /* If we have a repdata structure */ 00681 00682 if (repcnt == 0) { /* If repcnt exhausted */ 00683 00684 if (reptype == REPCHAR) 00685 free(rptr->u.rchr.repchr); 00686 00687 reptype = REPNONE; 00688 } 00689 00690 rptr->repcnt = repcnt; 00691 rptr->reptype = (enum reptypes) reptype; 00692 } 00693 00694 if (errn > 0) 00695 RERROR(errn); 00696 00697 return(errn); 00698 } 00699 00700 /* 00701 * _get_repcount - scan text for a positive integer repeat count followed 00702 * by an asterisk. 00703 * 00704 * Return value: 00705 * Repeat count (1 if no count found) 00706 * Line position updated if repeat count found. 00707 */ 00708 00709 long 00710 _get_repcount( 00711 long *ptr, /* Pointer into current record buffer */ 00712 int limit, /* Number of characters left in current record */ 00713 long *width) /* Number of characters consumed by repeat count */ 00714 { 00715 register int nchars; /* Number of characters processed */ 00716 register long chr; /* Current character */ 00717 register long count; /* Repeat count */ 00718 00719 chr = *ptr++; 00720 count = 0; 00721 nchars = 0; 00722 00723 while (limit > 1 && IS_DIGIT(chr)) { 00724 count = (count + count + (count << 3)) + (chr - ZERO); 00725 chr = *ptr++; 00726 nchars = nchars + 1; 00727 limit = limit - 1; 00728 } 00729 00730 /* 00731 * If the repeat count is zero or not found, set the repeat count 00732 * to 1 but do not update the line position. 00733 */ 00734 00735 if (chr != STAR || count == 0) { /* If no repeat count or zero */ 00736 count = 1; /* Update line position */ 00737 nchars = 0; 00738 } 00739 else 00740 nchars = nchars + 1; /* Count the asterisk */ 00741 00742 *width = nchars; 00743 00744 return(count); /* Return repeat count */ 00745 } 00746 00747 /* 00748 * _get_value - Read a real, integer, or logical value. 00749 * 00750 * Return value: 00751 * 0 on success 00752 * >0 error code on error 00753 */ 00754 00755 int 00756 _get_value( 00757 long *lptr, /* Pointer to the unpacked text */ 00758 int lcnt, /* Number of characters available to scan */ 00759 void *ptr, /* Pointer to I/O list item */ 00760 ftype_t type, /* Fortran data type */ 00761 int elsize, /* Size in bytes of the I/O list item */ 00762 long *size) /* Field width (output) */ 00763 { 00764 register int errn; 00765 register int nc; 00766 long dummy; 00767 long cmode; 00768 long zero = 0; 00769 long width; 00770 long *begin; 00771 long *end; 00772 const ic_func *ngcf; 00773 00774 begin = lptr; /* Mark start of field */ 00775 ngcf = _ilditab[type]; /* Conversion function */ 00776 *size = 0; 00777 nc = 0; 00778 cmode = 0; 00779 00780 /* Find the trailing value separator */ 00781 00782 while ( nc < lcnt && !IS_DELIMITER(*lptr) ) { 00783 lptr = lptr + 1; 00784 nc = nc + 1; 00785 } 00786 00787 end = lptr; 00788 width = nc; 00789 00790 /* Set up cmode */ 00791 00792 switch (type) { 00793 00794 case DVTYPE_REAL: 00795 00796 switch (elsize) { 00797 00798 #ifdef _F_REAL4 00799 case 4: 00800 cmode = MODEHP; 00801 break; 00802 #endif 00803 case 8: 00804 break; 00805 00806 case 16: 00807 cmode = MODEDP; 00808 break; 00809 00810 default: 00811 return(FEKNTSUP); /* kind not supported */ 00812 } 00813 break; 00814 00815 case DVTYPE_INTEGER: 00816 case DVTYPE_LOGICAL: 00817 00818 switch (elsize) { 00819 00820 #if (defined(_F_INT2) || defined(_F_LOG2)) && (defined(__mips) || \ 00821 defined(_LITTLE_ENDIAN)) 00822 case 1: 00823 cmode = MODEBP; 00824 break; 00825 case 2: 00826 cmode = MODEWP; 00827 break; 00828 #endif 00829 #if defined(_F_INT4) || defined(_F_LOG4) 00830 case 4: 00831 cmode = MODEHP; 00832 break; 00833 #endif 00834 case 8: 00835 break; 00836 00837 default: 00838 return(FEKNTSUP); /* kind not supported */ 00839 } 00840 break; 00841 00842 default: 00843 return(FEKNTSUP); /* kind not supported */ 00844 } 00845 00846 /* Call the conversion function */ 00847 00848 errn = ngcf( begin, &width, &end, &cmode, ptr, &dummy, 00849 &zero, &zero); 00850 00851 if (errn < 0) 00852 errn = _nicverr(errn); 00853 else 00854 errn = 0; 00855 00856 /* 00857 * If the scan failed, the input data might be hollerith or hex or 00858 * octal. Allow _s_scan_extensions to rescan the input and recompute 00859 * the field width. 00860 */ 00861 00862 if (errn == FENICVIC || errn == FERDIVLG) { 00863 register int errn2; 00864 00865 errn2 = _s_scan_extensions( 00866 ptr, 00867 type, 00868 elsize, 00869 begin, 00870 lcnt, 00871 size, 00872 cmode); 00873 00874 if (errn2 >= 0) 00875 errn = errn2; 00876 } 00877 else 00878 *size = end - begin; 00879 00880 return(errn); 00881 } 00882 00883 /* 00884 * _s_scan_extensions - read a Cray extension format into an I/O list item. 00885 * 00886 * Input forms accepted ('Y' yes or '-' no): 00887 * 00888 * Data types 00889 * I R L C Format Description 00890 * - - - - ------ ----------- 00891 * 00892 * Y Y Y Y (o0)'nnn['] Octal bit pattern 00893 * Y Y Y Y (zZ)'nnn['] Hexadecimal bit pattern 00894 * Y Y - Y nnn(bB) Octal integer (may be converted to real) 00895 * Y Y Y Y ("')xxx("')[hH] Blank-filled Hollerith character data 00896 * Y Y Y Y ("')xxx("')(lL) Zero-filled character data 00897 * Y Y Y Y ("')xxx("')(rR) Right-justified character data 00898 * 00899 * Input forms accepted for data item sizes: 00900 * 00901 * Size (words) 00902 * 1 2+ Format 00903 * - - ------ 00904 * 00905 * Y - (o0)'nnn['] 00906 * Y - (zZ)'nnn['] 00907 * Y Y nnn(bB) (but the integer value must fit in one word) 00908 * Y - 'xxxx'[hH] 00909 * Y - 'xxxx'(lL) 00910 * Y - 'xxxx'(rR) 00911 * 00912 * Return value: 00913 * 0 on success 00914 * >0 error code 00915 * -1 use previously assigned error code 00916 */ 00917 int 00918 _s_scan_extensions( 00919 void *ptr, /* Pointer to user I/O list item */ 00920 ftype_t type, /* Fortran data type */ 00921 int elsize, /* Size in bytes of datum */ 00922 long *begin, /* Pointer to start of input field */ 00923 int left, /* Number of characters left in record */ 00924 long *size, /* Field width (output) */ 00925 long cmode) /* Mode from calling routine */ 00926 { 00927 register short nchars; 00928 register int errn; 00929 register int i; 00930 register int lcnt; 00931 register long delim; 00932 long dummy; 00933 long fw; 00934 long zero = 0; 00935 register char first; 00936 register char ht; 00937 _f_int8 intvalue; 00938 char cbuf[sizeof(_f_int8)]; 00939 long *endptr; 00940 long *lptr; 00941 void *vptr; 00942 ic_func *ncf; /* Numeric conversion function */ 00943 00944 *size = 0; 00945 errn = 0; 00946 lptr = begin; 00947 lcnt = left; 00948 first = (char) *lptr; 00949 00950 switch (first) { 00951 00952 case 'b': 00953 case 'B': /* Binary, F90 only */ 00954 if (first == 'b' || first == 'B') 00955 return (FELDUNKI); 00956 break; 00957 00958 case 'o': 00959 case 'O': /* Octal */ 00960 case 'z': 00961 case 'Z': /* Hexadecimal */ 00962 00963 if (lcnt < 3 || lptr[1] != SQUOTE) 00964 return(-1); 00965 00966 lptr = lptr + 2; /* advance past the [oOzZ]' */ 00967 lcnt = lcnt - 2; 00968 00969 for (i = 0; i < lcnt; i++) { 00970 if (IS_DELIMITER(lptr[i])) 00971 break; 00972 } 00973 00974 if (lptr[i - 1] == SQUOTE) 00975 i = i - 1; /* Exclude trailing ' */ 00976 00977 if (i <= 0) 00978 return (-1); /* No sequence of digits found */ 00979 00980 if (first == 'b' || first == 'B') 00981 return (FELDUNKI); 00982 00983 if (first == 'o' || first == 'O') 00984 ncf = _ou2s; 00985 else /* Assume hexadecimal */ 00986 ncf = _zu2s; 00987 00988 endptr = lptr + i; 00989 fw = i; 00990 00991 errn = ncf(lptr, &fw, &endptr, &cmode, ptr, &dummy, 00992 &zero, &zero); 00993 00994 if (errn < 0) { 00995 register int estat; 00996 estat = _nicverr(errn); 00997 if (estat > 0) 00998 return(estat); 00999 } 01000 01001 lptr = lptr + fw; 01002 lcnt = lcnt - fw; 01003 01004 if (lcnt > 0 && *lptr == SQUOTE) { /* consume trailing ' */ 01005 lptr = lptr + 1; 01006 lcnt = lcnt - 1; 01007 } 01008 01009 break; 01010 01011 case '\'': 01012 case '"': /* Hollerith */ 01013 delim = (long) first; 01014 nchars = 0; 01015 01016 for (;;) { 01017 lptr = lptr + 1; 01018 lcnt = lcnt - 1; 01019 01020 if (lcnt == 0) 01021 return(-1); 01022 01023 if (*lptr == delim) { 01024 lptr = lptr + 1; 01025 lcnt = lcnt - 1; 01026 01027 if (lcnt == 0 || *lptr != delim) 01028 break; /* loop exit */ 01029 } 01030 01031 if ((nchars >= sizeof(_f_int8)) || 01032 (nchars >= elsize)) 01033 return(FELDSTRL); /* too long for 1 word*/ 01034 01035 cbuf[nchars] = (char) *lptr; 01036 nchars = nchars + 1; 01037 } 01038 01039 if (lcnt == 0) 01040 ht = 'h'; 01041 else if (IS_SEPARATOR(*lptr)) 01042 ht = 'h'; 01043 else { 01044 switch (*lptr) { 01045 case 'h': 01046 case 'H': 01047 ht = 'h'; 01048 break; 01049 01050 case 'l': 01051 case 'L': 01052 ht = 'l'; 01053 break; 01054 01055 case 'r': 01056 case 'R': 01057 ht = 'r'; 01058 break; 01059 01060 default: 01061 return(FELDUNKI); 01062 } 01063 01064 lptr = lptr + 1; 01065 } 01066 01067 /* pad with nulls */ 01068 01069 switch (elsize) { 01070 #ifdef _F_REAL4 01071 case 4: 01072 *(_f_int4 *)ptr = 0; 01073 break; 01074 #endif 01075 case 8: 01076 *(_f_int8 *)ptr = 0; 01077 break; 01078 #if (defined(_F_INT2) || defined(_F_LOG2)) && (defined(__mips) || \ 01079 defined(_LITTLE_ENDIAN)) 01080 case 2: 01081 *(_f_int2 *)ptr = 0; 01082 break; 01083 case 1: 01084 *((char *)ptr) = '\0'; 01085 break; 01086 #endif 01087 } 01088 01089 if (nchars > 0) { 01090 01091 if (ht == 'r'){ /* right justify */ 01092 memcpy((char *)ptr+elsize-nchars, cbuf, nchars); 01093 } 01094 else 01095 (void) memcpy(ptr, cbuf, nchars); 01096 } 01097 01098 if (ht == 'h' && nchars != sizeof(long)) { 01099 register int pad; 01100 01101 pad = elsize - nchars; 01102 01103 (void) memset((char *)ptr + nchars, BLANK, pad); 01104 } 01105 01106 break; 01107 01108 default: /* Must be the nnnnnB form */ 01109 for (i = 0; i < lcnt; i++) { 01110 if (IS_DELIMITER(lptr[i])) 01111 break; 01112 } 01113 01114 i = i - 1; /* exclude 'b'/'B' */ 01115 01116 if (i == 0) 01117 return (-1); /* no digits prior to 'b'/'B' */ 01118 01119 if (lptr[i] != 'B' && lptr[i] != 'b') 01120 return (-1); /* not terminated by 'b'/'B' */ 01121 01122 vptr = &intvalue; 01123 endptr = lptr + i; 01124 fw = i; 01125 01126 errn = _ou2s(lptr, &fw, &endptr, &cmode, vptr, &dummy, 01127 &zero, &zero); 01128 01129 if (errn < 0) { 01130 register int estat; 01131 estat = _nicverr(errn); 01132 if (estat > 0) 01133 return(estat); 01134 } 01135 01136 /* 01137 * Unlike the z'nn and o'nn forms, nnB is converted to 01138 * floating point for REAL input list items. 01139 */ 01140 01141 if (type == DVTYPE_REAL) { 01142 switch (elsize) { 01143 #ifdef _F_REAL4 01144 case 4: 01145 *(_f_real4 *)ptr = (_f_real4)intvalue; 01146 break; 01147 #endif 01148 case 8: 01149 *(_f_real8 *)ptr = (_f_real8)intvalue; 01150 break; 01151 01152 #if defined(_F_REAL16) && !defined(FAKE_REAL16) 01153 case 16: 01154 *(_f_real16 *)ptr = (_f_real16)intvalue; 01155 break; 01156 #endif 01157 default: 01158 return (FEKNTSUP); 01159 } 01160 } 01161 else { 01162 switch (elsize) { 01163 #if (defined(_F_INT2) || defined(_F_LOG2)) && (defined(__mips) || \ 01164 defined(_LITTLE_ENDIAN)) 01165 case 2: 01166 *(_f_int2 *)ptr = (_f_int2)intvalue; 01167 break; 01168 case 1: 01169 *(_f_int1 *)ptr = (_f_int1)intvalue; 01170 break; 01171 #endif 01172 #ifdef _F_INT4 01173 case 4: 01174 *(_f_int4 *)ptr = (_f_int4)intvalue; 01175 break; 01176 #endif 01177 01178 #ifdef _F_INT8 01179 case 8: 01180 *(_f_int8 *)ptr = intvalue; 01181 break; 01182 #endif 01183 default: 01184 return (FEKNTSUP); 01185 } 01186 } 01187 01188 lptr = lptr + fw + 1; /* Advance past nnnnB */ 01189 01190 } 01191 01192 *size = lptr - begin; 01193 01194 return(0); 01195 } 01196 01197 /* 01198 * _mr_scan_complex Read a complex value starting from the current 01199 * position in the current record. If is_mult is set, 01200 * then scanning may continue into subsequent records. 01201 * 01202 * Return value: 01203 * 0 on success. 01204 * >0 on error. 01205 * <0 on end-of-file. 01206 * abort if error or end-of-file condition and user has not 01207 * specified IOSTAT=/ERR=/END= 01208 */ 01209 01210 int 01211 _mr_scan_complex( 01212 FIOSPTR css, /* Fortran statement state */ 01213 unit *cup, /* unit pointer */ 01214 void *cpxptr, /* pointer to the complex input list item */ 01215 int elsize, /* size in bytes of each input list item */ 01216 short is_mult) /* 1 if we may advance to the next record */ 01217 { 01218 register int errn; 01219 register int lcnt; 01220 long fw; 01221 long *lptr; 01222 01223 lcnt = cup->ulinecnt; 01224 lptr = cup->ulineptr; 01225 01226 if (*lptr != LPAREN) { /* If no opening parenthesis */ 01227 errn = FELDNOCX; 01228 goto done; 01229 } 01230 01231 lptr = lptr + 1; 01232 lcnt = lcnt - 1; 01233 01234 /* Advance to the start of the numeric field for the real part */ 01235 01236 while (lcnt > 0 && IS_WHITESPACE(*lptr)) { 01237 lptr = lptr + 1; 01238 lcnt = lcnt - 1; 01239 } 01240 01241 if (lcnt == 0) { 01242 errn = FELDNOCX; 01243 goto done; 01244 } 01245 01246 elsize = elsize >> 1; /* Size of each complex part */ 01247 01248 errn = _get_value(lptr, lcnt, cpxptr, DVTYPE_REAL, elsize, &fw); 01249 01250 if (errn != 0) 01251 goto done; 01252 01253 lptr = lptr + fw; 01254 lcnt = lcnt - fw; 01255 01256 /* Now advance to the comma */ 01257 01258 while (lcnt > 0 && IS_WHITESPACE(*lptr)) { 01259 lptr = lptr + 1; 01260 lcnt = lcnt - 1; 01261 } 01262 01263 if (lcnt == 0) { /* If at end of line */ 01264 01265 if (is_mult == 0) { 01266 errn = FELDNOCX; 01267 goto done; 01268 } 01269 01270 ADVANCE_INPUT(css, cup, lptr, lcnt); 01271 } 01272 01273 if (*lptr != COMMA) { /* If no comma between real and imaginary parts */ 01274 errn = FELDNOCX; 01275 goto done; 01276 } 01277 01278 lptr = lptr + 1; 01279 lcnt = lcnt - 1; 01280 01281 /* Advance to the start of the numeric field for the imaginary part */ 01282 01283 while (lcnt > 0 && IS_WHITESPACE(*lptr)) { 01284 lptr = lptr + 1; 01285 lcnt = lcnt - 1; 01286 } 01287 01288 if (lcnt == 0) { /* If at end of line */ 01289 ADVANCE_INPUT(css, cup, lptr, lcnt); 01290 } 01291 01292 /* 01293 * Scan the imaginary part. 01294 */ 01295 cpxptr = (char *) cpxptr + elsize; 01296 01297 errn = _get_value(lptr, lcnt, cpxptr, DVTYPE_REAL, elsize, &fw); 01298 01299 if (errn != 0) 01300 goto done; 01301 01302 lptr = lptr + fw; 01303 lcnt = lcnt - fw; 01304 01305 /* Advance past the trailing parenthesis */ 01306 01307 while (lcnt > 0 && *lptr != RPAREN) { 01308 lptr = lptr + 1; 01309 lcnt = lcnt - 1; 01310 } 01311 01312 if (lcnt == 0) { /* Didn't find closing parenthesis! */ 01313 errn = FELDNOCX; 01314 goto done; 01315 } 01316 01317 cup->ulineptr = lptr + 1; 01318 cup->ulinecnt = lcnt - 1; 01319 01320 done: 01321 if (errn > 0) 01322 RERROR(errn); 01323 01324 return(0); 01325 } 01326 01327 /* 01328 * _mr_scan_char - read a character value. 01329 * 01330 * This routine reads delimited or undelimited character strings for 01331 * list-directed input. Scanning starts from the current position in the 01332 * current record. If the string is delimitted by quotes or characters, 01333 * additional records are read when necessary to reach the trailing 01334 * delimiter. 01335 * 01336 * The character string is transferred to the I/O list item pointed 01337 * to by ptr. The I/O list item is properly padded with blanks if 01338 * the string is shorter than the I/O list item. If the I/O list item 01339 * is shorter than the input string, the whole string is scanned 01340 * anyway with extra characters being discarded. 01341 * 01342 * Return value: 01343 * 0 on success. 01344 * >0 on error. 01345 * <0 on end-of-file. 01346 * abort if error or end-of-file condition and user has not 01347 * specified IOSTAT=/ERR=/END= 01348 */ 01349 int 01350 _mr_scan_char( 01351 FIOSPTR css, /* Fortran statement state */ 01352 unit *cup, /* unit pointer */ 01353 char *ptr, /* pointer to the character input list item */ 01354 int elsize, /* size in bytes of each input list item */ 01355 char **chptr, /* (input) chptr is non-null if a copy of 01356 * multi-record strings should be saved. 01357 * (output) *chptr is assigned NULL if the 01358 * string didn't span records or string is 01359 * of zero length. Assigned a pointer to an 01360 * allocated buffer containing a copy of the 01361 * string. */ 01362 long *slen) /* (output) size of string saved at *chptr */ 01363 { 01364 register short span; /* Input spanned records? */ 01365 register int errn; /* Error code */ 01366 register int lcnt; /* Local copy of cup->ulinecnt */ 01367 register long chlen; /* Length of the character string */ 01368 register long delim; /* Character string delimiter */ 01369 register long lsave; /* Length of character save buffer */ 01370 long *lptr; /* Local copy of cup->ulineptr */ 01371 char *csave; /* Character save buffer */ 01372 01373 span = 0; 01374 chlen = 0; 01375 lsave = 0; 01376 csave = NULL; 01377 lptr = cup->ulineptr; 01378 lcnt = cup->ulinecnt; 01379 delim = *lptr; /* Possible delimiter */ 01380 01381 if (IS_STRING_DELIMITER(delim)) { /* If quoted character */ 01382 01383 for (;;) { 01384 01385 lptr = lptr + 1; 01386 lcnt = lcnt - 1; 01387 01388 /* Advance to a nonempty record */ 01389 01390 while (lcnt == 0) { 01391 span = 1; 01392 01393 errn = css->u.fmt.endrec(css, cup, 1); 01394 01395 if (errn != 0) 01396 goto err_end_return; 01397 01398 lptr = cup->ulineptr; 01399 lcnt = cup->ulinecnt; 01400 } 01401 01402 if (*lptr == delim) { 01403 01404 if (lcnt > 1 && *(lptr + 1) == delim) { 01405 lptr = lptr + 1; 01406 lcnt = lcnt - 1; 01407 } 01408 else 01409 break; /* loop exit */ 01410 } 01411 01412 if (chlen < elsize) 01413 ptr[chlen] = (char) *lptr; 01414 01415 if (chptr != NULL) { /* If saving input */ 01416 01417 if (csave == NULL) { 01418 lsave = RECMAX; 01419 csave = (char *) malloc(lsave); 01420 01421 if (csave == NULL) { 01422 errn = FENOMEMY; 01423 goto err_end_return; 01424 } 01425 } 01426 else { 01427 if (chlen > lsave) { 01428 lsave = lsave + RECMAX; 01429 csave = (char *) realloc(csave, lsave); 01430 01431 if (csave == NULL) { 01432 errn = FENOMEMY; 01433 goto err_end_return; 01434 } 01435 } 01436 } 01437 01438 csave[chlen] = (char) *lptr; 01439 } 01440 01441 chlen = chlen + 1; 01442 } /* for */ 01443 01444 lptr = lptr + 1; /* advance past trailing delimiter */ 01445 lcnt = lcnt - 1; 01446 01447 if (span == 0) { /* input didn't span records */ 01448 if (csave != NULL) 01449 free(csave); /* don't need it */ 01450 } 01451 else { /* input spanned records */ 01452 if (chptr != NULL) { /* If saving input */ 01453 *chptr = csave; /* Character save buffer */ 01454 *slen = chlen; /* Set length */ 01455 } 01456 } 01457 } 01458 else { /* Unquoted character string */ 01459 while ( lcnt > 0 && !IS_SEPARATOR(*lptr) ) { 01460 01461 if (chlen < elsize) 01462 ptr[chlen] = (char) *lptr; 01463 01464 chlen = chlen + 1; 01465 lptr = lptr + 1; 01466 lcnt = lcnt - 1; 01467 } 01468 } 01469 01470 /* If input shorter than variable, pad with blanks */ 01471 01472 if (chlen < elsize) 01473 (void) memset(ptr + chlen, BLANK, elsize - chlen); 01474 01475 cup->ulineptr = lptr; 01476 cup->ulinecnt = lcnt; 01477 01478 return(0); /* normal return */ 01479 01480 err_end_return: 01481 if (csave != NULL) 01482 free(csave); 01483 01484 if (errn < 0) { 01485 REND(errn); 01486 } 01487 else if (errn > 0) { 01488 RERROR(errn); 01489 } 01490 else 01491 _ferr(css, FEINTUNK); 01492 01493 return(0); /* MIPS compiler needs a return statement */ 01494 } 01495 01496 _PRAGMA_INLINE(_cmplx_convert) 01497 void 01498 _cmplx_convert( 01499 void *dest, 01500 int size, 01501 _gen_real src[2]) 01502 { 01503 /* Assertions */ 01504 01505 assert ( size <= (sizeof(_gen_real) << 1) ); 01506 01507 switch (size) { /* case for each supported complex kind */ 01508 01509 #ifdef _F_COMP4 01510 case ( 2 * 4 ): /* KIND=4 */ 01511 ((_f_real4 *)dest)[0] = GENREALTO4(&src[0]); 01512 ((_f_real4 *)dest)[1] = GENREALTO4(&src[1]); 01513 break; 01514 #endif 01515 01516 case ( 2 * 8 ): /* KIND=8 */ 01517 ((_f_real8 *)dest)[0] = GENREALTO8(&src[0]); 01518 ((_f_real8 *)dest)[1] = GENREALTO8(&src[1]); 01519 break; 01520 01521 #ifdef _F_COMP16 01522 case ( 2 * 16 ): /* KIND=16 */ 01523 ((_f_real16 *)dest)[0] = src[0]; 01524 ((_f_real16 *)dest)[1] = src[1]; 01525 break; 01526 #endif 01527 01528 default: 01529 assert ( 0 ); /* shouldn't happen */ 01530 } /* switch */ 01531 01532 return; 01533 }
1.7.6.1 
