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/open.c 92.3 08/02/99 10:37:16" 00039 00040 #include <sys/param.h> /* PATH_MAX */ 00041 #include <string.h> 00042 #include <stdlib.h> 00043 #include <errno.h> 00044 #include <liberrno.h> 00045 #include <fcntl.h> 00046 #include <unistd.h> 00047 #include <cray/assign.h> 00048 #include <sys/stat.h> 00049 #include <stdio.h> 00050 #include "fio.h" 00051 00052 #define FERROR(cond, n) { \ 00053 if (!cond) \ 00054 _ferr(css, n); \ 00055 else \ 00056 return(n); \ 00057 } 00058 00059 #define FERROR1(cond, n, p) { \ 00060 if (!cond) \ 00061 _ferr(css, n, p); \ 00062 else \ 00063 return(n); \ 00064 } 00065 00066 static void freeit(void *); /* forward reference */ 00067 00068 /* 00069 * _f_open 00070 * 00071 * Primary Fortran OPEN and implicit open processing routine. 00072 * All external file units are connected via this routine. 00073 * 00074 * It is assumed that _openlock is locked upon entry to this 00075 * routine. Upon successful exit from this routine, the unit 00076 * will be locked. 00077 * 00078 * Side effect 00079 * 00080 * *cup_p is assigned the pointer to a newly allocated (and 00081 * locked) unit structure on exit. On input, *cup_p, if not 00082 * null, is a valid open unit. This unit is closed and unlocked 00083 * prior to reassignment of this pointer to the new unit. Note 00084 * that the new unit may be a different unit with the same 00085 * number. The new unit may have thread, process, or application 00086 * team scope, depending on what the -P assign option specifies. 00087 * 00088 * Return value is: 00089 * 00090 * 0 - normal return 00091 * >0 - error code if an error occurred 00092 */ 00093 00094 int 00095 _f_open( 00096 FIOSPTR css, /* Fortran statement state */ 00097 unit **cup_p,/* input: pointer to currently open unit. output: */ 00098 /* pointer to new unit. */ 00099 olist *olptr, /* OPEN information */ 00100 int isf90) /* 1 if being opened from CF90, 0 if CF77 */ 00101 { 00102 register short is_bin; /* 1 if binary; else 0 */ 00103 register short is_fmt; /* 1 if formatted; 0 if unformatted */ 00104 register short is_seq; /* 1 if sequential; 0 if direct */ 00105 register short is_sys; /* 1 if system; else 0 */ 00106 register short no_mem; /* 1 if malloc() fails */ 00107 register int aifound; /* 1 if assign/asgcmd info found */ 00108 register int errn; /* Error code */ 00109 register int gamask; /* Global assign mask */ 00110 register int oflags; /* O_EXCL/O_CREAT */ 00111 register int P_value; /* -P option value */ 00112 register int stdfn; /* 1 if std file stdin/stdout/stderr */ 00113 register int stdfnum; /* standard file descriptor number */ 00114 register int stat_ok; /* 1 if statbuf is valid */ 00115 register int tufs; /* requested file structure (default) */ 00116 register int uscope; /* File scope */ 00117 register unum_t unum; /* unit number */ 00118 char namebuf[MXUNITSZ]; /* buffer to construct file name */ 00119 char *fname; /* FILE= specifier or default filename*/ 00120 char *aname; /* actual file name */ 00121 char *atstr; /* assign attributes string */ 00122 unit *cup; 00123 assign_info ai; 00124 struct stat statbuf; 00125 00126 unum = olptr->ounit; 00127 00128 if (! GOOD_UNUM(unum)) 00129 FERROR1(olptr->oerr, FEIVUNIT, unum); 00130 00131 /* 00132 * Check for a re-open before initializing any unit table fields. 00133 */ 00134 if (OPEN_UPTR(*cup_p)) { 00135 /* 00136 * The unit is connected, but we have already checked in 00137 * $OPN for reconnection to the same file with unchanged 00138 * attributes. Thus, we know that we may disconnect the unit 00139 * here before continuing the set up of the new connection. 00140 * 00141 * We unlock it so that _alloc_unit may find it again and 00142 * lock it. 00143 */ 00144 00145 errn = _unit_close(*cup_p, CLST_UNSPEC, NULL); 00146 00147 if (errn != 0) 00148 FERROR(olptr->oerr, errn); 00149 00150 _release_cup(*cup_p); /* unlock the unit */ 00151 } 00152 00153 /* 00154 * "aname" receives the actual name to be opened by the system. 00155 * It starts out the same as fname, but might later be reassigned 00156 * by assign. 00157 */ 00158 00159 aname = NULL; 00160 fname = NULL; 00161 stdfn = 0; 00162 no_mem = 0; 00163 00164 if (olptr->ofile == NULL) { /* If no name specified */ 00165 00166 if (olptr->ostatus == OS_SCRATCH) { /* If SCRATCH */ 00167 int scratchfd; 00168 /* 00169 * Scratch files have no name (see INQUIRE). 00170 */ 00171 fname = NULL; 00172 aname = strdup("FXXXXXX"); 00173 scratchfd = mkstemp(aname); 00174 close(scratchfd); /* because mkstemp opens the file */ 00175 } 00176 else if (unum == 0 || unum == 5 || unum == 6 || 00177 RSVD_UNUM(unum)) { 00178 stdfn = 1; /* Possible standard file */ 00179 stdfnum = -1; 00180 00181 switch (unum) { 00182 00183 case 5: /* Connect 5 and 100 to stdin */ 00184 case 100: 00185 stdfnum = STDIN_FILENO; 00186 break; 00187 case 6: /* Connect 6 and 101 to stdout */ 00188 case 101: 00189 stdfnum = STDOUT_FILENO; 00190 break; 00191 case 0: /* Connect 0 and 102 to stderr/errfile */ 00192 case 102: /* (see finit.c) */ 00193 stdfnum = fileno(errfile); 00194 break; 00195 default: 00196 _ferr(css, FEINTUNK); /* deep weeds */ 00197 } 00198 } 00199 else { /* not scratch nor standard file */ 00200 00201 (void) _fortname(namebuf, unum); /* Make default name */ 00202 00203 fname = strdup(namebuf); 00204 aname = strdup(namebuf); 00205 no_mem = (aname == NULL) || (fname == NULL); 00206 } 00207 } 00208 else { /* Copy user supplied name */ 00209 if ((fname = malloc(olptr->ofilelen + 1)) != NULL) { 00210 _copy_n_trim(olptr->ofile, olptr->ofilelen, fname); 00211 aname = strdup(fname); 00212 } 00213 00214 no_mem = (aname == NULL) || (fname == NULL); 00215 } 00216 00217 if (no_mem) { /* If malloc() failed */ 00218 00219 freeit(aname); 00220 freeit(fname); 00221 00222 FERROR(olptr->oerr, FENOMEMY); /* No memory */ 00223 } 00224 00225 00226 is_bin = (olptr->oform == OS_BINARY) ? 1 : 0; 00227 is_fmt = (olptr->oform == OS_FORMATTED) ? 1 : 0; 00228 is_seq = (olptr->oaccess == OS_SEQUENTIAL ? 1 : 0); 00229 is_sys = (olptr->oform == OS_SYSTEM) ? 1 : 0; 00230 00231 /* 00232 * The ASN_G_SF/SU/DF/DU masks map to the ACCESS/FORM specifiers on OPEN. 00233 */ 00234 switch ((is_seq << 3) | is_fmt) { 00235 00236 case 011: /* Sequential Formatted */ 00237 gamask = ASN_G_SF; 00238 break; 00239 00240 case 010: /* Sequential Unformatted */ 00241 gamask = ASN_G_SU; 00242 break; 00243 00244 case 001: /* Direct Formatted */ 00245 gamask = ASN_G_DF; 00246 break; 00247 00248 case 000: /* Direct Unformatted */ 00249 gamask = ASN_G_DU; 00250 break; 00251 } 00252 00253 gamask = gamask | ASN_G_ALL; 00254 atstr = NULL; 00255 aifound = _assign_asgcmd_info(fname, unum, gamask, &ai, &atstr, 00256 olptr->oerr); 00257 00258 if (aifound == -1) { 00259 freeit(fname); 00260 freeit(aname); 00261 freeit(atstr); 00262 FERROR(olptr->oerr, errno); 00263 } 00264 00265 /* 00266 * Set up the scoping of this unit. -P process is default. 00267 */ 00268 uscope = AS_PROCESS; /* actual scope */ 00269 P_value = AS_PROCESS; /* -P option value, if any */ 00270 00271 if (aifound == 1 && ai.P_ioscop_flg) { 00272 uscope = ai.P_ioscop; 00273 P_value = ai.P_ioscop; 00274 /* Map -P private and -P global to the new spelling */ 00275 #ifdef _CRAYMPP 00276 if (ai.P_ioscop == AS_PRIVATE) 00277 uscope = AS_PROCESS; 00278 #else 00279 if (ai.P_ioscop == AS_PRIVATE) 00280 uscope = AS_THREAD; 00281 00282 if (ai.P_ioscop == AS_GLOBAL) 00283 uscope = AS_PROCESS; 00284 #endif 00285 } 00286 00287 #ifdef _CRAYMPP 00288 if (uscope == AS_GLOBAL) 00289 FERROR(olptr->oerr, FENOGLOB); 00290 00291 if (uscope == AS_THREAD) 00292 FERROR(olptr->oerr, FENOTHRD); 00293 00294 if (uscope == AS_TEAM) 00295 FERROR(olptr->oerr, FENOTEAM); 00296 #else 00297 if (uscope == AS_TEAM) 00298 FERROR(olptr->oerr, FENOTEAM); 00299 #endif 00300 00301 /* 00302 * Now that we know the unit number and scope we can get a pointer to the 00303 * unit table. 00304 */ 00305 #ifdef _CRAYMPP 00306 cup = _alloc_unit(unum, 1); /* TEMPORARY */ 00307 #else 00308 cup = _alloc_unit(unum, (uscope == AS_THREAD)); 00309 #endif 00310 if (cup == NULL) 00311 FERROR1(olptr->oerr, errno, unum); 00312 00313 *cup_p = cup; 00314 00315 /* 00316 * Record OPEN specifiers in unit table 00317 */ 00318 cup->ubinary = is_bin; 00319 cup->ufmt = is_fmt; 00320 cup->useq = is_seq; 00321 cup->usystem = is_sys; 00322 cup->ublnk = (olptr->oblank == OS_ZERO ? 1 : 0); 00323 cup->uposition = olptr->oposition; 00324 cup->uaction = olptr->oaction; 00325 cup->udelim = olptr->odelim; 00326 cup->upad = olptr->opad; 00327 cup->urecl = olptr->orecl; 00328 00329 /* 00330 * Initialize the cf77/f90 mode. It might be changed in f_asgn() later. 00331 */ 00332 cup->uft90 = isf90; 00333 00334 if (aifound == 1 && ai.a_actfil_flg) { 00335 stdfn = 0; /* standard file overridden */ 00336 00337 freeit(aname); 00338 aname = strdup(ai.a_actfil); 00339 00340 if (aname == NULL) { 00341 freeit(atstr); 00342 freeit(fname); 00343 FERROR(olptr->oerr, FENOMEMY); 00344 } 00345 } 00346 00347 if (aifound == 1 && ai.D_fildes_flg) { 00348 stdfn = 1; /* indicate standard file */ 00349 stdfnum = ai.D_fildes; 00350 00351 freeit(aname); 00352 aname = NULL; 00353 } 00354 00355 /* 00356 * Units connected to stdin, stdout, or stderr may not have thread scope 00357 * on PVP systems. 00358 */ 00359 #ifdef _CRAYMPP 00360 if (stdfn && uscope == AS_TEAM) { 00361 freeit(fname); 00362 freeit(aname); 00363 freeit(atstr); 00364 FERROR(olptr->oerr, FENOTEAM); 00365 } 00366 #else 00367 if (stdfn && uscope == AS_THREAD) { 00368 freeit(fname); 00369 freeit(aname); 00370 freeit(atstr); 00371 FERROR(olptr->oerr, (P_value==AS_PRIVATE)? FENOPRIV: FENOTHRD); 00372 } 00373 #endif 00374 00375 /* 00376 * Set up cup->urecsize, the maximum record size. If RECL was 00377 * specified (it's required on direct access files; optional 00378 * on sequential access files), then RECL becomes the maximum 00379 * record size for all formatted I/O on this unit. Otherwise 00380 * we use default values for the maximum record size for both 00381 * regular I/O and list-directed/namelist output. 00382 */ 00383 00384 if (cup->ufmt) { /* If formatted file */ 00385 00386 if (cup->urecl > 0) { /* If RECL specified */ 00387 cup->urecsize = cup->urecl; 00388 cup->uldwsize = cup->urecl; 00389 } 00390 else { /* Else set defaults */ 00391 cup->urecsize = _f_rcsz; 00392 cup->uldwsize = _f_ldsz; 00393 } 00394 00395 /* Allocate line buffer for formatted files */ 00396 00397 cup->ulinebuf = (long *) malloc(sizeof(long) * 00398 (cup->urecsize + 1)); 00399 00400 if (cup->ulinebuf == NULL) { 00401 freeit(fname); 00402 freeit(aname); 00403 freeit(atstr); 00404 FERROR(olptr->oerr, FENOMEMY); 00405 } 00406 } 00407 00408 /* 00409 * See if the file exists. We don't know the filename for sure if FFIO 00410 * is being used though. 00411 */ 00412 errn = 0; 00413 stat_ok = 0; 00414 00415 if (stdfn) { 00416 errn = fstat(stdfnum, &statbuf); 00417 stat_ok = 1; 00418 } 00419 else if (aifound == 0 || ai.F_filter_flg == 0) { 00420 errn = stat(aname, &statbuf); 00421 stat_ok = 1; 00422 } 00423 00424 /* 00425 * ENOENT means the file doesn't exist. EINTR means the request 00426 * was interrupted. If we got an EINTR error, retry the stat 00427 * request a few times. A persistent EINTR error or any other 00428 * stat error besides ENOENT is fatal. 00429 * 00430 * On UNICOS and UNICOS/mk systems, a EINTR error should never 00431 * occur on a stat request... but we've seen some on UNICOS/mk 00432 * for a reason the kernel developers do not understand. 00433 */ 00434 00435 if (stat_ok && errn == -1) { /* If we did a stat and it failed */ 00436 register short retry = 0; 00437 00438 while (errn == -1 && errno == EINTR && retry++ < 10) { 00439 if (stdfn) 00440 errn = fstat(stdfnum, &statbuf); 00441 else 00442 errn = stat(aname, &statbuf); 00443 } 00444 00445 if (errn == -1) { /* We have a hard failure */ 00446 00447 stat_ok = 0; 00448 00449 if (errno != ENOENT) { /* If not ENOENT, abort */ 00450 freeit(fname); 00451 freeit(aname); 00452 freeit(atstr); 00453 freeit(cup->ulinebuf); 00454 FERROR(olptr->oerr, errno); 00455 } 00456 } 00457 } 00458 00459 /* Select the file structure */ 00460 00461 if (aifound == 1 && (ai.s_fstrct_flg || ai.F_filter_flg)) { 00462 if (ai.F_filter_flg) 00463 tufs = FS_FDC; 00464 else 00465 tufs = ai.s_fstrct; 00466 } 00467 else { 00468 /* Select default file structure */ 00469 00470 if ( cup->ufmt ) /* if formatted */ 00471 #if defined(__mips) || defined(_LITTLE_ENDIAN) 00472 tufs = (cup->useq) ? FS_TEXT : FS_UNBLOCKED; 00473 #else 00474 tufs = FS_TEXT; 00475 #endif 00476 else { /* else unformatted */ 00477 #ifdef _UNICOS 00478 tufs = (cup->useq) ? FS_COS : FS_UNBLOCKED; 00479 #else /* else NOT _UNICOS */ 00480 tufs = (cup->useq) ? FS_F77 : FS_UNBLOCKED; 00481 #endif /* END _UNICOS */ 00482 if (is_bin || is_sys) { 00483 /* 00484 * Use UNBLOCKED layer for direct or 00485 * sequential unformatted IO that does 00486 * not contain record control images. 00487 * Formatted IO is not allowed (i.e., a) 00488 */ 00489 tufs = FS_UNBLOCKED; 00490 } 00491 00492 } 00493 00494 /* See if the device is a tape and handle it accordingly */ 00495 00496 if (stat_ok && _gsys_qtape(&statbuf) != 0) 00497 tufs = FS_TAPE; 00498 } 00499 00500 /* 00501 * Process the open for standard files (STDIN_FILENO, STDOUT_FILENO 00502 * or STDERR_FILENO) 00503 */ 00504 00505 if (stdfn) { 00506 FILE *stdf; 00507 00508 #if defined(_LITTLE_ENDIAN) && !defined(__sv2) 00509 /* iob not the same on non-sv2 little endian systems. 00510 * Use the following: 00511 */ 00512 switch(stdfnum) { 00513 case(STDIN_FILENO): 00514 stdf = _IO_stdin; 00515 break; 00516 case(STDOUT_FILENO): 00517 stdf = _IO_stdout; 00518 break; 00519 default: 00520 stdf = _IO_stderr; 00521 break; 00522 } 00523 #else 00524 stdf = &__iob[stdfnum]; 00525 #endif 00526 00527 if (!cup->useq || !cup->ufmt || 00528 (tufs != FS_TEXT && tufs != STD)) { 00529 freeit(fname); 00530 freeit(aname); 00531 freeit(atstr); 00532 freeit(cup->ulinebuf); 00533 FERROR(olptr->oerr, FEOPSTFN); /* Std file mismatch */ 00534 } 00535 00536 if (stdfnum < STDIN_FILENO || stdfnum > STDERR_FILENO) { 00537 /* Should not happen because assign filters out */ 00538 /* unsupported file descriptor values */ 00539 freeit(fname); 00540 freeit(aname); 00541 freeit(atstr); 00542 freeit(cup->ulinebuf); 00543 FERROR(olptr->oerr,FEINTUNK); 00544 } 00545 00546 if (fileno(stdf) != stdfnum) { 00547 /* Stdio file has been reopened with an alternate */ 00548 /* file descriptor! */ 00549 freeit(fname); 00550 freeit(aname); 00551 freeit(atstr); 00552 freeit(cup->ulinebuf); 00553 FERROR(olptr->oerr,FEINTUNK); 00554 } 00555 00556 cup->ufp.std = stdf; 00557 00558 /* 00559 * The auxiliary lock protects multiple units connected to 00560 * the same standard file. 00561 */ 00562 switch (stdfnum) { 00563 case STDIN_FILENO: 00564 cup->auxlockp = &_stdin_lock; 00565 break; 00566 00567 case STDOUT_FILENO: 00568 cup->auxlockp = &_stdout_lock; 00569 break; 00570 00571 case STDERR_FILENO: 00572 cup->auxlockp = &_stderr_lock; 00573 break; 00574 } 00575 00576 /* 00577 * Standard files have no Fortran name. 00578 */ 00579 00580 freeit(aname); 00581 freeit(fname); 00582 aname = NULL; 00583 fname = NULL; 00584 } 00585 00586 /* 00587 * Record the file name and unit number in the unit. The alfnm field 00588 * might be changed later. 00589 */ 00590 00591 cup->ufnm = fname; 00592 cup->alfnm = aname; 00593 cup->uid = unum; 00594 00595 /* Process the STATUS specifier */ 00596 00597 cup->uostatus = olptr->ostatus; 00598 00599 switch (olptr->ostatus) { 00600 00601 case OS_UNKNOWN: 00602 default: 00603 oflags = O_CREAT; 00604 break; 00605 00606 case OS_SCRATCH: 00607 cup->uscrtch = 1; 00608 oflags = O_CREAT; 00609 break; 00610 00611 case OS_OLD: 00612 oflags = 0; 00613 break; 00614 00615 case OS_NEW: 00616 /* Unless tape or pipe, file is not allowed to exist */ 00617 00618 if (stat_ok && !S_ISCHR(statbuf.st_mode) && 00619 !S_ISFIFO(statbuf.st_mode)) { 00620 freeit(fname); 00621 freeit(aname); 00622 freeit(atstr); 00623 freeit(cup->ulinebuf); 00624 FERROR(olptr->oerr, FEOPFNNX); 00625 } 00626 00627 cup->uostatus = OS_OLD; /* NEW becomes OLD */ 00628 00629 oflags = O_EXCL | O_CREAT; 00630 break; 00631 00632 case OS_REPLACE: 00633 /* 00634 * Fortran 90 addition to replace existing file with 00635 * a new file or create new file if no file exists. 00636 * The error check on use of filename with the new 00637 * option is in opn.c. 00638 */ 00639 cup->uostatus = OS_OLD; /* REPLACE becomes OLD */ 00640 00641 oflags = O_CREAT; 00642 break; 00643 00644 } /* switch */ 00645 00646 /* Open the file; use whatever permissions are available */ 00647 00648 errn = _f_opn(aname, cup, css, tufs, aifound, &ai, &statbuf, 00649 stat_ok, olptr->oerr, oflags); 00650 00651 if (errn != OK) { 00652 errn = errno; 00653 /* 00654 * Map EEXIST to something more meaningfull to Fortran users. 00655 */ 00656 if (errn == EEXIST) 00657 errn = FEOPFNNX; 00658 00659 goto open_error; 00660 } 00661 00662 #ifdef _CRAYMPP 00663 /* Don't trunc() standard files on the MPP, since they're shared */ 00664 if (stdfn) 00665 cup->utrunc = 0; /* Clear trunc() flag */ 00666 #endif 00667 00668 /* 00669 * Check that another unit hasn't been opened to the same file 00670 */ 00671 _set_device_and_inode(cup->usysfd, &cup->udevice, &cup->uinode); 00672 00673 errn = _uniqinod(cup, (aifound ? &ai : NULL)); 00674 00675 if (errn != 0) 00676 goto open_error; 00677 00678 /* 00679 * Check that the same unit number is not opened at more than one 00680 * scoping level. 00681 */ 00682 errn = _mixed_scope(cup); 00683 00684 if (errn != 0) 00685 goto open_error; 00686 00687 /*************************************************************************** 00688 * * 00689 * The unit is now a valid connected unit. * 00690 * * 00691 ***************************************************************************/ 00692 00693 /* 00694 * Truncate the file to zero size if STATUS='REPLACE'. 00695 */ 00696 if (olptr->ostatus == OS_REPLACE) { 00697 errn = _unit_trunc(cup); 00698 00699 if (errn != 0) 00700 goto open_error; 00701 00702 /* 00703 * Some FDC layers cannot read after write, and 00704 * unit_trunc is like a write to FDC layers; so 00705 * do a seek to clear the last-operation-was-a-write 00706 * status. 00707 */ 00708 if (cup->ufs == FS_FDC) { 00709 struct ffsw fst; 00710 00711 XRCALL(cup->ufp.fdc, seekrtn) cup->ufp.fdc, 0, 0, &fst); 00712 } 00713 00714 cup->udamax = 0; 00715 } 00716 00717 /* 00718 * Position the file as specified with the POSITION specifier 00719 */ 00720 switch (cup->uposition) { 00721 00722 case OS_REWIND: 00723 case OS_ASIS: /* do nothing */ 00724 break; 00725 00726 case OS_APPEND: /* Position to end of file. */ 00727 00728 /* position to end */ 00729 { 00730 int neg1; 00731 00732 neg1 = -1; 00733 errn = _setpos(css, cup, &neg1, 1); 00734 00735 if (errn != 0) 00736 goto open_error; 00737 00738 errn = _unit_bksp(cup); 00739 00740 if (errn != 0) 00741 goto open_error; 00742 } 00743 break; 00744 00745 } /* switch */ 00746 00747 /* 00748 * If assigned with -t, unlink it now. 00749 */ 00750 if (cup->utmpfil) { 00751 errn = _unit_scratch(cup); 00752 00753 if (errn != 0) 00754 goto open_error; 00755 } 00756 00757 /* 00758 * Set up OK flags to speed up error checking in I/O statements. 00759 */ 00760 _set_ok_flags(cup); 00761 00762 if (FORTSTATS) { 00763 /* 00764 * Now initialize statistics counting for this unit. 00765 */ 00766 if (_ft_stopen(cup, atstr) == -1) { 00767 errn = errno; 00768 goto open_error; 00769 } 00770 } 00771 00772 freeit(atstr); 00773 00774 /* 00775 * The auxliary lock needs to be locked. If this is a reopen, 00776 * _unit_close() unlocked it. Otherwise it has not yet been locked. 00777 */ 00778 00779 if (cup->auxlockp != NULL) 00780 MEM_LOCK(cup->auxlockp); 00781 00782 return(0); 00783 00784 /* Process error(s) */ 00785 00786 open_error: /* Error code is in errn */ 00787 freeit(atstr); 00788 (void)_unit_close(cup, CLST_UNSPEC, NULL); 00789 00790 FERROR(olptr->oerr, errn); 00791 00792 return(0); /* not reached */ 00793 } 00794 00795 /* 00796 * Free a pointer if it's non-null. 00797 */ 00798 static void 00799 freeit(void *ptr) 00800 { 00801 if (ptr != NULL) 00802 free(ptr); 00803 } 00804 00805 /* 00806 * _set_ok_flags 00807 * 00808 * Initialize all cup->ok_* flags in a unit. This function is 00809 * called by _f_open() and _init_internal_unit(). 00810 */ 00811 00812 void 00813 _set_ok_flags(unit *cup) 00814 { 00815 cup->ok_wr_seq_fmt = _get_mismatch_error(1, T_WSF, cup, NULL) == 0; 00816 cup->ok_wr_seq_unf = _get_mismatch_error(1, T_WSU, cup, NULL) == 0; 00817 cup->ok_wr_dir_fmt = _get_mismatch_error(1, T_WDF, cup, NULL) == 0; 00818 cup->ok_wr_dir_unf = _get_mismatch_error(1, T_WDU, cup, NULL) == 0; 00819 00820 cup->ok_rd_seq_fmt = _get_mismatch_error(1, T_RSF, cup, NULL) == 0; 00821 cup->ok_rd_seq_unf = _get_mismatch_error(1, T_RSU, cup, NULL) == 0; 00822 cup->ok_rd_dir_fmt = _get_mismatch_error(1, T_RDF, cup, NULL) == 0; 00823 cup->ok_rd_dir_unf = _get_mismatch_error(1, T_RDU, cup, NULL) == 0; 00824 00825 return; 00826 } 00827 00828 /* 00829 * _get_mismatch_error 00830 * 00831 * This function evaluates the unchanging properties of 00832 * a unit (ie. cup->ufmt, etc.), to determine whether particular 00833 * types of I/O statements are valid for this unit. This routine 00834 * is called once at open time to set up the cup->ok_* fields in 00835 * the unit table. They are also called if an error is detected 00836 * in _FWF, _FRF, _FWU, or _FRU. 00837 * 00838 * Return Value: 00839 * 00840 * The error number. If the noabort argument is 0, then this 00841 * function calls _ferr(). 00842 */ 00843 00844 int 00845 _get_mismatch_error( 00846 int noabort,/* nonzero if we should not abort on error */ 00847 int iost, /* type of I/O statement (T_WSF, ...) */ 00848 unit *cup, /* unit pointer */ 00849 FIOSPTR css) /* Fortran I/O statement state; May be NULL if 00850 * noabort is nonzero */ 00851 { 00852 register int errn = 0; 00853 00854 if (cup->ufs == FS_AUX) { 00855 errn = FEMIXAUX; 00856 goto ret; 00857 } 00858 00859 /* if write statement, else read statement ... */ 00860 00861 if (iost & TF_WRITE) { 00862 if ((cup->uaction & OS_WRITE) == 0) { 00863 errn = FENOWRIT; /* No write permission */ 00864 goto ret; 00865 } 00866 } 00867 else { 00868 if ((cup->uaction & OS_READ) == 0) { 00869 errn = FENOREAD; /* No read permission */ 00870 goto ret; 00871 } 00872 } 00873 00874 /* if formatted I/O statement, else unformatted ... */ 00875 00876 if (iost & TF_FMT) { 00877 if (!cup->ufmt) { 00878 errn = FEFMTTIV; /* Formatted not allowed */ 00879 goto ret; 00880 } 00881 } 00882 else { 00883 if (cup->ufmt) { 00884 errn = FEUNFMIV; /* Unformatted not allowed */ 00885 goto ret; 00886 } 00887 } 00888 00889 /* if direct access I/O statement, else sequential ... */ 00890 00891 if (iost == T_WDF || iost == T_WDU || iost == T_RDF || iost == T_RDU) { 00892 if (cup->useq) { 00893 errn = FEDIRTIV; /* Direct access not allowed */ 00894 goto ret; 00895 } 00896 } else { 00897 if (cup->useq == 0) { 00898 errn = FESEQTIV; /* Sequential not allowed */ 00899 goto ret; 00900 } 00901 } 00902 00903 ret: 00904 if (noabort) 00905 return(errn); 00906 else { 00907 if (errn == 0) 00908 errn = FEINTUNK; /* force an abort */ 00909 00910 _ferr(css, errn); 00911 } 00912 00913 return(FEINTUNK); /* not reached */ 00914 } 00915 00916 #ifdef _UNICOS 00917 /* 00918 * The module open.c must have hard references to any routines which 00919 * are needed for Fortran I/O initialization. The functions referenced 00920 * here are accessed with soft references by $START and are called at 00921 * startup time only if they have hard reverences. 00922 * 00923 * It is assumed that any Fortran program which does Fortran I/O has 00924 * hard references to some entry point in this module (usually _f_open 00925 * through _implicit_open). Internal file I/O processing is integrated 00926 * with the external I/O path, so internal Fortran I/O statements DO 00927 * cause hard references to open.c. 00928 * 00929 * __fio_hardrefs() should NEVER be called. 00930 */ 00931 00932 void 00933 __fio_hardrefs() 00934 { 00935 (void) _finit(); /* Has a soft reference in $START. It is 00936 * called only for programs which do Fortran 00937 * I/O. */ 00938 00939 #if defined(_CRAY1) 00940 (void) _repriev(); /* A hard reference of _repriev causes the 00941 * appropriate style of program abort 00942 * handling for programs which do Fortran 00943 * I/O. */ 00944 #endif 00945 } 00946 00947 #endif /* _UNICOS */