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/rf.c 92.5 09/07/99 15:26:57" 00039 00040 #include <ctype.h> 00041 #include <errno.h> 00042 #include <liberrno.h> 00043 #include <fortran.h> 00044 #include <stdlib.h> 00045 #include <stdlib.h> 00046 #include <string.h> 00047 #include <unistd.h> 00048 #include <cray/fmtconv.h> 00049 #include <cray/format.h> 00050 #include <cray/nassert.h> 00051 #ifndef _ABSOFT 00052 #include <sys/unistd.h> 00053 #endif 00054 #include "fio.h" 00055 #include "fmt.h" 00056 #include "fstats.h" 00057 #include "f90io.h" 00058 #ifdef _CRAYMPP 00059 #include <stdarg.h> 00060 #endif 00061 00062 #ifdef _UNICOS 00063 00064 #pragma _CRI duplicate $RFI as $RLI 00065 #pragma _CRI duplicate $RFA$ as $RLA$ 00066 #pragma _CRI duplicate $RFA$ as $DFA$ 00067 #pragma _CRI duplicate $RFF as $RLF 00068 #pragma _CRI duplicate $RFF as $DFF 00069 00070 /* Define macros to convert _numargs() to number of arguments */ 00071 #define ARGS_6 (4 + 2*sizeof(_fcd)/sizeof(long)) 00072 #define ARGS_7 (5 + 2*sizeof(_fcd)/sizeof(long)) 00073 #define ARGS_8 (6 + 2*sizeof(_fcd)/sizeof(long)) 00074 #define ARGS_9 (7 + 2*sizeof(_fcd)/sizeof(long)) 00075 00076 #define ZERO ((int) '0') 00077 00078 int $RFF(void); 00079 00080 #define ERROR0(cond, n) { \ 00081 if (!(cond)) \ 00082 _ferr(css, (n)); \ 00083 else \ 00084 goto error; \ 00085 } 00086 00087 #define ERROR1(cond, n, p) { \ 00088 if (!(cond)) \ 00089 _ferr(css, (n), p); \ 00090 else \ 00091 goto error; \ 00092 } 00093 00094 /* 00095 * Here we do some things for upward compatibility with CFT77 5.0.2. 00096 */ 00097 #define IS_PFORM_BROKEN (_numargs() < ARGS_9) /* true if pform is broken */ 00098 00099 /* 00100 * $RFI - read formatted initialization 00101 * 00102 * CALL $RFI,(funit, format, err, end, iostat, rec, pform, inumelt, 00103 * inumcfe) 00104 * 00105 * funit Address of Fortran unit designator (integer unit 00106 * number for external I/O or Fortran character 00107 * descriptor (FCD) for internal I/O) 00108 * format Address of format (Fortran character descriptor or 00109 * hollerith); NULL if list-directed 00110 * err Address of error address (ERR=label) 00111 * end Address of end address (END=label) 00112 * iostat Address of I/O status variable (integer variable) 00113 * rec Address of integer record number (NULL implies 00114 * sequential I/O) 00115 * pform Address of address of parsed format (NULL if no 00116 * compiler-supplied word; points to NULL if not yet 00117 * parsed) 00118 * inumelt Address of number of internal array elements 00119 * (internal I/O only) 00120 * inumcfe Argument passed by new compilers to indicate that 00121 * the pform argument is fixed, and to contain the 00122 * number of array elements in a character format. 00123 * 00124 * $RFI calls: 00125 * 00126 * _imp_open77(), _unit_seek(), _parse(), _ferr(), $RFF() 00127 */ 00128 00129 #ifdef _CRAYMPP 00130 int 00131 $RFI( 00132 _fcd funit, /* Address of unit number or FCD */ 00133 ... 00134 ) 00135 #else 00136 int 00137 $RFI( 00138 _fcd funit, /* Address of unit number or FCD */ 00139 _fcd format, /* Address of format (FCD or hollerith) */ 00140 long *err, /* Address of error processing address */ 00141 long *end, /* Address of end processing address */ 00142 _f_int *iostat, /* Address of IOSTAT variable */ 00143 _f_int *rec, /* Address of direct access record no. */ 00144 fmt_type **pform, /* Address of address of parsed format */ 00145 long *inumelt, /* Address of int. array element count */ 00146 long *inumcfe /* Address of number of format elements */ 00147 ) 00148 #endif 00149 { 00150 register int endf; /* END processing flag */ 00151 register int errf; /* ERR processing flag */ 00152 register int errn; /* Error number */ 00153 register int iost; /* I/O statement type */ 00154 register int iotp; /* I/O type */ 00155 register recn_t recn; /* Record number */ 00156 register unum_t unum; /* Unit number */ 00157 fmt_type **prsfmt; /* Parsed format info. */ 00158 unit *cup; /* Unit table pointer */ 00159 FIOSPTR css; /* I/O statement state */ 00160 #ifdef _CRAYMPP 00161 va_list args; 00162 _fcd format; /* Address of format (FCD or hollerith) */ 00163 long *err; /* Address of error processing address */ 00164 long *end; /* Address of end processing address */ 00165 _f_int *iostat; /* Address of IOSTAT variable */ 00166 _f_int *rec; /* Address of direct access record no. */ 00167 fmt_type **pform; /* Address of address of parsed format */ 00168 long *inumelt; /* Address of int. array element count */ 00169 long *inumcfe; /* Address of number of format elements */ 00170 #endif 00171 00172 GET_FIOS_PTR(css); 00173 00174 /* Check if recursive triple-call I/O */ 00175 00176 if (css->f_iostmt != 0) 00177 _ferr(css, FEIOACTV); 00178 00179 #ifdef _CRAYMPP 00180 va_start(args, funit); 00181 format = va_arg(args, _fcd); 00182 err = va_arg(args, long *); 00183 end = va_arg(args, long *); 00184 iostat = va_arg(args, _f_int *); 00185 rec = va_arg(args, _f_int *); 00186 if (_numargs() > ARGS_6) { 00187 pform = va_arg(args, fmt_type **); 00188 if (_numargs() > ARGS_7) { 00189 inumelt = va_arg(args, long *); 00190 if (_numargs() > ARGS_8) { 00191 inumcfe = va_arg(args, long *); 00192 } 00193 } 00194 } 00195 va_end(args); 00196 #endif 00197 errn = 0; 00198 00199 /* Establish error processing options */ 00200 00201 if (iostat != NULL) 00202 *iostat = 0; /* Clear IOSTAT variable, if extant */ 00203 00204 errf = ((err != NULL) || (iostat != NULL)); 00205 endf = ((end != NULL) || (iostat != NULL)); 00206 00207 /* Check if formatted or list-directed */ 00208 00209 iost = (_fcdtocp(format) != NULL) ? T_RSF : T_RLIST; 00210 iotp = SEQ; /* Assume sequential */ 00211 00212 /* Check if we're doing internal I/O or external I/O */ 00213 00214 if (_fcdlen(funit) > 0) { /* If internal I/O */ 00215 iotp = INT; 00216 STMT_BEGIN(-1, 1, iost, NULL, css, cup); 00217 } 00218 else { /* Else external I/O */ 00219 unum = **(_f_int **) &funit; 00220 00221 if (rec != NULL) { /* If direct access */ 00222 iost = T_RDF; /* Set direct formatted read */ 00223 iotp = DIR; 00224 recn = *rec; 00225 } 00226 00227 STMT_BEGIN(unum, 0, iost, NULL, css, cup); 00228 00229 if (cup == NULL) { /* If not connected */ 00230 int stat; /* Status */ 00231 00232 cup = _imp_open77(css, iotp, FMT, unum, errf, &stat); 00233 00234 /* 00235 * If the open failed, cup is NULL and stat contains 00236 * the error number. 00237 */ 00238 00239 if (cup == NULL) { 00240 errn = stat; 00241 goto error; 00242 } 00243 } 00244 } 00245 00246 /* All paths which lead here have set cup to a non-null value */ 00247 00248 assert (cup != NULL); 00249 00250 /* Copy the user's error processing options into the unit table */ 00251 00252 cup->uflag = (err != NULL ? _UERRF : 0) | 00253 (end != NULL ? _UENDF : 0) | 00254 (iostat != NULL ? _UIOSTF : 0); 00255 cup->uiostat = iostat; 00256 00257 if (iotp != INT) { /* If not internal I/O */ 00258 00259 /* If trying to read a file without read permission */ 00260 00261 if ((cup->uaction & OS_READ) == 0) { 00262 errn = FENOREAD; /* No read permission */ 00263 ERROR0(errf, errn); 00264 } 00265 00266 /* If attempting formatted I/O on an unformatted file */ 00267 00268 if (!cup->ufmt) { 00269 errn = FEFMTTIV; /* Formatted not allowed */ 00270 ERROR0(errf, errn); 00271 } 00272 00273 /* If sequential and writing, disallow read after write */ 00274 00275 if (cup->useq && cup->uwrt != 0) { 00276 errn = FERDAFWR; /* Read after write */ 00277 ERROR0(errf, errn); 00278 } 00279 } 00280 00281 /* Preset fields in unit table */ 00282 00283 cup->uwrt = 0; 00284 00285 /* Initialize fields in the Fortran statement state structure */ 00286 00287 css->u.fmt.icp = NULL; 00288 css->u.fmt.blank0 = cup->ublnk; 00289 css->u.fmt.lcomma = 0; 00290 css->u.fmt.slash = 0; 00291 css->u.fmt.freepfmt = 0; 00292 #ifdef _CRAYMPP 00293 css->f_shrdput = 0; 00294 #endif 00295 00296 if (_fcdtocp(format) != NULL) { /* If not list-directed input */ 00297 char *fptr; 00298 int flen; 00299 int fnum; 00300 int stsz; 00301 00302 /* 00303 * Ensure that fmtbuf is initialized in case _ferr() is called. 00304 */ 00305 css->u.fmt.u.fe.fmtbuf = NULL; 00306 css->u.fmt.u.fe.fmtnum = 0; 00307 css->u.fmt.u.fe.fmtcol = 0; 00308 css->u.fmt.u.fe.scale = 0; 00309 css->u.fmt.u.fe.charcnt = 0; 00310 00311 /* 00312 * For formats passed as hollerith (integer) variables, 00313 * there is no rigorous definition of the "length" of the 00314 * format, so we simply use strlen() as a first-order 00315 * approximation. 00316 * 00317 * For static formats (FORMAT statements) or formats 00318 * which are character constants or simple character 00319 * variables, the length of the format is the length of 00320 * the character string. 00321 * 00322 * For formats passed as character arrays, then the length 00323 * of the format is the length of the entire array. We 00324 * compute this by multiplying the length of the element 00325 * passed times the dimension of the array (inumcfe argument). 00326 * 00327 * We cannot distinguish the latter two cases without the 00328 * the inumcfe argument (see SPR 52032), which was added to 00329 * CF77 5.0.2.19. If we do not have the inumcfe argument, 00330 * we resort to a strlen() call. 00331 */ 00332 00333 if (_fcdlen(format) == 0) { /* If noncharacter format */ 00334 fptr = *(char **) &format; 00335 flen = strlen(fptr); 00336 } 00337 else { /* Else character format */ 00338 register int repl; 00339 00340 if (_numargs() > ARGS_8 && inumcfe != NULL) 00341 repl = *inumcfe; 00342 else 00343 repl = -1; 00344 00345 fptr = _fcdtocp(format); 00346 flen = (repl >= 0) ? repl * _fcdlen(format) : 00347 strlen(fptr); 00348 } 00349 00350 /* 00351 * The pform argument was not passed to the library in early 00352 * versions of CFT77 (2.0 and earlier on CRAY-2's; 4.0 and 00353 * earlier on CX/CEA's). This check can be removed when we 00354 * no longer support those compilers. 00355 */ 00356 00357 if (_numargs() > ARGS_6) { 00358 prsfmt = pform; 00359 /* 00360 * The pform argument was passed incorrectly by the 00361 * CFT77 5.0 compiler on CX/CEA systems. The fixed 00362 * compiler passes the inumcfe argument to indicate that 00363 * pform is passed correctly. If the inumcfe argument 00364 * is not passed and pform != NULL then pform was 00365 * passed with one instead of two levels of 00366 * indirection. 00367 */ 00368 if (IS_PFORM_BROKEN && pform != NULL) { 00369 /* preparsed pform was passed incorrectly */ 00370 if (*(long*)pform == -1) 00371 /* variable format */ 00372 prsfmt = NULL; 00373 else 00374 /* pre-parsed format */ 00375 prsfmt = (fmt_type**)&pform; 00376 } 00377 } 00378 else 00379 prsfmt = NULL; 00380 00381 /* 00382 * Pull an optional statement number off of the beginning of 00383 * the format and save it. If a statement number is found, 00384 * update the format string pointer and length. Someday, 00385 * Obi-wan, we'll do this only for static formats. 00386 */ 00387 00388 fnum = 0; 00389 00390 while (isdigit(*fptr) && flen-- > 0) 00391 fnum = (fnum * 10) + ((int) *fptr++ - ZERO); 00392 00393 css->u.fmt.u.fe.fmtbuf = fptr; 00394 css->u.fmt.u.fe.fmtlen = flen; 00395 css->u.fmt.u.fe.fmtnum = fnum; 00396 00397 /* 00398 * If the format is a variable format, or if it has not yet 00399 * been parsed, or if it was parsed by an incompatible version 00400 * of the format parser, then parse it. 00401 */ 00402 00403 if (prsfmt == NULL || *prsfmt == NULL || 00404 (**prsfmt).offset != PARSER_LEVEL) { /* If not parsed */ 00405 00406 errn = _parse(css, cup, prsfmt); 00407 00408 if (errn != 0) { 00409 ERROR0(errf, errn); 00410 } 00411 } 00412 else 00413 css->u.fmt.u.fe.pfmt = *prsfmt; 00414 00415 /* 00416 * Ensure that the format count stack is allocated and is 00417 * large enough to accomodate the maximum nesting depth of 00418 * this format. 00419 */ 00420 00421 stsz = (*css->u.fmt.u.fe.pfmt).rep_count; 00422 00423 if (stsz > cup->upfcstsz) { 00424 00425 cup->upfcstsz = stsz; /* Set new depth */ 00426 00427 if (cup->upfcstk != NULL) 00428 free(cup->upfcstk); /* Free old stack */ 00429 00430 cup->upfcstk = (int *) malloc(sizeof(int) * stsz); 00431 00432 if (cup->upfcstk == NULL) { 00433 errn = FENOMEMY; /* No memory */ 00434 ERROR0(errf, errn); 00435 } 00436 00437 } 00438 00439 css->u.fmt.u.fe.pftocs = cup->upfcstk; /* Top of count stack */ 00440 00441 /* Skip first entry of parsed format */ 00442 00443 css->u.fmt.u.fe.pfcp = css->u.fmt.u.fe.pfmt + 1; 00444 00445 /* Set initial repeat count */ 00446 00447 *css->u.fmt.u.fe.pftocs = css->u.fmt.u.fe.pfcp->rep_count; 00448 } 00449 00450 /* Set processing functions */ 00451 00452 if (iotp == DIR) { 00453 00454 if (cup->useq) /* If direct attempted on seq. file */ 00455 errn = FEDIRTIV; /* Direct access not allowed */ 00456 else 00457 errn = _unit_seek(cup, recn, iost); 00458 00459 if (errn != 0) { 00460 ERROR1(errf, errn, recn); 00461 } 00462 00463 css->u.fmt.endrec = _dr_endrec; 00464 } 00465 else { 00466 00467 if (cup->useq == 0) { /* If seq. attempted on direct file */ 00468 errn = FESEQTIV; /* Sequential not allowed */ 00469 ERROR0(errf, errn); 00470 } 00471 00472 /* 00473 * The inumelt argument was not passed to the library in 00474 * earlier (prior to 5.0) versions of CFT77. The check 00475 * can be removed when we no longer support those compilers. 00476 * For decode statements, later compilers are passing a 00477 * NULL value for inumelt. 00478 */ 00479 00480 if (iotp == INT) { /* If internal I/O */ 00481 00482 css->u.fmt.iiae = ((_numargs() > ARGS_7) && 00483 (inumelt != NULL)) ? *inumelt : -1; 00484 css->u.fmt.endrec = _ir_endrec; 00485 css->u.fmt.icp = _fcdtocp(funit); 00486 css->u.fmt.icl = _fcdlen (funit); 00487 00488 /* 00489 * If the size of the internal record is greater 00490 * than the existing line buffer, then realloc() 00491 * another one; else just decrease urecsize. 00492 */ 00493 00494 if (css->u.fmt.icl > cup->urecsize) { 00495 00496 cup->ulinebuf = (long*) realloc(cup->ulinebuf, 00497 sizeof(long) * 00498 (css->u.fmt.icl + 1)); 00499 00500 if (cup->ulinebuf == NULL) { 00501 errn = FENOMEMY; /* No memory */ 00502 ERROR0(errf, errn); 00503 } 00504 } 00505 00506 cup->urecsize = css->u.fmt.icl; 00507 } 00508 else /* External sequential formatted I/O */ 00509 css->u.fmt.endrec = _sr_endrec; 00510 } 00511 00512 if (cup->pnonadv == 0) { /* if previous ADVNACE='YES' */ 00513 errn = (*css->u.fmt.endrec)(css, cup, 1); /* Read a record */ 00514 } 00515 else { /* else previous ADVANCE='NO' */ 00516 css->u.fmt.leftablim = cup->ulineptr; /* set left tab limit */ 00517 } 00518 00519 if (errn != 0) 00520 if (errn < 0 ) { 00521 ERROR0(endf, errn); 00522 } 00523 else { 00524 ERROR0(errf, errn); 00525 } 00526 00527 cup->pnonadv = 0; 00528 00529 /* normal return with 0 in S3 */ 00530 00531 return(CFT77_RETVAL(IO_OKAY)); 00532 00533 error: 00534 /* Update IOSTAT variable, if specified, with error status */ 00535 00536 if (iostat != NULL) 00537 *iostat = errn; 00538 00539 if (cup != NULL) /* If we have a unit, set status */ 00540 cup->uflag |= (errn < 0) ? _UENDC : _UERRC; 00541 00542 /* Complete record and return */ 00543 00544 return(CFT77_RETVAL($RFF())); 00545 } 00546 00547 /* 00548 * $RFA$ - read formatted transfer 00549 * 00550 * CALL $RFA,(fwa, cnt, inc, typ) 00551 * 00552 * fwa First word address of datum (may be a Fortran 00553 * character descriptor) 00554 * cnt Number of data items 00555 * inc Stride between data items 00556 * typ Type of data 00557 * 00558 * $RFA$ calls: 00559 * 00560 * _ld_read(), _rdfmt(), $RFF() 00561 */ 00562 00563 int 00564 $RFA$( 00565 _fcd fwa, /* Address of first word of data */ 00566 long *cnt, /* Address of count of data items */ 00567 long *inc, /* Address of stride between data items */ 00568 long *typ /* Address of data type */ 00569 ) 00570 { 00571 register int errn; /* Error number */ 00572 type_packet tip; /* Type information packet */ 00573 unit *cup; /* Pointer to unit table entry */ 00574 void *vaddr; /* Data byte address */ 00575 xfer_func *xfunc; /* Data transfer function */ 00576 FIOSPTR css; /* Pointer to I/O state structure */ 00577 00578 /* Set unit table pointer */ 00579 00580 GET_FIOS_PTR(css); 00581 00582 cup = css->f_cu; 00583 tip.type77 = *typ & 017; 00584 tip.type90 = _f77_to_f90_type_cnvt[tip.type77]; 00585 tip.count = *cnt; 00586 tip.stride = *inc; 00587 tip.intlen = _f77_type_len[tip.type77]; 00588 tip.extlen = tip.intlen; 00589 tip.elsize = tip.intlen; 00590 tip.cnvindx = 0; 00591 00592 if (tip.type77 == DT_CHAR) { 00593 vaddr = _fcdtocp(fwa); 00594 tip.elsize = tip.elsize * _fcdlen(fwa); 00595 } 00596 else 00597 vaddr = *(void **) &fwa; 00598 00599 xfunc = (css->f_iostmt & TF_FMT) ? _rdfmt : _ld_read; 00600 errn = xfunc(css, cup, vaddr, &tip, 0); 00601 00602 if (errn == 0) 00603 return(CFT77_RETVAL(IO_OKAY)); 00604 00605 /* Update IOSTAT variable, if specified, with error status */ 00606 00607 if (cup->uiostat != NULL) 00608 *(cup->uiostat) = errn; 00609 00610 /* Set error or EOF status */ 00611 00612 cup->uflag |= (errn < 0) ? _UENDC : _UERRC; 00613 00614 /* Complete record and return */ 00615 00616 return(CFT77_RETVAL($RFF())); 00617 } 00618 00619 /* 00620 * $RFF - read formatted finalization 00621 * 00622 * CALL $RFF,() 00623 * 00624 * $RFF calls: 00625 * 00626 * _rdfmt() 00627 */ 00628 00629 int 00630 $RFF(void) 00631 { 00632 register int errn; /* Error number */ 00633 register long flag; /* Error flag */ 00634 unit *cup; /* Pointer to unit table entry */ 00635 FIOSPTR css; /* Pointer to I/O state structure */ 00636 00637 /* Set unit table pointer */ 00638 00639 GET_FIOS_PTR(css); 00640 00641 cup = css->f_cu; 00642 00643 if (cup == NULL) /* If unit not opened */ 00644 flag = _UERRC | _UERRF; 00645 /* NB: You can't get an EOF error without a cup pointer */ 00646 else { 00647 00648 /* If formatted I/O and no error/EOF, complete processing */ 00649 00650 #ifdef _CRAYMPP 00651 if (css->f_shrdput) { 00652 css->f_shrdput = 0; 00653 _remote_write_barrier(); 00654 } 00655 #endif 00656 if ((css->f_iostmt & TF_FMT) && /* If formatted and... */ 00657 (cup->uflag & (_UERRC | _UENDC)) == 0) { /* If no ERR/EOF */ 00658 00659 /* Complete format */ 00660 errn = _rdfmt(css, cup, (void *) NULL, &__tip_null, 00661 0); 00662 00663 if (errn != 0) { 00664 00665 /* Set IOSTAT variable */ 00666 00667 if (cup->uiostat != NULL) 00668 *(cup->uiostat) = errn; 00669 00670 /* Set error status */ 00671 00672 cup->uflag |= (errn > 0) ? _UERRC : _UENDC; 00673 } 00674 } 00675 00676 /* If we allocated memory for a variable format, free it */ 00677 00678 if (css->u.fmt.freepfmt && css->u.fmt.u.fe.pfmt != NULL) 00679 free(css->u.fmt.u.fe.pfmt); 00680 00681 flag = cup->uflag; /* Save status */ 00682 } 00683 00684 STMT_END(cup, TF_READ, NULL, css); /* Unlock unit */ 00685 00686 /* Return proper status */ 00687 00688 if ((flag & (_UERRC | _UENDC)) == 0) /* If no error or EOF */ 00689 return(CFT77_RETVAL(IO_OKAY)); 00690 else 00691 if ((flag & _UERRC) != 0) { /* If error */ 00692 00693 if ((flag & (_UIOSTF | _UERRF)) != 0) 00694 return(CFT77_RETVAL(IO_ERR)); 00695 } 00696 else /* Else EOF */ 00697 if ((flag & (_UIOSTF | _UENDF)) != 0) 00698 return(CFT77_RETVAL(IO_END)); 00699 00700 _ferr(css, FEINTUNK); /* Deep weeds */ 00701 } 00702 00703 #endif /* _UNICOS */ 00704 00705 /* 00706 * _dr_endrec(css, cup, count) 00707 * 00708 * Process the end of a format or the slash edit 00709 * descriptor on a direct access read 00710 * 00711 * css Current statement state pointer 00712 * cup Current unit pointer 00713 * count Count of records to read (1 if end of format else 00714 * >= 1 for slash edit descriptor) 00715 * 00716 * If no error or end of file, zero is returned. 00717 * If error and user error processing is enabled, error number is returned. 00718 * If error and no user error processing is enabled, _ferr() is called. 00719 * If EOF and user end processing is enabled, -(EOF number) is returned. 00720 * If EOF and no user end processing is enabled, _ferr() is called. 00721 * 00722 * Calls: _frch() 00723 */ 00724 int 00725 _dr_endrec(FIOSPTR css, unit *cup, int count) 00726 { 00727 register int i; 00728 register int length; 00729 long stat; 00730 00731 assert ( css != NULL ); 00732 assert ( cup != NULL ); 00733 assert ( count > 0 ); 00734 00735 cup->udalast = cup->udalast + count; 00736 length = 0; 00737 00738 if (cup->udalast > cup->udamax) /* If trying to read nonexistent rec. */ 00739 RERROR1(FENORECN, cup->udalast); 00740 00741 for (i = 0; i < count; i++) { /* For each record to be read... */ 00742 00743 length = _frch(cup, cup->ulinebuf, cup->urecsize, FULL, &stat); 00744 00745 switch (stat) { 00746 00747 case EOR: /* Normal case */ 00748 if (length != cup->urecsize) { 00749 /* Should be an error */ 00750 } 00751 break; 00752 00753 case EOF: /* End of file */ 00754 case EOD: /* End of data */ 00755 /* 00756 * It's possible that the check against 00757 * udamax above will prevent this from 00758 * ever occurring; in which case this 00759 * path is never taken. 00760 */ 00761 RERROR1(FENORECN, cup->udalast); 00762 00763 case CNT: /* Malformed record */ 00764 /* 00765 * In full record mode, the only way we 00766 * can get a CNT status back is if the 00767 * record is malformed (e.g., missing 00768 * EOR). 00769 */ 00770 RERROR(FERDMALR); 00771 00772 default: /* Read error */ 00773 RERROR(errno); 00774 00775 } /* switch */ 00776 } /* for */ 00777 00778 cup->ulinecnt = length; 00779 cup->ulineptr = cup->ulinebuf; 00780 css->u.fmt.leftablim = cup->ulinebuf; 00781 00782 return(0); 00783 } 00784 00785 /* 00786 * _ir_endrec(css, cup, count) 00787 * 00788 * Process the end of a format or the slash edit 00789 * descriptor on an internal read 00790 * 00791 * css Current statement state pointer 00792 * cup Current unit pointer 00793 * count Count of records to read (1 if end of format else 00794 * >= 1 for slash edit descriptor) 00795 * 00796 * If no error or end of file, zero is returned. 00797 * If error and user error processing is enabled, error number is returned. 00798 * If error and no user error processing is enabled, _ferr() is called. 00799 * If EOF and user end processing is enabled, -(EOF number) is returned. 00800 * If EOF and no user end processing is enabled, _ferr() is called. 00801 * 00802 * Calls: _unpack() 00803 */ 00804 int 00805 _ir_endrec(FIOSPTR css, unit *cup, int count) 00806 { 00807 register int i; 00808 00809 assert ( css != NULL ); 00810 assert ( cup != NULL ); 00811 assert ( count > 0 ); 00812 00813 for (i = 0; i < count; i++) { /* For each record to be read... */ 00814 00815 if (css->u.fmt.iiae-- == 0) 00816 REND(FERDIEOF); /* Read past end of internal array */ 00817 00818 /* Skip all but last record */ 00819 00820 if (i != (count - 1)) /* If not last record */ 00821 css->u.fmt.icp = css->u.fmt.icp + cup->urecsize; 00822 else 00823 (void) _unpack(css->u.fmt.icp, cup->ulinebuf, 00824 css->u.fmt.icl, -1); 00825 00826 } /* for */ 00827 00828 css->u.fmt.icp = css->u.fmt.icp + css->u.fmt.icl; 00829 cup->ulinecnt = css->u.fmt.icl; 00830 cup->ulineptr = cup->ulinebuf; 00831 css->u.fmt.leftablim = cup->ulinebuf; 00832 00833 return(0); 00834 } 00835 00836 /* 00837 * _sr_endrec(css, cup, count) 00838 * 00839 * Process the end of a format or the slash edit 00840 * descriptor on a sequential read 00841 * 00842 * css Current statement state pointer 00843 * cup Current unit pointer 00844 * count Count of records to read (1 if end of format else 00845 * >= 1 for slash edit descriptor) 00846 * 00847 * If no error or end of file, zero is returned. 00848 * If error and user error processing is enabled, error number is returned. 00849 * If error and no user error processing is enabled, _ferr() is called. 00850 * If EOF and user end processing is enabled, -(EOF number) is returned. 00851 * If EOF and no user end processing is enabled, _ferr() is called. 00852 * 00853 * Calls: _frch() 00854 */ 00855 int 00856 _sr_endrec(FIOSPTR css, unit *cup, int count) 00857 { 00858 register int eofstat; 00859 register long length; 00860 register long offset; 00861 long stat; 00862 00863 assert ( css != NULL ); 00864 assert ( cup != NULL ); 00865 assert ( count > 0 ); 00866 00867 cup->uend = BEFORE_ENDFILE; 00868 00869 while (count > 1) { /* Skip all but last record */ 00870 long tbuf[2]; /* Dummy buffer */ 00871 00872 length = _frch(cup, tbuf, 1, FULL, &stat); 00873 00874 if (length == IOERR) 00875 RERROR(errno); 00876 00877 switch (stat) { 00878 00879 case EOR: /* Normal case */ 00880 case CNT: /* Malformed record (no newline) */ 00881 break; 00882 00883 case EOF: /* End of file */ 00884 cup->uend = PHYSICAL_ENDFILE; 00885 REND(FERDPEOF); 00886 00887 case EOD: /* End of data */ 00888 if (cup->uend == BEFORE_ENDFILE) { 00889 cup->uend = LOGICAL_ENDFILE; 00890 eofstat = FERDPEOF; 00891 } 00892 else 00893 eofstat = FERDENDR; 00894 00895 REND(eofstat); 00896 00897 default: /* Read error */ 00898 RERROR(errno); 00899 00900 } /* switch */ 00901 00902 count = count - 1; 00903 } 00904 00905 offset = 0; 00906 00907 do { /* Read last record */ 00908 00909 length = _frch(cup, cup->ulinebuf + offset, 00910 cup->urecsize - offset, PARTIAL, &stat); 00911 00912 if (length == IOERR) 00913 RERROR(errno); 00914 00915 switch (stat) { 00916 register long tlen; 00917 long *tptr; 00918 00919 case EOR: /* Normal case */ 00920 break; 00921 00922 case EOF: /* End of file */ 00923 if (offset > 0) /* Premature EOF */ 00924 break; 00925 00926 cup->uend = PHYSICAL_ENDFILE; 00927 REND(FERDPEOF); 00928 00929 case EOD: /* End of data */ 00930 if (offset > 0) /* Premature EOD */ 00931 break; 00932 00933 if (cup->uend == BEFORE_ENDFILE) { 00934 cup->uend = LOGICAL_ENDFILE; 00935 eofstat = FERDPEOF; 00936 } 00937 else 00938 eofstat = FERDENDR; 00939 00940 REND(eofstat); 00941 00942 case CNT: /* Partial record */ 00943 /* 00944 * The record didn't fit into the line buffer, 00945 * so we increase the size of the line buffer 00946 * and try reading the rest of the record. 00947 * 00948 * Basically, we double the size of the line 00949 * buffer on each iteration except that when 00950 * we get above a million words, we ensure 00951 * that the size of the memory request is a 00952 * multiple of a megabyte (for purposes of 00953 * memory alignment and allocation). 00954 * 00955 * Note that we have a one-word pad at the 00956 * end of the line buffer. 00957 */ 00958 00959 #define MB 01000000L /* A million */ 00960 00961 if (length != (cup->urecsize - offset)) { 00962 /* 00963 * We got a short count. Most 00964 * likely, a missing newline on 00965 * the last record of the file. 00966 * Treat it is as an EOR. 00967 */ 00968 stat = EOR; 00969 break; 00970 } 00971 00972 offset = cup->urecsize; 00973 tlen = offset; 00974 00975 if (tlen >= (MB - 1)) 00976 tlen = (((tlen + 1) << 1) & 00977 ~(MB - 1)) - 1; 00978 else { 00979 tlen = tlen << 1; 00980 00981 if (tlen > MB) 00982 tlen = MB - 1; 00983 } 00984 00985 if (tlen < offset) /* Oops, overflow! */ 00986 RERROR(FERDMEMY); 00987 00988 tptr = realloc(cup->ulinebuf, sizeof(long) * 00989 (tlen + 1)); 00990 00991 if (tptr == (long *) NULL) /* No memory */ 00992 RERROR(FERDMEMY); 00993 00994 cup->ulinebuf = tptr; 00995 cup->urecsize = tlen; 00996 00997 break; 00998 00999 default: /* Read error */ 01000 RERROR(errno); 01001 01002 } /* switch */ 01003 } while (stat == CNT); 01004 01005 cup->uend = BEFORE_ENDFILE; 01006 cup->ulinecnt = length + offset; 01007 cup->ulineptr = cup->ulinebuf; 01008 css->u.fmt.leftablim = cup->ulinebuf; 01009 01010 return(0); 01011 }