|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
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/fcontext.c 92.1 06/18/99 16:08:47" 00039 00040 #include <ctype.h> 00041 #include <errno.h> 00042 #include <stdio.h> 00043 #include <stdlib.h> 00044 #include <string.h> 00045 #include "fio.h" 00046 00047 #define MAX_ENT_LEN 32 /* Maximum entry point name length */ 00048 00049 extern int _who_called_me(); 00050 00051 /* 00052 * _fcontext - Print the context of a Fortran library run-time error. 00053 * based on the following global flags: 00054 * 00055 * f_iostmt Identifies the type of I/O statement, NULL 00056 * if none. 00057 * f_curun Identifies the unit number being operated on, 00058 * -1 if none defined. 00059 * f_cu Identifies current unit, if this is NULL, an 00060 * unconnected unit (possibly an invalid unit 00061 * number) is assumed. 00062 * f_intflg Identifies an internal file, 1 if internal. 00063 * 00064 */ 00065 00066 void 00067 _fcontext(FIOSPTR css) 00068 { 00069 register short is_int; /* 1 if internal file I/O */ 00070 register int utindex; 00071 char *file, *fstruct, *idir, *oprn, *sepr; 00072 register unum_t unum; /* Fortran unit number */ 00073 long stmt; /* I/O statement type */ 00074 unit *cup; /* Pointer to unit table entry */ 00075 00076 /* Just return if no Fortran statement info is available */ 00077 00078 if (css == NULL) 00079 return; 00080 00081 /* Retrieve global data */ 00082 00083 cup = css->f_cu; 00084 unum = css->f_curun; 00085 stmt = css->f_iostmt; 00086 is_int = css->f_intflg; 00087 00088 file = (!OPEN_UPTR(cup) || cup->alfnm == NULL) ? NULL : cup->alfnm; 00089 00090 if (stmt & TF_READ) 00091 idir = " READ from"; 00092 else 00093 if (stmt & TF_WRITE) 00094 idir = " WRITE to"; 00095 else 00096 idir = ""; 00097 00098 /* Determine the type of error */ 00099 00100 switch (stmt) { 00101 00102 case T_RSF: /* Sequential formatted READ */ 00103 case T_WSF: /* Sequential formatted WRITE */ 00104 oprn = " sequential formatted"; 00105 break; 00106 00107 case T_RSU: /* Sequential unformatted READ */ 00108 case T_WSU: /* Sequential unformatted WRITE */ 00109 oprn = " sequential unformatted"; 00110 break; 00111 00112 case T_RDF: /* Direct formatted READ */ 00113 case T_WDF: /* Direct formatted WRITE */ 00114 oprn = " direct access formatted"; 00115 break; 00116 00117 case T_RDU: /* Direct unformatted READ */ 00118 case T_WDU: /* Direct unformatted WRITE */ 00119 oprn = " direct access unformatted"; 00120 break; 00121 00122 case T_RLIST: /* List-directed READ */ 00123 case T_WLIST: /* List-directed WRITE */ 00124 oprn = " list-directed"; 00125 break; 00126 00127 case T_RNL: /* Namelist READ */ 00128 case T_WNL: /* Namelist WRITE */ 00129 oprn = " namelist"; 00130 break; 00131 00132 case T_BUFOUT: /* BUFFER OUT */ 00133 oprn = " BUFFER OUT on"; 00134 idir = ""; 00135 break; 00136 00137 case T_BUFIN: /* BUFFER IN */ 00138 oprn = " BUFFER IN from"; 00139 idir = ""; 00140 break; 00141 00142 case T_OPEN: /* OPEN */ 00143 oprn = "n OPEN of"; 00144 idir = ""; 00145 break; 00146 00147 case T_REWIND: /* REWIND */ 00148 oprn = " REWIND on"; 00149 idir = ""; 00150 break; 00151 00152 case T_BACKSPACE:/* BACKSPACE */ 00153 oprn = " BACKSPACE on"; 00154 idir = ""; 00155 break; 00156 00157 case T_ENDFILE: /* ENDFILE */ 00158 oprn = "n ENDFILE on"; 00159 idir = ""; 00160 break; 00161 00162 case T_CLOSE: /* CLOSE */ 00163 oprn = " CLOSE of"; 00164 idir = ""; 00165 break; 00166 00167 case T_INQF: /* INQUIRE */ 00168 oprn = "n INQUIRE by file on"; 00169 unum = -1; 00170 idir = ""; 00171 break; 00172 00173 case T_INQU: /* INQUIRE */ 00174 oprn = "n INQUIRE by unit on"; 00175 idir = ""; 00176 break; 00177 00178 case T_GETPOS: /* GETPOS */ 00179 oprn = " GETPOS on"; 00180 idir = ""; 00181 break; 00182 00183 case T_SETPOS: /* SETPOS */ 00184 oprn = " SETPOS on"; 00185 idir = ""; 00186 break; 00187 00188 case T_LENGTH: /* LENGTH */ 00189 oprn = " LENGTH function on"; 00190 idir = ""; 00191 break; 00192 00193 case T_UNIT: /* UNIT */ 00194 oprn = " UNIT function on"; 00195 idir = ""; 00196 break; 00197 00198 case T_TAPE: /* TAPE */ 00199 oprn = " tape operation on"; 00200 idir = ""; 00201 break; 00202 00203 default: 00204 oprn = "n I/O operation on"; 00205 break; 00206 00207 } /* switch */ 00208 00209 (void) fprintf(errfile, "\nEncountered during a%s%s", oprn, idir); 00210 00211 if (is_int) 00212 (void) fprintf(errfile, 00213 " an internal file (character variable)\n"); 00214 else { 00215 if (unum != -1) { 00216 (void) fprintf(errfile, " unit %lld\n", unum); 00217 00218 (void) fprintf(errfile, "Fortran unit %lld is ", 00219 unum); 00220 00221 if (!OPEN_UPTR(cup)) { 00222 if (GOOD_UNUM(unum)) 00223 (void) fprintf(errfile, 00224 "not connected\n"); 00225 else 00226 (void) fprintf(errfile, 00227 "not a valid unit number\n"); 00228 } 00229 else { 00230 (void) fprintf(errfile, "connected to "); 00231 00232 utindex = IO_TYPE(cup); 00233 fstruct = FIO_STRUCT(_deduce_fstruct( 00234 cup->ufs, 00235 (struct fdinfo*)cup->ufp.fdc, 00236 cup->ufmt)); 00237 00238 if (fstruct == NULL) 00239 fstruct = ""; 00240 00241 (void) fprintf(errfile, "a %s %s file", 00242 FIO_METHOD(utindex), fstruct); 00243 00244 if (file == NULL && cup->ufs != FS_FDC) { 00245 if (cup->ufp.std == stdin) 00246 file = "standard input"; 00247 else if (cup->ufp.std == stdout) 00248 file = "standard output"; 00249 else if (cup->ufp.std == stderr) 00250 file = "standard error"; 00251 else 00252 file = "unnamed"; 00253 00254 (void) fprintf(errfile, 00255 "\n (%s).\n", file); 00256 } 00257 else { /* Format to under 80 chars. per line */ 00258 if ((int)strlen(file) > 8) 00259 sepr = ":\n "; 00260 else 00261 sepr = ": "; 00262 00263 (void) fprintf(errfile, "%s\"%s\"\n", 00264 sepr, file); 00265 } 00266 00267 /* 00268 * If the connection is formatted and there's 00269 * a format, print the format and point to 00270 * the current position therein. 00271 */ 00272 00273 if ((stmt & TF_FMT) && 00274 css->u.fmt.u.fe.fmtbuf != NULL) { 00275 00276 int i, offset; 00277 00278 offset = css->u.fmt.u.fe.fmtcol - 2 + 00279 fprintf(errfile, 00280 " Current format: "); 00281 00282 if (css->u.fmt.u.fe.fmtnum > 0) 00283 /* If format label, print it */ 00284 offset = offset + 00285 fprintf(errfile, 00286 "%5d FORMAT", 00287 css->u.fmt.u.fe.fmtnum); 00288 00289 (void) fprintf(errfile, "%.*s\n", 00290 css->u.fmt.u.fe.fmtlen, 00291 css->u.fmt.u.fe.fmtbuf); 00292 00293 for (i = 0; i <= offset; i++) 00294 (void) fprintf(errfile, " "); 00295 00296 (void) fprintf(errfile, "^\n"); 00297 } 00298 } 00299 } 00300 else /* Unknown state */ 00301 if (file == NULL) 00302 (void) fprintf(errfile, 00303 " an indeterminate file\n"); 00304 else 00305 (void) fprintf(errfile, " file \"%s\"\n", file); 00306 } 00307 00308 /* 00309 * Print name of the routine which called _ferr() which called us. 00310 */ 00311 00312 #ifdef _UNICOS 00313 { 00314 int len, lineno; 00315 char name[MAX_ENT_LEN]; 00316 00317 len = _who_called_me(&lineno, name, MAX_ENT_LEN, 2); 00318 00319 if (len > 0) { /* If no error */ 00320 00321 name[len] = '\0'; 00322 00323 (void) fprintf(errfile, 00324 "Error initiated at line %d in routine '%s'.\n", 00325 lineno, name); 00326 } 00327 } 00328 #endif 00329 00330 #ifdef _CRAY2 00331 /* 00332 * Print traceback 00333 * 00334 * On CX/CEA systems, the traceback is printed by the abort() call. 00335 */ 00336 00337 (void) _tracebk(25, errfile); 00338 #endif 00339 00340 return; 00341 }
1.7.6.1 
