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/wf.c 92.2 06/18/99 15:49:57" 00039 00040 #include <ctype.h> 00041 #include <errno.h> 00042 #include <liberrno.h> 00043 #include <fortran.h> 00044 #include <memory.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 <cray/clibinc_config.h> 00055 #include "fio.h" 00056 #include "fmt.h" 00057 #include "fstats.h" 00058 #include "f90io.h" 00059 #include "lio.h" 00060 #ifdef _CRAYMPP 00061 #include <stdarg.h> 00062 #endif 00063 00064 #ifdef _UNICOS 00065 00066 #pragma _CRI duplicate $WFI as $WLI 00067 #pragma _CRI duplicate $WFA$ as $WLA$ 00068 #pragma _CRI duplicate $WFA$ as $EFA$ 00069 #pragma _CRI duplicate $WFF as $WLF 00070 #pragma _CRI duplicate $WFF as $EFF 00071 00072 #endif /* _UNICOS */ 00073 00074 #undef BLANK 00075 #define BLANK ((long) ' ') 00076 #undef ZERO 00077 #define ZERO ((long) '0') 00078 00079 /* 00080 * _newrec_listio_after_nonadvancing is 1 if list directed 00081 * writes after a nonadvancing read or write will cause the record 00082 * to be flushed before list-directed write processing begins, 0 if 00083 * a list-directed write continues writing to the current record. 00084 * 00085 * These variables are modified by _wf_setup. 00086 */ 00087 short _newrec_listio_after_nonadvancing = 0; 00088 00089 #ifdef _UNICOS 00090 00091 int $WFF(void); 00092 00093 #define ERROR0(cond, n) { \ 00094 if (!(cond)) \ 00095 _ferr(css, n); \ 00096 else \ 00097 goto error; \ 00098 } 00099 00100 #define ERROR1(cond, n, p) { \ 00101 if (!(cond)) \ 00102 _ferr(css, (n), p); \ 00103 else \ 00104 goto error; \ 00105 } 00106 00107 /* Define macros to convert _numargs() to number of arguments */ 00108 #define ARGS_6 (4 + 2*sizeof(_fcd)/sizeof(long)) 00109 #define ARGS_7 (5 + 2*sizeof(_fcd)/sizeof(long)) 00110 #define ARGS_8 (6 + 2*sizeof(_fcd)/sizeof(long)) 00111 #define ARGS_9 (7 + 2*sizeof(_fcd)/sizeof(long)) 00112 00113 /* 00114 * Here we do some things for upward compatibility with CFT77 5.0.2. 00115 */ 00116 #define IS_PFORM_BROKEN (_numargs() < ARGS_9) /* true if pform is broken */ 00117 00118 /* 00119 * $WFI - write formatted initialization 00120 * 00121 * CALL $WFI,(funit, format, err, _arg4, iostat, rec, pform, inumelt, 00122 * inumcfe) 00123 * 00124 * funit Address of Fortran unit designator (integer unit 00125 * number for external I/O or Fortran character 00126 * descriptor (FCD) for internal I/O) 00127 * format Address of format (Fortran character descriptor or 00128 * hollerith); NULL if list-directed 00129 * err Address of error address (ERR=label) 00130 * _arg4 Unused 00131 * iostat Address of I/O status variable (integer variable) 00132 * rec Address of integer record number (NULL implies 00133 * sequential I/O) 00134 * pform Address of address of parsed format (NULL if no 00135 * compiler-supplied word; points to NULL if not yet 00136 * parsed) 00137 * inumelt Address of number of internal array elements 00138 * (internal I/O only) 00139 * inumcfe Argument passed by new compilers to indicate that 00140 * the pform argument is fixed, and to contain the 00141 * number of array elements in a character format. 00142 * 00143 * $WFI calls: 00144 * 00145 * _imp_open77(), _unit_seek(), _parse(), _ferr() 00146 */ 00147 00148 #ifdef _CRAYMPP 00149 $WFI( 00150 _fcd funit, /* Address of unit number or FCD */ 00151 ... 00152 ) 00153 #else 00154 int 00155 $WFI( 00156 _fcd funit, /* Address of unit number or FCD */ 00157 _fcd format, /* Address of format (FCD or hollerith) */ 00158 long *err, /* Address of error processing address */ 00159 long *_arg4, /* Unused */ 00160 _f_int *iostat, /* Address of IOSTAT variable */ 00161 _f_int *rec, /* Address of direct access record no. */ 00162 fmt_type **pform, /* Address of address of parsed format */ 00163 long *inumelt, /* Address of int. array element count */ 00164 long *inumcfe /* Address of number of format elements */ 00165 ) 00166 #endif 00167 { 00168 register int errf; /* ERR processing flag */ 00169 register int errn; /* Error number */ 00170 register int iost; /* I/O statement type */ 00171 register int iotp; /* I/O type */ 00172 register recn_t recn; /* Record number */ 00173 register unum_t unum; /* Unit number */ 00174 fmt_type **prsfmt; /* Parsed format info. */ 00175 unit *cup; /* Unit table pointer */ 00176 FIOSPTR css; /* I/O statement state */ 00177 #ifdef _CRAYMPP 00178 va_list args; 00179 _fcd format; /* Address of format (FCD or hollerith) */ 00180 long *err; /* Address of error processing address */ 00181 long *end; /* Address of end processing address */ 00182 _f_int *iostat; /* Address of IOSTAT variable */ 00183 _f_int *rec; /* Address of direct access record no. */ 00184 fmt_type **pform; /* Address of address of parsed format */ 00185 long *inumelt; /* Address of int. array element count */ 00186 long *inumcfe; /* Address of number of format elements */ 00187 #endif 00188 00189 GET_FIOS_PTR(css); 00190 00191 /* Check if recursive triple-call I/O */ 00192 00193 if (css->f_iostmt != 0) 00194 _ferr(css, FEIOACTV); 00195 00196 #ifdef _CRAYMPP 00197 va_start(args, funit); 00198 format = va_arg(args, _fcd); 00199 err = va_arg(args, long *); 00200 end = va_arg(args, long *); 00201 iostat = va_arg(args, _f_int *); 00202 rec = va_arg(args, _f_int *); 00203 00204 if (_numargs() > ARGS_6) { 00205 pform = va_arg(args, fmt_type **); 00206 if (_numargs() > ARGS_7) { 00207 inumelt = va_arg(args, long *); 00208 if (_numargs() > ARGS_8) { 00209 inumcfe = va_arg(args, long *); 00210 } 00211 } 00212 } 00213 va_end(args); 00214 #endif 00215 00216 errn = 0; 00217 00218 /* Establish error processing options */ 00219 00220 if (iostat != NULL) 00221 *iostat = 0; /* Clear IOSTAT variable, if extant */ 00222 00223 errf = ((err != NULL) || (iostat != NULL)); 00224 00225 /* Check if formatted or list-directed */ 00226 00227 iost = (_fcdtocp(format) != NULL) ? T_WSF : T_WLIST; 00228 iotp = SEQ; /* Assume sequential */ 00229 00230 /* Check if we're doing internal I/O or external I/O */ 00231 00232 if (_fcdlen(funit)) { /* If internal I/O */ 00233 iotp = INT; 00234 STMT_BEGIN(-1, 1, iost, NULL, css, cup); 00235 } 00236 else { /* Else external I/O */ 00237 unum = **(_f_int **) &funit; 00238 00239 if (rec != NULL) { /* If direct access */ 00240 iost = T_WDF; /* Set direct formatted read */ 00241 iotp = DIR; 00242 recn = *rec; 00243 } 00244 00245 STMT_BEGIN(unum, 0, iost, NULL, css, cup); 00246 00247 if (cup == NULL) { /* If not connected */ 00248 int stat; /* Status */ 00249 00250 cup = _imp_open77(css, iotp, FMT, unum, errf, &stat); 00251 00252 /* 00253 * If the open failed, cup is NULL and stat contains 00254 * the error number. 00255 */ 00256 00257 if (cup == NULL) { 00258 errn = stat; 00259 goto error; 00260 } 00261 } 00262 } 00263 00264 /* All paths which lead here have set cup to a non-null value */ 00265 00266 assert (cup != NULL); 00267 00268 /* Copy the user's error processing options into the unit table */ 00269 00270 cup->uflag = (iostat != NULL ? _UIOSTF : 0) | 00271 ( err != NULL ? _UERRF : 0); 00272 cup->uiostat = iostat; 00273 00274 if (iotp != INT) { /* If not internal I/O */ 00275 00276 /* If trying to write a file without write permission */ 00277 00278 if ((cup->uaction & OS_WRITE) == 0) { 00279 errn = FENOWRIT; /* No write permission */ 00280 ERROR0(errf, errn); 00281 } 00282 00283 /* If attempting formatted I/O on an unformatted file */ 00284 00285 if (!cup->ufmt) { 00286 errn = FEFMTTIV; /* Formatted not allowed */ 00287 ERROR0(errf, errn); 00288 } 00289 } 00290 00291 /* Initialize fields in the Fortran statement state structure */ 00292 00293 css->u.fmt.icp = NULL; 00294 css->u.fmt.nonl = 0; 00295 css->u.fmt.freepfmt = 0; 00296 00297 00298 if (_fcdtocp(format) != NULL) { /* If not list-directed output */ 00299 char *fptr; 00300 int flen; 00301 int fnum; 00302 int stsz; 00303 00304 /* 00305 * Initialize fmtbuf before any call to _ferr(). 00306 */ 00307 css->u.fmt.u.fe.fmtbuf = NULL; 00308 css->u.fmt.u.fe.fmtnum = 0; 00309 css->u.fmt.u.fe.fmtcol = 0; 00310 css->u.fmt.u.fe.scale = 0; 00311 css->u.fmt.cplus = 0; 00312 00313 /* 00314 * For formats passed as hollerith (integer) variables, 00315 * there is no rigorous definition of the "length" of the 00316 * format, so we simply use strlen() as a first-order 00317 * approximation. 00318 * 00319 * For static formats (FORMAT statements) or formats 00320 * which are character constants or simple character 00321 * variables, the length of the format is the length of 00322 * the character string. 00323 * 00324 * For formats passed as character arrays, then the length 00325 * of the format is the length of the entire array. We 00326 * compute this by multiplying the length of the element 00327 * passed times the dimension of the array (inumcfe argument). 00328 * 00329 * We cannot distinguish the latter two cases without the 00330 * the inumcfe argument (see SPR 52032), which was added to 00331 * CF77 5.0.2.19. If we do not have the inumcfe argument, 00332 * we resort to a strlen() call. 00333 */ 00334 00335 if (_fcdlen(format) == 0) { /* If noncharacter format */ 00336 fptr = *(char **) &format; 00337 flen = strlen(fptr); 00338 } 00339 else { /* Else character format */ 00340 register int repl; 00341 00342 if (_numargs() > ARGS_8 && inumcfe != NULL) 00343 repl = *inumcfe; 00344 else 00345 repl = -1; 00346 00347 fptr = _fcdtocp(format); 00348 flen = (repl >= 0) ? repl * _fcdlen(format) : 00349 strlen(fptr); 00350 } 00351 00352 /* 00353 * The pform argument was not passed to the library in early 00354 * versions of CFT77 (2.0 and earlier on CRAY-2's; 4.0 and 00355 * earlier on CX/CEA's). This check can be removed when we 00356 * no longer support those compilers. 00357 */ 00358 00359 if (_numargs() > ARGS_6) { 00360 prsfmt = pform; 00361 /* 00362 * The pform argument was passed incorrectly by the 00363 * CFT77 5.0 compiler on CX/CEA systems. The fixed 00364 * compiler passes the inumcfe argument to indicate that 00365 * pform is passed correctly. If the inumcfe argument 00366 * is not passed and pform != NULL then pform was 00367 * passed with one instead of two levels of 00368 * indirection. 00369 */ 00370 if (IS_PFORM_BROKEN && pform != NULL) { 00371 /* preparsed pform was passed incorrectly */ 00372 if (*(long*)pform == -1) 00373 /* variable format */ 00374 prsfmt = NULL; 00375 else 00376 /* pre-parsed format */ 00377 prsfmt = (fmt_type**)&pform; 00378 } 00379 } 00380 else 00381 prsfmt = NULL; 00382 00383 /* 00384 * Pull an optional statement number off of the beginning of 00385 * the format and save it. If a statement number is found, 00386 * update the format string pointer and length. Someday, 00387 * Obi-wan, we'll do this only for static formats. 00388 */ 00389 00390 fnum = 0; 00391 00392 while (isdigit(*fptr) && flen-- > 0) 00393 fnum = (fnum * 10) + ((int) *fptr++ - ZERO); 00394 00395 css->u.fmt.u.fe.fmtbuf = fptr; 00396 css->u.fmt.u.fe.fmtlen = flen; 00397 css->u.fmt.u.fe.fmtnum = fnum; 00398 00399 /* 00400 * If the format is a variable format, or if it has not yet 00401 * been parsed, or if it was parsed by an incompatible version 00402 * of the format parser, then parse it. 00403 */ 00404 00405 if (prsfmt == NULL || *prsfmt == NULL || 00406 (**prsfmt).offset != PARSER_LEVEL) { /* If not parsed */ 00407 00408 errn = _parse(css, cup, prsfmt); 00409 00410 if (errn != 0) { 00411 ERROR0(errf, errn); 00412 } 00413 } 00414 else /* Use already-parsed format */ 00415 css->u.fmt.u.fe.pfmt = *prsfmt; 00416 00417 /* 00418 * Ensure that the format count stack is allocated and is 00419 * large enough to accomodate the maximum nesting depth of 00420 * this format. 00421 */ 00422 00423 stsz = (*css->u.fmt.u.fe.pfmt).rep_count; 00424 00425 if (stsz > cup->upfcstsz) { 00426 00427 cup->upfcstsz = stsz; /* Set new depth */ 00428 00429 if (cup->upfcstk != NULL) 00430 free(cup->upfcstk); /* Free old stack */ 00431 00432 cup->upfcstk = (int *) malloc(sizeof(int) * stsz); 00433 00434 if (cup->upfcstk == NULL) { 00435 errn = FENOMEMY; /* No memory */ 00436 ERROR0(errf, errn); 00437 } 00438 } 00439 00440 css->u.fmt.u.fe.pftocs = cup->upfcstk; /* Top of count stack */ 00441 00442 /* Skip first entry of parsed format */ 00443 00444 css->u.fmt.u.fe.pfcp = css->u.fmt.u.fe.pfmt + 1; 00445 00446 /* Set initial repeat count */ 00447 00448 *css->u.fmt.u.fe.pftocs = css->u.fmt.u.fe.pfcp->rep_count; 00449 } 00450 else /* Else list-directed output */ 00451 css->u.fmt.u.le.ldwinit = 1; 00452 00453 /* Set processing functions */ 00454 00455 if (iotp == DIR) { 00456 00457 if (cup->useq) /* If direct attempted on seq. file */ 00458 errn = FEDIRTIV; /* Direct access not allowed */ 00459 else 00460 errn = _unit_seek(cup, recn, iost); 00461 00462 if (errn != 0) { 00463 ERROR1(errf, errn, recn); 00464 } 00465 00466 cup->uend = BEFORE_ENDFILE; 00467 cup->ulinecnt = 0; /* Num of characters written */ 00468 cup->ulinemax = 0; /* Highwater mark */ 00469 cup->ulineptr = cup->ulinebuf;/* Current character position */ 00470 css->u.fmt.endrec = _dw_endrec; 00471 } 00472 else { 00473 00474 /* 00475 * The inumelt argument was not passed to the library in 00476 * earlier (prior to 5.0) versions of CFT77. The check 00477 * can be removed when we no longer support those compilers. 00478 * For encode statements, later compilers are passing a 00479 * NULL value for inumelt. 00480 */ 00481 00482 if (iotp == INT) { /* If internal I/O */ 00483 00484 cup->ulinecnt = 0; /* Num chars written */ 00485 cup->ulinemax = 0; /* Highwater mark */ 00486 00487 css->u.fmt.iiae = 00488 ((_numargs() > ARGS_7) && (inumelt != NULL)) ? 00489 *inumelt : -1; 00490 css->u.fmt.endrec = _iw_endrec; 00491 css->u.fmt.icp = _fcdtocp(funit); 00492 css->u.fmt.icl = _fcdlen (funit); 00493 00494 /* 00495 * If the size of the internal record is greater 00496 * than the existing line buffer, then realloc() 00497 * another one; else just decrease urecsize. 00498 */ 00499 00500 if (css->u.fmt.icl > cup->urecsize) { 00501 00502 cup->ulinebuf = (long *) realloc(cup->ulinebuf, 00503 sizeof(long) * 00504 (css->u.fmt.icl + 1)); 00505 00506 if (cup->ulinebuf == NULL) { 00507 errn = FENOMEMY; /* No memory */ 00508 ERROR0(errf, errn); 00509 } 00510 } 00511 00512 cup->urecsize = css->u.fmt.icl; 00513 cup->ulineptr = cup->ulinebuf; 00514 } 00515 else { /* external sequential formatted I/O */ 00516 00517 if (cup->useq == 0) { /* If direct access file */ 00518 errn = FESEQTIV; /* Sequential not allowed */ 00519 ERROR0(errf, errn); 00520 } 00521 00522 if (cup->uend != BEFORE_ENDFILE) { 00523 /* 00524 * If positioned after an endfile, and the file 00525 * does not support multiple endfiles, a write 00526 * is invalid. 00527 */ 00528 if (!cup->umultfil && !cup->uspcproc) { 00529 errn = FEWRAFEN; 00530 ERROR0(errf, errn); 00531 } 00532 00533 /* 00534 * If a logical endfile record had just been 00535 * read, replace it with a physical endfile 00536 * record before starting the current data 00537 * record. 00538 */ 00539 if ((cup->uend == LOGICAL_ENDFILE) && 00540 !(cup->uspcproc)) { 00541 struct ffsw fst; /* FFIO status block */ 00542 00543 if (XRCALL(cup->ufp.fdc, weofrtn) 00544 cup->ufp.fdc, &fst) < 0) { 00545 00546 errn = fst.sw_error; 00547 00548 ERROR0(errf, errn); 00549 } 00550 } 00551 cup->uend = BEFORE_ENDFILE; 00552 } 00553 00554 if (cup->pnonadv && cup->uwrt == 0) { 00555 register int offset; 00556 /* 00557 * A formatted or list-directed write statement 00558 * follows a nonadvancing read. Switch the 00559 * current line (record) from read to write 00560 * mode. Then backspace the file so the 00561 * current record gets written back in place. 00562 */ 00563 00564 offset = cup->ulineptr - cup->ulinebuf; 00565 cup->ulinemax = offset + cup->ulinecnt; 00566 cup->ulinecnt = offset; 00567 cup->uflshptr = cup->ulinebuf; 00568 00569 errn = _unit_bksp(cup); 00570 00571 if (errn != 0) { 00572 ERROR0(errf, errn); 00573 } 00574 } 00575 else if (cup->pnonadv == 0) { 00576 /* 00577 * There is no current record (due to a prior 00578 * nonadvancing read or write). Initialize 00579 * the empty line buffer. 00580 */ 00581 cup->ulinecnt = 0; /* Num chars written */ 00582 cup->ulinemax = 0; /* Highwater mark */ 00583 cup->ulineptr = cup->ulinebuf; 00584 cup->uflshptr = cup->ulinebuf; 00585 } 00586 00587 /* 00588 * If list-directed write and there is a current 00589 * record, then truncate the current record at the 00590 * current position and flush it if the current record 00591 * is already beyond uldwsize. 00592 */ 00593 if (cup->pnonadv && (css->f_iostmt & TF_FMT) == 0) { 00594 errn = _lw_after_nonadv(css, cup, 00595 cup->uldwsize, 0); 00596 if (errn != 0) 00597 goto error; 00598 } 00599 00600 css->u.fmt.endrec = _sw_endrec; 00601 cup->pnonadv = 0; 00602 } 00603 } 00604 00605 css->u.fmt.leftablim = cup->ulineptr; /* set left tab limit */ 00606 cup->uwrt = 1; /* Write mode */ 00607 00608 /* Normal return with 0 in S3 */ 00609 00610 return(CFT77_RETVAL(IO_OKAY)); 00611 00612 error: 00613 /* Update IOSTAT variable, if specified, with error status */ 00614 00615 if (iostat != NULL) 00616 *iostat = errn; 00617 00618 if (cup != NULL) /* If we have a unit, set status */ 00619 cup->uflag = cup->uflag | _UERRC; /* Indicate error */ 00620 00621 /* Complete record and return */ 00622 00623 return(CFT77_RETVAL($WFF())); 00624 } 00625 00626 /* 00627 * $WFA$ - write formatted transfer 00628 * 00629 * CALL $WFA,(fwa, cnt, inc, typ) 00630 * 00631 * fwa First word address of datum (may be a Fortran 00632 * character descriptor) 00633 * cnt Number of data items 00634 * inc Stride between data items 00635 * typ Type of data 00636 * 00637 * $WFA$ calls: 00638 * 00639 * _ld_write(), _wrfmt(), $WFF() 00640 */ 00641 00642 int 00643 $WFA$( 00644 _fcd fwa, /* Address of first word of data */ 00645 long *cnt, /* Address of count of data items */ 00646 long *inc, /* Address of stride between data items */ 00647 long *typ /* Address of data type */ 00648 ) 00649 { 00650 register int errn; /* Error flag */ 00651 type_packet tip; /* Type information packet */ 00652 unit *cup; /* Pointer to unit table entry */ 00653 void *vaddr; /* Data byte address */ 00654 xfer_func *xfunc; /* Data transfer function */ 00655 FIOSPTR css; /* Pointer to I/O state structure */ 00656 00657 /* Set unit table pointer */ 00658 00659 GET_FIOS_PTR(css); 00660 00661 cup = css->f_cu; 00662 tip.type77 = *typ & 017; 00663 tip.type90 = _f77_to_f90_type_cnvt[tip.type77]; 00664 tip.count = *cnt; 00665 tip.stride = *inc; 00666 tip.intlen = _f77_type_len[tip.type77]; 00667 tip.extlen = tip.intlen; 00668 tip.elsize = tip.intlen; 00669 tip.cnvindx = 0; 00670 00671 if (tip.type77 == DT_CHAR) { 00672 vaddr = _fcdtocp(fwa); 00673 tip.elsize = tip.elsize * _fcdlen (fwa); 00674 } 00675 else 00676 vaddr = *(void **) &fwa; 00677 00678 xfunc = (css->f_iostmt & TF_FMT) ? _wrfmt : _ld_write; 00679 errn = xfunc(css, cup, vaddr, &tip, 0); 00680 00681 if (errn == 0) 00682 return(CFT77_RETVAL(IO_OKAY)); 00683 00684 /* Update IOSTAT variable, if specified, with error status */ 00685 00686 if (cup->uiostat != NULL) 00687 *(cup->uiostat) = errn; 00688 00689 cup->uflag = cup->uflag | _UERRC; /* Indicate error */ 00690 00691 /* Complete record and return */ 00692 00693 return(CFT77_RETVAL($WFF())); 00694 } 00695 00696 /* 00697 * $WFF - write formatted finalization 00698 * 00699 * CALL $WFF,() 00700 * 00701 * $WFF calls: 00702 * 00703 * _wrfmt() 00704 */ 00705 00706 int 00707 $WFF(void) 00708 { 00709 register int errn; /* Error flag */ 00710 register long flag; /* Copy of cup->uflag */ 00711 unit *cup; /* Pointer to unit table entry */ 00712 FIOSPTR css; /* Pointer to I/O state structure */ 00713 00714 /* Set unit table pointer */ 00715 00716 GET_FIOS_PTR(css); 00717 cup = css->f_cu; 00718 00719 if (cup == NULL) /* If unit not opened */ 00720 flag = _UERRC | _UERRF; 00721 else { 00722 00723 /* If no error, complete processing */ 00724 00725 if ((cup->uflag & _UERRC) == 0) { 00726 xfer_func *xfunc; 00727 00728 /* If formatted I/O, ensure format complete */ 00729 00730 xfunc = (css->f_iostmt & TF_FMT) ? _wrfmt : _ld_write; 00731 00732 errn = xfunc(css, cup, (void *) NULL, &__tip_null, 0); 00733 00734 /* Complete record */ 00735 00736 if (errn == 0) 00737 errn = (*css->u.fmt.endrec)(css, cup, 1); 00738 00739 if (errn != 0) { 00740 00741 /* Set IOSTAT variable */ 00742 00743 if (cup->uiostat != NULL) 00744 *(cup->uiostat) = errn; 00745 00746 /* Set error status */ 00747 00748 cup->uflag = cup->uflag | _UERRC; 00749 } 00750 } 00751 00752 /* If we allocated memory for a variable format, free it */ 00753 00754 if (css->u.fmt.freepfmt && css->u.fmt.u.fe.pfmt != NULL) 00755 free(css->u.fmt.u.fe.pfmt); 00756 00757 flag = cup->uflag; /* Save status */ 00758 } 00759 00760 STMT_END(cup, TF_WRITE, NULL, css); /* Unlock unit */ 00761 00762 /* Return proper status */ 00763 00764 if ((flag & _UERRC) == 0) /* If no error */ 00765 return(CFT77_RETVAL(IO_OKAY)); 00766 else 00767 if ((flag & (_UIOSTF | _UERRF)) != 0) 00768 return(CFT77_RETVAL(IO_ERR)); 00769 00770 _ferr(css, FEINTUNK); /* Deep weeds */ 00771 } 00772 00773 #endif /* _UNICOS */ 00774 00775 /* 00776 * _dw_endrec(css, cup, count) 00777 * 00778 * Process the end of a format or the slash edit- 00779 * descriptor on a direct access write 00780 * 00781 * css Current statement state pointer 00782 * cup Current unit pointer 00783 * count Count of records to write (1 if end of format else 00784 * >= 1 for slash edit descriptor) 00785 * 00786 * If no error, zero is returned. 00787 * If error and user error processing is enabled, error number is returned. 00788 * If error and no user error processing is enabled, _ferr() is called. 00789 * 00790 * Calls: _fwch() 00791 */ 00792 int 00793 _dw_endrec(FIOSPTR css, unit *cup, int count) 00794 { 00795 assert ( css != NULL ); 00796 assert ( cup != NULL ); 00797 assert ( count > 0 ); 00798 00799 /* Write current record */ 00800 00801 if (cup->ulinemax < cup->urecl) { /* If record length less then RECL */ 00802 register int i, j; 00803 long *ptr; 00804 00805 j = cup->urecl - cup->ulinemax; 00806 ptr = cup->ulinebuf + cup->ulinemax; 00807 00808 /* The following loop should vectorize */ 00809 00810 for (i = 0; i < j; i++) 00811 ptr[i] = BLANK; 00812 } 00813 00814 if (_fwch(cup, cup->ulinebuf, cup->urecl, FULL) < 0) 00815 RERROR(errno); /* Write error */ 00816 00817 if (count > 1) { /* If more than one record to write */ 00818 register int i; 00819 00820 if (cup->ulinemax > 0) { /* If the whole line isn't blank */ 00821 long *ptr; 00822 00823 ptr = cup->ulinebuf; 00824 00825 /* The following loop should vectorize */ 00826 00827 for (i = 0; i <= cup->ulinemax; i++) 00828 ptr[i] = BLANK; 00829 } 00830 00831 for (i = 1; i < count; i++) 00832 if (_fwch(cup, cup->ulinebuf, cup->urecl, FULL) < 0) 00833 RERROR(errno); /* Write failed */ 00834 } 00835 00836 cup->udalast = cup->udalast + count; 00837 00838 /* If we wrote beyond the last record, update last record */ 00839 00840 if (cup->udalast > cup->udamax) 00841 cup->udamax = cup->udalast; 00842 00843 cup->ulinecnt = 0; 00844 cup->ulinemax = 0; 00845 cup->ulineptr = cup->ulinebuf; 00846 css->u.fmt.leftablim = cup->ulinebuf; 00847 00848 return(0); 00849 } 00850 00851 /* 00852 * _iw_endrec(css, cup, count) 00853 * 00854 * Process the end of a format or a slash edit- 00855 * descriptor on an internal write 00856 * 00857 * css Current statement state pointer 00858 * cup Current unit pointer 00859 * count Count of records to write 00860 * 00861 * If no error, zero is returned. 00862 * 00863 * Calls: _pack(), memset() 00864 */ 00865 int 00866 _iw_endrec(FIOSPTR css, unit *cup, int count) 00867 { 00868 register int reclen; 00869 00870 assert ( css != NULL ); 00871 assert ( cup != NULL ); 00872 assert ( count > 0 ); 00873 00874 reclen = cup->ulinemax; 00875 00876 /* If internal file is not array, cannot go to next record */ 00877 00878 if (css->u.fmt.iiae-- == 0) 00879 RERROR(FEWRIEND); /* Internal write past end of array */ 00880 00881 (void) _pack(cup->ulinebuf, css->u.fmt.icp, reclen, -1); 00882 00883 if (reclen < css->u.fmt.icl) 00884 (void) memset(css->u.fmt.icp + reclen, BLANK, 00885 css->u.fmt.icl - reclen); 00886 00887 if (count > 1) { /* If more than one record to write */ 00888 register int i; 00889 00890 i = count - 1; 00891 00892 if (css->u.fmt.iiae < 0 || css->u.fmt.iiae > i) { 00893 css->u.fmt.iiae = css->u.fmt.iiae - i; 00894 (void) memset(css->u.fmt.icp + css->u.fmt.icl, BLANK, 00895 css->u.fmt.icl * i); 00896 css->u.fmt.icp = css->u.fmt.icp + (css->u.fmt.icl * i); 00897 } 00898 else /* Write each record until error */ 00899 for (i = 1; i < count; i++) { 00900 00901 if (css->u.fmt.iiae-- == 0) 00902 RERROR(FEWRIEND); /* Write past EOF */ 00903 00904 css->u.fmt.icp = css->u.fmt.icp + css->u.fmt.icl; 00905 00906 (void) memset(css->u.fmt.icp, BLANK, 00907 css->u.fmt.icl); 00908 } 00909 } 00910 00911 cup->ulinecnt = 0; 00912 cup->ulinemax = 0; 00913 cup->ulineptr = cup->ulinebuf; 00914 css->u.fmt.leftablim = cup->ulinebuf; 00915 css->u.fmt.icp = css->u.fmt.icp + css->u.fmt.icl; 00916 00917 return(0); 00918 } 00919 00920 /* 00921 * _sw_endrec(css, cup, count) 00922 * 00923 * Process the end of a format or a slash edit- 00924 * descriptor on a sequential write. 00925 * 00926 * css Current statement state pointer 00927 * cup Current unit pointer 00928 * count Count of records to write. 00929 * 00930 * If no error, zero is returned. 00931 * If error and user error processing is enabled, error number is returned. 00932 * If error and no user error processing is enabled, _ferr() is called. 00933 * 00934 * Calls: _fwch() 00935 */ 00936 int 00937 _sw_endrec(FIOSPTR css, unit *cup, int count) 00938 { 00939 register long mode; 00940 register long nchars; 00941 00942 assert ( css != NULL ); 00943 assert ( cup != NULL ); 00944 assert ( count > 0 ); 00945 00946 mode = css->u.fmt.nonl ? PARTIAL : FULL; 00947 nchars = cup->ulinemax - (cup->uflshptr - cup->ulinebuf); 00948 00949 if (_fwch(cup, cup->uflshptr, nchars, mode) < 0) 00950 RERROR(errno); /* Write failed */ 00951 00952 if (count > 1) { /* If more than one record to write */ 00953 register int i; 00954 00955 for (i = 1; i < count; i++) 00956 if (_fwch(cup, cup->ulinebuf, 0, FULL) < 0) 00957 RERROR(errno); /* Write failed */ 00958 } 00959 00960 cup->ulinecnt = 0; 00961 cup->ulinemax = 0; 00962 cup->ulineptr = cup->ulinebuf; 00963 cup->uflshptr = cup->ulinebuf; 00964 css->u.fmt.leftablim = cup->ulineptr; 00965 css->u.fmt.nonl = 0; 00966 00967 return(0); 00968 } 00969 00970 /* 00971 * _nonadv_partrec(css, cup) 00972 * 00973 * Process the end of a nonadvancing sequential write. 00974 * The part of the line buffer between cup->uflshptr and 00975 * cup->ulineptr is printed out. If cup->ulineptr is positioned 00976 * beyond the highwater mark because of a trailing TR or X edit 00977 * descriptor, print out only to the current highwater mark. 00978 * 00979 * css Current statement state pointer 00980 * cup Current unit pointer 00981 * 00982 * If no error, zero is returned. 00983 * If error and user error processing is enabled, error number is returned. 00984 * If error and no user error processing is enabled, _ferr() is called. 00985 * 00986 * Calls: _fwch() 00987 */ 00988 int 00989 _nonadv_partrec(FIOSPTR css, unit *cup) 00990 { 00991 register int nchars; 00992 register int offset; 00993 00994 assert ( css != NULL ); 00995 assert ( cup != NULL ); 00996 00997 offset = cup->ulineptr - cup->ulinebuf; 00998 00999 if (cup->ulinemax < offset) { 01000 register int i; 01001 register int padcnt; 01002 long *lbuff; 01003 01004 /* 01005 * Pad the area between ulinemax and ulineptr with blanks. 01006 * The area in the line buffer beyond the highwater mark 01007 * (ulinemax) would otherwise contain garbage. 01008 */ 01009 lbuff = cup->ulinebuf + cup->ulinemax; 01010 nchars = MIN(cup->ulinemax, cup->urecsize) - 01011 (cup->uflshptr - cup->ulinebuf); 01012 padcnt = MIN(offset, cup->urecsize) - cup->ulinemax; 01013 01014 for (i = 0; i < padcnt; i++) 01015 lbuff[i] = BLANK; 01016 } 01017 else 01018 nchars = cup->ulineptr - cup->uflshptr; 01019 01020 if (_fwch(cup, cup->uflshptr, nchars, PARTIAL) < 0) 01021 RERROR(errno); /* Write failed */ 01022 01023 cup->uflshptr = cup->uflshptr + nchars; 01024 01025 return(0); 01026 } 01027 01028 /* 01029 * _nonadv_endrec(css, cup) 01030 * 01031 * Write out the "current record" at the start of REWIND, 01032 * BACKSPACE, ENDFILE, or CLOSE processing when the previous 01033 * operation was a a nonadvancing write. 01034 * 01035 * css Current statement state pointer 01036 * cup Current unit pointer 01037 * 01038 * If no error, zero is returned. 01039 * If error and user error processing is enabled, error number is returned. 01040 * If error and no user error processing is enabled, _ferr() is called. 01041 * 01042 * Calls: _fwch() 01043 */ 01044 int 01045 _nonadv_endrec(FIOSPTR css, unit *cup) 01046 { 01047 register long nchars; 01048 01049 assert ( css != NULL ); 01050 assert ( cup != NULL ); 01051 01052 nchars = cup->ulinemax - (cup->uflshptr - cup->ulinebuf); 01053 01054 if (_fwch(cup, cup->uflshptr, nchars, FULL) < 0) 01055 RERROR(errno); /* Write failed */ 01056 01057 cup->pnonadv = 0; 01058 01059 return(0); 01060 } 01061 01062 /* 01063 * _lw_after_nonadv(css, cup) 01064 * 01065 * Manage the transition from a formatted nonadvancing read or 01066 * write to a list directed write. We blank out any part of 01067 * the line buffer which will be flushed along with the 01068 * list-directed output which follows. This blanking is needed 01069 * only if a trailing TR or X edit descriptor in the prior 01070 * nonadvancing I/O statement left us positioned beyond the 01071 * highwater mark in the record. 01072 * 01073 * Calls: _sw_endrec() 01074 */ 01075 int 01076 _lw_after_nonadv(FIOSPTR css, unit *cup, int linelimit, int namelist) 01077 { 01078 register int errn; 01079 01080 assert ( css != NULL ); 01081 assert ( cup != NULL ); 01082 01083 if (_newrec_listio_after_nonadvancing && !namelist) 01084 errn = _sw_endrec(css, cup, 1); 01085 else { 01086 register int nchars; 01087 01088 nchars = cup->ulineptr - cup->ulinebuf; 01089 01090 if (nchars > cup->urecsize) 01091 errn = FEWRLONG; 01092 else { 01093 if (nchars > cup->ulinemax) { 01094 register int i; 01095 register int lmax; 01096 register int nblanks; 01097 01098 nblanks = nchars - cup->ulinemax; 01099 lmax = cup->ulinemax; 01100 01101 for (i = 0; i < nblanks; i++) 01102 cup->ulinebuf[lmax + i] = BLANK; 01103 01104 } 01105 01106 cup->ulinemax = nchars; 01107 errn = 0; 01108 01109 if (cup->ulinemax > linelimit) 01110 errn = _sw_endrec(css, cup, 1); 01111 } 01112 } 01113 01114 return (errn); 01115 } 01116 01117 /* 01118 * _wf_setup 01119 * 01120 * Access the LISTIO_AFTER_NONADVANCING environment variable to 01121 * establish what happens when a list-directed output statement 01122 * follows a nonadvancing formatted READ or WRITE statment. 01123 * 01124 * Access the ZERO_WIDTH_PRECISION environment variable to 01125 * establish what happens when a zero-width format is used 01126 * for floating-point output. 01127 * 01128 * Access the FORMAT_TYPE_CHECKING environment variable to 01129 * establish the conformance rules for data/format checking. 01130 * 01131 * NEWREC Cause the current record to be flushed to the file 01132 * at the start of list-directed write processing. 01133 * CURPOS Cause the list-directed write processing to continue 01134 * at the current position in the current record. 01135 * 01136 * This function is called by _initialize_fortran_io() 01137 * 01138 * Calls: getenv(), memcpy(), strcmp(). 01139 */ 01140 void 01141 _wf_setup(void) 01142 { 01143 register short i; 01144 register signed char d4, d8, d16; 01145 char *str; 01146 01147 /* 01148 * Flush of current rec before list directed write is default for 01149 * pre 2.0 CrayLibs. No flushing is default for CrayLibs 2.0 and higher. 01150 */ 01151 _newrec_listio_after_nonadvancing = (_CRAYLIBS_RELEASE < 2000) ? 1 : 0; 01152 01153 str = getenv("LISTIO_AFTER_NONADVANCING"); 01154 01155 if (str != NULL) { 01156 if (strcmp(str, "NEWREC") == 0) 01157 _newrec_listio_after_nonadvancing = 1; 01158 else if (strcmp(str, "CURPOS") == 0) 01159 _newrec_listio_after_nonadvancing = 0; 01160 } 01161 01162 /* 01163 * Set default width for zero-width formats. The user can alter 01164 * these values via an environment variable, so they must be set 01165 * at runtime. 01166 */ 01167 01168 /* Assume default (full) precision */ 01169 01170 #ifdef _F_REAL4 01171 d4 = DREAL4; 01172 #else 01173 d4 = -1; 01174 #endif 01175 d8 = DREAL8; 01176 d16 = DREAL16; 01177 01178 str = getenv("ZERO_WIDTH_PRECISION"); 01179 01180 if (str != NULL) { 01181 if (strcmp(str, "PRECISION") == 0) { 01182 #ifdef _F_REAL4 01183 d4 = DREAL4_P; 01184 #endif 01185 d8 = DREAL8_P; 01186 d16 = DREAL16_P; 01187 } 01188 else if (strcmp(str, "HALF") == 0) { 01189 #ifdef _F_REAL4 01190 d4 = (d4 + 1) >> 1; 01191 #endif 01192 d8 = (d8 + 1) >> 1; 01193 d16 = (d16 + 1) >> 1; 01194 } 01195 } 01196 01197 for (i = D_ED; i <= G_ED; i++) { 01198 _rw_mxdgt[i-1][4-1] = d4; 01199 _rw_mxdgt[i-1][8-1] = d8; 01200 _rw_mxdgt[i-1][16-1] = d16; 01201 } 01202 01203 /* 01204 * Set conformance rules for data/format checking. The user can select 01205 * an alternate set of rules via an environment variable, so they must 01206 * be set at runtime. 01207 */ 01208 01209 str = getenv("FORMAT_TYPE_CHECKING"); 01210 01211 if (str != NULL) { 01212 register int sz; 01213 01214 sz = sizeof(fmtchk_t) * DVTYPE_ASCII; 01215 01216 if (strcmp(str, "RELAXED") == 0) { 01217 (void) memcpy( (void *) _RCHK, (void *)_RNOCHK, sz); 01218 (void) memcpy( (void *) _WCHK, (void *)_WNOCHK, sz); 01219 } 01220 else if (strcmp(str, "STRICT77") == 0) { 01221 (void) memcpy( (void *) _RCHK, (void *)_RCHK77, sz); 01222 (void) memcpy( (void *) _WCHK, (void *)_WCHK77, sz); 01223 } 01224 else if (strcmp(str, "STRICT90") == 0 || 01225 strcmp(str, "STRICT95") == 0) { 01226 (void) memcpy( (void *) _RCHK, (void *)_RCHK90, sz); 01227 (void) memcpy( (void *) _WCHK, (void *)_WCHK90, sz); 01228 } 01229 } 01230 01231 return; 01232 }