1 files changed, 298 insertions, 0 deletions
diff --git a/gcc/f/runtime/libI77/err.c b/gcc/f/runtime/libI77/err.c
new file mode 100644
index 00000000000..1d0188737be
--- /dev/null
+++ b/gcc/f/runtime/libI77/err.c
@@ -0,0 +1,298 @@
+#ifndef NON_UNIX_STDIO
+#include <sys/types.h>
+#include <sys/stat.h>
+#endif
+#include "f2c.h"
+#if defined (NON_UNIX_STDIO) || defined (MISSING_FILE_ELEMS)
+#ifdef KR_headers
+extern char *malloc();
+#else
+#undef abs
+#undef min
+#undef max
+#include <stdlib.h>
+#endif
+#endif
+#include "fio.h"
+#include "fmt.h"	/* for struct syl */
+#include "rawio.h"	/* for fcntl.h, fdopen */
+
+/*global definitions*/
+unit f__units[MXUNIT];	/*unit table*/
+int f__init;	/*bit 0: set after initializations;
+		  bit 1: set during I/O involving returns to
+		    caller of library (or calls to user code)*/
+cilist *f__elist;	/*active external io list*/
+icilist *f__svic;	/*active internal io list*/
+flag f__reading;	/*1 if reading, 0 if writing*/
+flag f__cplus,f__cblank;
+char *f__fmtbuf;
+flag f__external;	/*1 if external io, 0 if internal */
+#ifdef KR_headers
+int (*f__doed)(),(*f__doned)();
+int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)();
+int (*f__getn)(),(*f__putn)();	/*for formatted io*/
+#else
+int (*f__getn)(void),(*f__putn)(int);	/*for formatted io*/
+int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*);
+int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void);
+#endif
+flag f__sequential;	/*1 if sequential io, 0 if direct*/
+flag f__formatted;	/*1 if formatted io, 0 if unformatted*/
+FILE *f__cf;	/*current file*/
+unit *f__curunit;	/*current unit*/
+int f__recpos;	/*place in current record*/
+int f__cursor, f__hiwater, f__scale;
+char *f__icptr;
+
+/*error messages*/
+char *F_err[] =
+{
+	"error in format",				/* 100 */
+	"illegal unit number",				/* 101 */
+	"formatted io not allowed",			/* 102 */
+	"unformatted io not allowed",			/* 103 */
+	"direct io not allowed",			/* 104 */
+	"sequential io not allowed",			/* 105 */
+	"can't backspace file",				/* 106 */
+	"null file name",				/* 107 */
+	"can't stat file",				/* 108 */
+	"unit not connected",				/* 109 */
+	"off end of record",				/* 110 */
+	"truncation failed in endfile",			/* 111 */
+	"incomprehensible list input",			/* 112 */
+	"out of free space",				/* 113 */
+	"unit not connected",				/* 114 */
+	"read unexpected character",			/* 115 */
+	"bad logical input field",			/* 116 */
+	"bad variable type",				/* 117 */
+	"bad namelist name",				/* 118 */
+	"variable not in namelist",			/* 119 */
+	"no end record",				/* 120 */
+	"variable count incorrect",			/* 121 */
+	"subscript for scalar variable",		/* 122 */
+	"invalid array section",			/* 123 */
+	"substring out of bounds",			/* 124 */
+	"subscript out of bounds",			/* 125 */
+	"can't read file",				/* 126 */
+	"can't write file",				/* 127 */
+	"'new' file exists",				/* 128 */
+	"can't append to file",				/* 129 */
+	"non-positive record number",			/* 130 */
+	"I/O started while already doing I/O"		/* 131 */
+};
+#define MAXERR (sizeof(F_err)/sizeof(char *)+100)
+
+#ifdef KR_headers
+f__canseek(f) FILE *f; /*SYSDEP*/
+#else
+f__canseek(FILE *f) /*SYSDEP*/
+#endif
+{
+#ifdef NON_UNIX_STDIO
+	return !isatty(fileno(f));
+#else
+	struct stat x;
+
+	if (fstat(fileno(f),&x) < 0)
+		return(0);
+#ifdef S_IFMT
+	switch(x.st_mode & S_IFMT) {
+	case S_IFDIR:
+	case S_IFREG:
+		if(x.st_nlink > 0)	/* !pipe */
+			return(1);
+		else
+			return(0);
+	case S_IFCHR:
+		if(isatty(fileno(f)))
+			return(0);
+		return(1);
+#ifdef S_IFBLK
+	case S_IFBLK:
+		return(1);
+#endif
+	}
+#else
+#ifdef S_ISDIR
+	/* POSIX version */
+	if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) {
+		if(x.st_nlink > 0)	/* !pipe */
+			return(1);
+		else
+			return(0);
+		}
+	if (S_ISCHR(x.st_mode)) {
+		if(isatty(fileno(f)))
+			return(0);
+		return(1);
+		}
+	if (S_ISBLK(x.st_mode))
+		return(1);
+#else
+	Help! How does fstat work on this system?
+#endif
+#endif
+	return(0);	/* who knows what it is? */
+#endif
+}
+
+ void
+#ifdef KR_headers
+f__fatal(n,s) char *s;
+#else
+f__fatal(int n, char *s)
+#endif
+{
+	static int dead = 0;
+
+	if(n<100 && n>=0) perror(s); /*SYSDEP*/
+	else if(n >= (int)MAXERR || n < -1)
+	{	fprintf(stderr,"%s: illegal error number %d\n",s,n);
+	}
+	else if(n == -1) fprintf(stderr,"%s: end of file\n",s);
+	else
+		fprintf(stderr,"%s: %s\n",s,F_err[n-100]);
+	if (dead) {
+		fprintf (stderr, "(libf2c f__fatal already called, aborting.)");
+		abort();
+	}
+	dead = 1;
+	if (f__init & 1) {
+		if (f__curunit) {
+			fprintf(stderr,"apparent state: unit %d ",f__curunit-f__units);
+			fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n",
+				f__curunit->ufnm);
+			}
+		else
+			fprintf(stderr,"apparent state: internal I/O\n");
+		if (f__fmtbuf)
+			fprintf(stderr,"last format: %s\n",f__fmtbuf);
+		fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing",
+			f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted",
+			f__external?"external":"internal");
+	}
+	f__init &= ~2;	/* No longer doing I/O (no more user code to be called). */
+	sig_die(" IO", 1);
+}
+/*initialization routine*/
+ VOID
+f_init(Void)
+{	unit *p;
+
+	if (f__init & 2)
+		f__fatal (131, "I/O recursion");
+	f__init = 1;
+	p= &f__units[0];
+	p->ufd=stderr;
+	p->useek=f__canseek(stderr);
+#ifdef _IOLBF
+	setvbuf(stderr, (char*)malloc(BUFSIZ+8), _IOLBF, BUFSIZ+8);
+#else
+#if defined (NON_UNIX_STDIO) || defined (MISSING_FILE_ELEMS)
+	setbuf(stderr, (char *)malloc(BUFSIZ+8));
+#else
+	stderr->_flag &= ~_IONBF;
+#endif
+#endif
+	p->ufmt=1;
+	p->uwrt=1;
+	p = &f__units[5];
+	p->ufd=stdin;
+	p->useek=f__canseek(stdin);
+	p->ufmt=1;
+	p->uwrt=0;
+	p= &f__units[6];
+	p->ufd=stdout;
+	p->useek=f__canseek(stdout);
+	p->ufmt=1;
+	p->uwrt=1;
+}
+#ifdef KR_headers
+f__nowreading(x) unit *x;
+#else
+f__nowreading(unit *x)
+#endif
+{
+	long loc;
+	int ufmt;
+	extern char *f__r_mode[];
+
+	if (!x->ufnm)
+		goto cantread;
+	ufmt = x->ufmt;
+	loc=ftell(x->ufd);
+	if(freopen(x->ufnm,f__r_mode[ufmt],x->ufd) == NULL) {
+ cantread:
+		errno = 126;
+		return(1);
+		}
+	x->uwrt=0;
+	(void) fseek(x->ufd,loc,SEEK_SET);
+	return(0);
+}
+#ifdef KR_headers
+f__nowwriting(x) unit *x;
+#else
+f__nowwriting(unit *x)
+#endif
+{
+	long loc;
+	int ufmt;
+	extern char *f__w_mode[];
+#ifndef NON_UNIX_STDIO
+	int k;
+#endif
+
+	if (!x->ufnm)
+		goto cantwrite;
+	ufmt = x->ufmt;
+#ifdef NON_UNIX_STDIO
+	ufmt |= 2;
+#endif
+	if (x->uwrt == 3) { /* just did write, rewind */
+#ifdef NON_UNIX_STDIO
+		if (!(f__cf = x->ufd =
+				freopen(x->ufnm,f__w_mode[ufmt],x->ufd)))
+#else
+		if (close(creat(x->ufnm,0666)))
+#endif
+			goto cantwrite;
+		}
+	else {
+		loc=ftell(x->ufd);
+#ifdef NON_UNIX_STDIO
+		if (!(f__cf = x->ufd =
+			freopen(x->ufnm, f__w_mode[ufmt], x->ufd)))
+#else
+		if (fclose(x->ufd) < 0
+		|| (k = x->uwrt == 2 ? creat(x->ufnm,0666)
+				     : open(x->ufnm,O_WRONLY)) < 0
+		|| (f__cf = x->ufd = fdopen(k,f__w_mode[ufmt])) == NULL)
+#endif
+			{
+			x->ufd = NULL;
+ cantwrite:
+			errno = 127;
+			return(1);
+			}
+		(void) fseek(x->ufd,loc,SEEK_SET);
+		}
+	x->uwrt = 1;
+	return(0);
+}
+
+ int
+#ifdef KR_headers
+err__fl(f, m, s) int f, m; char *s;
+#else
+err__fl(int f, int m, char *s)
+#endif
+{
+	if (!f)
+		f__fatal(m, s);
+	if (f__doend)
+		(*f__doend)();
+	f__init &= ~2;
+	return errno = m;
+	}