lang/fortran/lib/libI77/err.c

   1 #include "sys/types.h"
   2 #ifndef MSDOS
   3 #include "sys/stat.h"
   4 #endif
   5 #include "f2c.h"
   6 #include "fio.h"
   7 #include "fcntl.h"
   8 #ifndef O_WRONLY
   9 #define O_WRONLY 1
  10 #endif
  11
  12 extern FILE *fdopen();
  13
  14 /*global definitions*/
  15 unit units[MXUNIT];     /*unit table*/
  16 flag init;      /*0 on entry, 1 after initializations*/
  17 cilist *elist;  /*active external io list*/
  18 flag reading;   /*1 if reading, 0 if writing*/
  19 flag cplus,cblank;
  20 char *fmtbuf;
  21 flag external;  /*1 if external io, 0 if internal */
  22 int (*doed)(),(*doned)();
  23 int (*doend)(),(*donewrec)(),(*dorevert)();
  24 flag sequential;        /*1 if sequential io, 0 if direct*/
  25 flag formatted; /*1 if formatted io, 0 if unformatted*/
  26 int (*getn)(),(*putn)();        /*for formatted io*/
  27 FILE *cf;       /*current file*/
  28 unit *curunit;  /*current unit*/
  29 int recpos;     /*place in current record*/
  30 int cursor,scale;
  31
  32 /*error messages*/
  33 char *F_err[] =
  34 {
  35         "error in format",                              /* 100 */
  36         "illegal unit number",                          /* 101 */
  37         "formatted io not allowed",                     /* 102 */
  38         "unformatted io not allowed",                   /* 103 */
  39         "direct io not allowed",                        /* 104 */
  40         "sequential io not allowed",                    /* 105 */
  41         "can't backspace file",                         /* 106 */
  42         "null file name",                               /* 107 */
  43         "can't stat file",                              /* 108 */
  44         "unit not connected",                           /* 109 */
  45         "off end of record",                            /* 110 */
  46         "truncation failed in endfile",                 /* 111 */
  47         "incomprehensible list input",                  /* 112 */
  48         "out of free space",                            /* 113 */
  49         "unit not connected",                           /* 114 */
  50         "read unexpected character",                    /* 115 */
  51         "bad logical input field",                      /* 116 */
  52         "bad variable type",                            /* 117 */
  53         "bad namelist name",                            /* 118 */
  54         "variable not in namelist",                     /* 119 */
  55         "no end record",                                /* 120 */
  56         "variable count incorrect",                     /* 121 */
  57         "subscript for scalar variable",                /* 122 */
  58         "invalid array section",                        /* 123 */
  59         "substring out of bounds",                      /* 124 */
  60         "subscript out of bounds",                      /* 125 */
  61         "can't read file",                              /* 126 */
  62         "can't write file",                             /* 127 */
  63         "'new' file exists"                             /* 128 */
  64 };
  65 #define MAXERR (sizeof(F_err)/sizeof(char *)+100)
  66 fatal(n,s) char *s;
  67 {
  68         if(n<100 && n>=0) perror(s); /*SYSDEP*/
  69         else if(n >= (int)MAXERR || n < -1)
  70         {       fprintf(stderr,"%s: illegal error number %d\n",s,n);
  71         }
  72         else if(n == -1) fprintf(stderr,"%s: end of file\n",s);
  73         else
  74                 fprintf(stderr,"%s: %s\n",s,F_err[n-100]);
  75         if (curunit) {
  76                 fprintf(stderr,"apparent state: unit %d ",curunit-units);
  77                 fprintf(stderr, curunit->ufnm ? "named %s\n" : "(unnamed)\n",
  78                         curunit->ufnm);
  79                 }
  80         else
  81                 fprintf(stderr,"apparent state: internal I/O\n");
  82         if (fmtbuf)
  83                 fprintf(stderr,"last format: %s\n",fmtbuf);
  84         fprintf(stderr,"lately %s %s %s %s",reading?"reading":"writing",
  85                 sequential?"sequential":"direct",formatted?"formatted":"unformatted",
  86                 external?"external":"internal");
  87         sig_die(" IO", 1);
  88 }
  89 /*initialization routine*/
  90 f_init()
  91 {       unit *p;
  92
  93         init=1;
  94         p= &units[0];
  95         p->ufd=stderr;
  96         p->useek=canseek(stderr);
  97 #ifdef COMMENTED_OUT
  98         if(isatty(fileno(stderr))) {
  99                 extern char *malloc();
 100                 setbuf(stderr, malloc(BUFSIZ));
 101                 /* setvbuf(stderr, _IOLBF, 0, 0); */
 102         }       /* wastes space, but win for debugging in windows */
 103 #endif
 104 #ifdef NON_UNIX_STDIO
 105         {extern char *malloc(); setbuf(stderr, malloc(BUFSIZ));}
 106 #else
 107         stderr->_flag &= ~_IONBF;
 108 #endif
 109         p->ufmt=1;
 110         p->uwrt=1;
 111         p = &units[5];
 112         p->ufd=stdin;
 113         p->useek=canseek(stdin);
 114         p->ufmt=1;
 115         p->uwrt=0;
 116         p= &units[6];
 117         p->ufd=stdout;
 118         p->useek=canseek(stdout);
 119         /* IOLBUF and setvbuf only in system 5+ */
 120 #ifdef COMMENTED_OUT
 121         if(isatty(fileno(stdout))) {
 122                 extern char _sobuf[];
 123                 setbuf(stdout, _sobuf);
 124                 /* setvbuf(stdout, _IOLBF, 0, 0);       /* the buf arg in setvbuf? */
 125                 p->useek = 1;   /* only within a record no bigger than BUFSIZ */
 126         }
 127 #endif
 128         p->ufmt=1;
 129         p->uwrt=1;
 130 }
 131 canseek(f) FILE *f; /*SYSDEP*/
 132 {
 133 #ifdef MSDOS
 134         return !isatty(fileno(f));
 135 #else
 136         struct stat x;
 137
 138         if (fstat(fileno(f),&x) < 0)
 139                 return(0);
 140 #ifdef S_IFMT
 141         switch(x.st_mode & S_IFMT) {
 142         case S_IFDIR:
 143         case S_IFREG:
 144                 if(x.st_nlink > 0)      /* !pipe */
 145                         return(1);
 146                 else
 147                         return(0);
 148         case S_IFCHR:
 149                 if(isatty(fileno(f)))
 150                         return(0);
 151                 return(1);
 152 #ifdef S_IFBLK
 153         case S_IFBLK:
 154                 return(1);
 155 #endif
 156         }
 157 #else
 158 #ifdef S_ISDIR
 159         /* POSIX version */
 160         if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) {
 161                 if(x.st_nlink > 0)      /* !pipe */
 162                         return(1);
 163                 else
 164                         return(0);
 165                 }
 166         if (S_ISCHR(x.st_mode)) {
 167                 if(isatty(fileno(f)))
 168                         return(0);
 169                 return(1);
 170                 }
 171         if (S_ISBLK(x.st_mode))
 172                 return(1);
 173 #else
 174         Help! How does fstat work on this system?
 175 #endif
 176 #endif
 177         return(0);      /* who knows what it is? */
 178 #endif
 179 }
 180 nowreading(x) unit *x;
 181 {
 182         long loc;
 183         extern char *r_mode[];
 184         if (!x->ufnm)
 185                 goto cantread;
 186         loc=ftell(x->ufd);
 187         if(freopen(x->ufnm,r_mode[x->ufmt],x->ufd) == NULL) {
 188  cantread:
 189                 errno = 126;
 190                 return(1);
 191                 }
 192         x->uwrt=0;
 193         (void) fseek(x->ufd,loc,SEEK_SET);
 194         return(0);
 195 }
 196 nowwriting(x) unit *x;
 197 {
 198         long loc;
 199         int k;
 200         extern char *w_mode[];
 201
 202         if (!x->ufnm)
 203                 goto cantwrite;
 204         if (x->uwrt == 3) { /* just did write, rewind */
 205                 if (close(creat(x->ufnm,0666)))
 206                         goto cantwrite;
 207                 }
 208         else {
 209                 loc=ftell(x->ufd);
 210                 if (fclose(x->ufd) < 0
 211                 || (k = x->uwrt == 2 ? creat(x->ufnm,0666)
 212                                      : open(x->ufnm,O_WRONLY)) < 0
 213                 || (cf = x->ufd = fdopen(k,w_mode[x->ufmt])) == NULL) {
 214                         x->ufd = NULL;
 215  cantwrite:
 216                         errno = 127;
 217                         return(1);
 218                         }
 219                 (void) fseek(x->ufd,loc,SEEK_SET);
 220                 }
 221         x->uwrt = 1;
 222         return(0);
 223 }