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/unit.c 92.1 06/18/99 18:38:26" 00039 #include <errno.h> 00040 #include <foreign.h> 00041 #include <fortran.h> 00042 #include <liberrno.h> 00043 #include "fio.h" 00044 00045 /* 00046 * UNIT function status values 00047 */ 00048 #define UNIT_PDONE (-2.0) /* Partial record read complete, data remains */ 00049 #define UNIT_DONE (-1.0) /* Operation completed */ 00050 #define UNIT_EOF (0.0) /* EOF on BUFFER IN */ 00051 #define UNIT_PERROR (1.0) /* Partially recovered error */ 00052 #define UNIT_ERROR (2.0) /* Unrecovered Error */ 00053 00054 /* 00055 * _UNIT_ 00056 * 00057 * Wait for completion of BUFFER IN/OUT and return a status. 00058 * 00059 * Return value: 00060 * 00061 * -2.0 Partial record read complete, data remains 00062 * -1.0 Operation complete 00063 * 0.0 End of file 00064 * 1.0 Partially recovered error 00065 * 2.0 Unrecovered error 00066 * 00067 * Undocumented feature: S2 is assigned on exit the specific error 00068 * code for the previous BUFFER IN or BUFFER OUT statement for 00069 * FFIO files when value 2.0 is returned by the function. 00070 * 00071 * Define duplicate entry points 00072 * 00073 * UNIT - if user declares it EXTERNAL 00074 * @UNIT - if user declares it INTRINSIC on CRAY-2 systems 00075 * $UNIT - if user declares it INTRINSIC on CX/CEA systems 00076 * _UNIT - if user declares it INTRINSIC with CF77 6.0.0.3 or 00077 * previous on the T3D (obsolete) 00078 */ 00079 #ifdef _UNICOS 00080 #pragma _CRI duplicate _UNIT_ as UNIT 00081 #pragma _CRI duplicate _UNIT_ as $UNIT 00082 #ifdef _CRAYMPP 00083 #pragma _CRI duplicate _UNIT_ as _UNIT 00084 #endif 00085 #endif /* _UNICOS */ 00086 00087 _f_real 00088 _UNIT_(_f_int *unump) 00089 { 00090 register unum_t unum; 00091 long s2ret; /* value to be returned in S2 */ 00092 _f_real status; 00093 unit *cup; 00094 struct fiostate cfs; 00095 00096 s2ret = 0; 00097 unum = *unump; 00098 00099 STMT_BEGIN(unum, 0, T_UNIT, NULL, &cfs, cup); /* lock the unit */ 00100 /* 00101 * If not connected, do an implicit open. Abort if the open fails. 00102 */ 00103 if (cup == NULL) 00104 cup = _imp_open(&cfs, SEQ, UNF, unum, 0, NULL); 00105 00106 if (cup->ufs == FS_AUX) 00107 _ferr(&cfs, FEMIXAUX); 00108 00109 /* 00110 * According to the file structure make the appropriate call 00111 * to check file status. File status routines are file 00112 * structure dependent. 00113 */ 00114 cup->unitchk = 1; /* indicate that UNIT has now been called */ 00115 00116 WAITIO(cup, {}); 00117 00118 if (cup->uerr) { 00119 status = UNIT_ERROR; 00120 /* 00121 * This undocumented behavior of returning the error number 00122 * in S2 is preserved for now. 00123 */ 00124 s2ret = cup->uffsw.sw_error; 00125 goto done; 00126 } 00127 else if (!cup->uwrt && cup->uend) { 00128 status = UNIT_EOF; 00129 goto done; 00130 } 00131 else if (cup->ufs == FS_FDC && FFSTAT(cup->uffsw) == FFCNT && 00132 (cup->uflagword & FFC_REC) && !cup->uwrt && 00133 cup->urecmode == PARTIAL) { 00134 00135 status = UNIT_PDONE; 00136 goto done; 00137 } 00138 status = UNIT_DONE; 00139 00140 done: 00141 STMT_END(cup, T_UNIT, NULL, &cfs); /* unlock the unit */ 00142 00143 #ifdef _CRAY1 00144 (void) _sets2(s2ret); 00145 #endif 00146 00147 return( (_f_real) status); 00148 }