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/read.c 92.2 06/21/99 10:37:55" 00039 00040 /* 00041 * read words 00042 */ 00043 00044 #include <errno.h> 00045 #include <foreign.h> 00046 #include <fortran.h> 00047 #include <liberrno.h> 00048 #include <cray/dopevec.h> 00049 #include "fio.h" 00050 00051 #define ret_err(errnum) { \ 00052 *words = 0; \ 00053 *status = errnum; \ 00054 goto done; \ 00055 } 00056 00057 #define UBC 5 /* argument number for optional ubc parameter */ 00058 00059 static void __READ(); 00060 00061 #undef READ 00062 00063 /* 00064 * Read cray words, partial record mode 00065 */ 00066 void 00067 READP( 00068 _f_int *unump, 00069 _f_int *uda, 00070 _f_int *words, 00071 _f_int *status, 00072 _f_int *ubc) 00073 { 00074 _f_int locubc, *ubcp; 00075 00076 if (_numargs() < UBC) { 00077 locubc = 0; 00078 ubcp = &locubc; 00079 } 00080 else 00081 ubcp = ubc; 00082 00083 00084 __READ(PARTIAL, unump, uda, words, status, ubcp); 00085 } 00086 00087 /* 00088 * Read cray words, full record mode 00089 */ 00090 _f_int 00091 READ( 00092 _f_int *unump, 00093 _f_int *uda, 00094 _f_int *words, 00095 _f_int *status, 00096 _f_int *ubc) 00097 { 00098 _f_int locubc, *ubcp; 00099 00100 if (_numargs() < UBC) { 00101 locubc = 0; 00102 ubcp = &locubc; 00103 } 00104 else 00105 ubcp = ubc; 00106 00107 __READ(FULL, unump, uda, words, status, ubcp); 00108 00109 return(0); 00110 } 00111 00112 /* 00113 * Read words, full or partial record mode 00114 * 00115 * The READ/READP interface does not advance past logical endfile 00116 * records. 00117 */ 00118 static void 00119 __READ( 00120 int fulp, 00121 _f_int *unump, 00122 _f_int *uda, 00123 _f_int *words, 00124 _f_int *status, 00125 _f_int *ubc) 00126 { 00127 register int ret; 00128 int rstat; 00129 int wubc; 00130 long wr; 00131 register unum_t unum; 00132 unit *cup; 00133 type_packet tip; 00134 struct fiostate cfs; 00135 00136 unum = *unump; 00137 wubc = *ubc; 00138 00139 STMT_BEGIN(unum, 0, T_RSU, NULL, &cfs, cup); 00140 /* 00141 * If not connected, do an implicit open. 00142 */ 00143 if (cup == NULL) { 00144 int ostat; 00145 00146 cup = _imp_open(&cfs, SEQ, UNF, unum, 1, &ostat); 00147 00148 if (cup == NULL) 00149 ret_err(ostat); 00150 } 00151 00152 if (!cup->ok_rd_seq_unf) { 00153 ret = _get_mismatch_error(1, T_RSU, cup, &cfs); 00154 ret_err(ret); 00155 } 00156 00157 cup->uwrt = 0; 00158 wr = 0; 00159 tip.type90 = DVTYPE_TYPELESS; 00160 tip.type77 = -1; 00161 tip.intlen = sizeof(long) << 3; 00162 tip.extlen = tip.intlen; 00163 tip.elsize = sizeof(long); 00164 tip.cnvindx = 0; 00165 tip.count = *words; 00166 tip.stride = 1; 00167 00168 ret = _frwd(cup, uda, &tip, fulp, &wubc, &wr, &rstat); 00169 00170 if ( ret == IOERR ) { 00171 if ( errno == FETAPUTE ) { 00172 *words = wr; 00173 *status = 4; 00174 } 00175 else if (errno >= 5) { 00176 *words = 0; 00177 *status = errno; 00178 } 00179 else { 00180 *words = 0; 00181 /* Map system errnos 1-4 to */ 00182 /* library errno. Otherwise, we would */ 00183 /* lose them. */ 00184 switch (errno) { 00185 case 1: 00186 *status = FEKLUDG1; 00187 break; 00188 case 2: 00189 *status = FEKLUDG2; 00190 break; 00191 case 3: 00192 *status = FEKLUDG3; 00193 break; 00194 case 4: 00195 *status = FEKLUDG4; 00196 break; 00197 } 00198 } 00199 } 00200 else { 00201 if ( rstat == EOR ) { 00202 cup->uend = BEFORE_ENDFILE; 00203 *status = 0; /* EOR */ 00204 *words = ret; 00205 00206 if ( ret == 0 ) 00207 *status = 1; /* NULL record */ 00208 } 00209 else if ( rstat == CNT ) { 00210 cup->uend = BEFORE_ENDFILE; 00211 *status = -1; /* WORDS REMAIN in record */ 00212 *words = ret; 00213 } 00214 else if ( rstat == EOD) { 00215 *status = 3; /* EOD */ 00216 *words = 0; 00217 /* If the user assigned -s tape, return 2 instead of 3*/ 00218 if (cup->ubmx) 00219 *status = 2; 00220 } 00221 else { /* rstat == EOF */ 00222 cup->uend = PHYSICAL_ENDFILE; 00223 *status = 2; /* EOF */ 00224 *words = 0; 00225 } 00226 } 00227 00228 done: 00229 *ubc = wubc; 00230 00231 STMT_END(cup, TF_READ, NULL, &cfs); 00232 00233 return; 00234 }