BSD 4 development

Work on file usr/src/lib/libI77uc/READ_ME
Work on file usr/src/lib/libI77uc/Makefile
Work on file usr/src/lib/libI77uc/NEWS
Work on file usr/src/lib/libI77uc/backspace.c
Work on file usr/src/lib/libI77uc/dfe.c
Work on file usr/src/lib/libI77uc/close.c
Work on file usr/src/lib/libI77uc/dballoc.c
Work on file usr/src/lib/libI77uc/douio.c
Work on file usr/src/lib/libI77uc/dofio.c
Work on file usr/src/lib/libI77uc/dolio.c
Work on file usr/src/lib/libI77uc/due.c
Work on file usr/src/lib/libI77uc/endfile.c
Work on file usr/src/lib/libI77uc/fiodefs.h
Work on file usr/src/lib/libI77uc/err.c
Work on file usr/src/lib/libI77uc/fio.h
Work on file usr/src/lib/libI77uc/fmt.h
Work on file usr/src/lib/libI77uc/fmtlib.c
Work on file usr/src/lib/libI77uc/fmt.c
Work on file usr/src/lib/libI77uc/inquire.c
Work on file usr/src/lib/libI77uc/iio.c
Work on file usr/src/lib/libI77uc/lio.h
Work on file usr/src/lib/libI77uc/io.c
Work on file usr/src/lib/libI77uc/lwrite.c
Work on file usr/src/lib/libI77uc/rdfmt.c
Work on file usr/src/lib/libI77uc/rewind.c
Work on file usr/src/lib/libI77uc/open.c
Work on file usr/src/lib/libI77uc/sue.c
Work on file usr/src/lib/libI77uc/sfe.c
Work on file usr/src/lib/libI77uc/util.c
Work on file usr/src/lib/libI77uc/writeup.tx

Synthesized-from: CSRG//cd1/4.0

diff --git a/usr/src/lib/libI77uc/Makefile b/usr/src/lib/libI77uc/Makefile
new file mode 100644 (file)
index 0000000..4fffb14
--- /dev/null
+++ b/usr/src/lib/libI77uc/Makefile
@@ -0,0 +1,88 @@
+# Makefile for the f77 I/O library
+# Originally written by P. Weinberger, Bell Labs, Murray Hill, N.J.
+# Modified by D. Wasley, Univ of California, Berkeley, Calif.
+
+DESTDIR =
+
+CFLAGS = -O
+
+SOURCES = backspace.c close.c dballoc.c dfe.c due.c endfile.c err.c fmt.c \
+       fmtlib.c iio.c inquire.c lwrite.c lread.c dolio.c open.c \
+       rdfmt.c rewind.c sfe.c sue.c douio.c util.c wrtfmt.c \
+       dofio.c fiodefs.h fio.h fmt.h lio.h
+
+OBJECTS = dfe.o due.o iio.o sue.o sfe.o lread.o lwrite.o \
+       dofio.o douio.o dolio.o \
+       rdfmt.o wrtfmt.o fmt.o fmtlib.o \
+       backspace.o rewind.o open.o close.o endfile.o inquire.o \
+       dballoc.o err.o util.o
+
+libI77.a:      $(OBJECTS)
+       @echo Loading
+       @rm -f libI77.a
+       @ar rc libI77.a $(OBJECTS)
+       @chmod 664 libI77.a
+       @echo "Done\a\a\a"
+
+install:
+       install -c libI77.a $(DESTDIR)/usr/lib/libI77uc.a
+       ranlib $(DESTDIR)/usr/lib/libI77uc.a
+
+backspace.o:   fio.h backspace.c
+dfe.o:         fio.h dfe.c
+due.o:         fio.h due.c
+iio.o:         fio.h lio.h iio.c
+inquire.o:     fio.h inquire.c
+rewind.o:      fio.h rewind.c
+rdfmt.o:       fio.h fmt.h rdfmt.c
+sue.o:         fio.h sue.c
+douio.o:       fio.h douio.c
+sfe.o:         fio.h sfe.c
+fmt.o:         fio.h fmt.h fmt.c
+dofio.o:       fio.h fmt.h dofio.c
+lwrite.o:      fio.h lio.h lwrite.c
+lread.o:       fio.h lio.h lread.c
+dolio.o:       fio.h lio.h dolio.c
+open.o:                fio.h open.c
+close.o:       fio.h close.c
+util.o:                fio.h util.c
+endfile.o:     fio.h endfile.c
+wrtfmt.o:      fio.h fmt.h wrtfmt.c
+err.o:         fiodefs.h err.c
+fmtlib.o:      fio.h fmtlib.c
+dballoc.o:     dballoc.c
+fio.h:         fiodefs.h
+
+# compile, then strip unnecessary symbols
+.c.o:
+       cc $(CFLAGS) -c $*.c
+       -ld -r -x $*.o
+       mv a.out $*.o
+
+clean:
+       rm -f *.o libI77.a tags
+
+index: $(SOURCES)
+       @mkindx "f77 libI77.a Source Listing " Makefile $(SOURCES)
+
+print: index
+       @pr index Makefile `ls $(SOURCES)` | lpr
+
+writeup:       writeup.tx
+       @-rm writeup
+       @nroff -ms writeup.tx > writeup
+
+wup:
+       @nroff -ms writeup.tx | more
+
+tape:  
+       @tar cf /dev/rmt4 \
+       Makefile READ_ME NEWS writeup.tx writeup $(SOURCES) io.c
+
+order:
+       @rm -f order
+       @lorder $(OBJECTS) | tsort >order
+
+tags:  $(SOURCES)
+       @ctags $(SOURCES)
+

diff --git a/usr/src/lib/libI77uc/NEWS b/usr/src/lib/libI77uc/NEWS
new file mode 100644 (file)
index 0000000..b1ff43d
--- /dev/null
+++ b/usr/src/lib/libI77uc/NEWS
@@ -0,0 +1,70 @@
+       Update info on the f77 I/O lib.
+
+01 Feb, 1980
+   All instances of:
+       if(!init) f_init();
+   have been removed. f_init() is called from main.c on startup in the new
+   libF77.a .
+
+01 Feb, 1980
+   Backspace now allows non-seek files to reset the EOF flag.
+
+20 Mar, 1980
+   The way SIGINT is handled in libF77/main.c has been changed.
+   If the signal is not SIG_DFL, it is left alone as otherwise the
+   program will be killed if run in the background and the user types DEL.
+   The signal trap that used to be in the I/O lib has been removed.
+
+20 Mar, 1980
+   The ANSI fortran standard requires that I/O routines return to the caller
+   on any error condition if iostat= is specified even if no err= or end=
+   trap is specified. The implication of this is that the program must
+   be prepared to deal with ALL I/O errors if iostat= is specified.
+   If only one trap is specified, end= for example, the program must test the
+   iostat variable for positive/non-zero after the I/O call since return
+   will occur on any error. This seems awkward and I've chosen to make this
+   feature optional. I am interested in other views on this.
+   
+   In the current version of the compiler (using the modified io.c),
+   iostat= is used only to return status information from
+   I/O calls but does not itself cause return on any I/O error. Only
+   the traps, err= and end=, will cause a return/branch, and only for
+   the specified trap(s).
+   
+   This feature has been made a compile time option in the current version
+   of (modified) io.c It implements the standard correctly if compiled
+   with -DKOSHER or -DIOSRETURN. Otherwise it executes as currently
+   implemented.
+
+18 Apr, 1980
+   As originally implemented the '$' specification caused a NULL to be
+   output (inplace of the \n) Actually NULL's should never appear in the
+   formatted output streams. Therefore in "sfe.c" in x_putc() and pr_put()
+   add      if (c)      before the instances of      putc(c,cf)
+
+12 May, 1980
+   Spaces (ASCII 040) do not have significance in FORMAT statements except
+   within strings. In order to accomodate old programs that may have
+   arbitrary occurances of spaces, all spaces are now ignored. Thus the
+   format ( 1 0 X , 1 2 F 1 0 . 4 / ) is accepted.
+
+12 May, 1980
+   A bug in handling partially filled "unformatted direct" records has been
+   fixed by ensuring that all records are complete when written. The bug was
+   that the last record of such a file would cause EOF if a read was attempted
+   for a full record. Existing files of this form should be "fixed" by
+   reading and rewriting the last record using the new version of libI77.a
+
+12 May, 1980
+   BACKSPACE will now open a default file (fort.N) if the specified logical
+   unit is not open. REWIND and other I/O already did this. CLOSE and
+   ENDFILE do not open a default file.
+
+07 Oct, 1980
+   List directed input now terminates properly on a slash and flushes to
+   either slash or newline, whichever comes first. List directed input now
+   properly converts wierd forms such as 3.-4 and 5+3. It now returns an
+   error if the repeat count is negative.
+
+   Several type definitions were changed/added to accomodate 11/70's.
+

diff --git a/usr/src/lib/libI77uc/READ_ME b/usr/src/lib/libI77uc/READ_ME
new file mode 100644 (file)
index 0000000..ed4b92f
--- /dev/null
+++ b/usr/src/lib/libI77uc/READ_ME
@@ -0,0 +1,51 @@
+Last update: Jan 1980
+
+       The sources here represent a major update of the f77 i/o library.
+In almost all cases routines conform to the ANSI standard. The only known
+exceptions are the "print" file form in `open' and `inquire', and the "+"
+vertical format control (still not implemented). Often relaxations or
+extensions of the standard have been incorporated.
+See the writeup file for details of the new library.
+
+       The non-ANSI extensions can be eliminated from the library by
+changing the Makefile to compile with -DKOSHER.
+
+       There may be some minor incompatabilities between the Vax 'C' compiler
+and 'C' on other machines that may cause problems with this code. The default
+definition of 'int' for example. I don't expect it to be a major problem.
+Please do send WELL DOCUMENTED bug reports to me.
+
+       A modified I/O code generation routine for the compiler is included
+in this directory. It include 2 compile time options. One option affects
+the handling of the iostat= clause: unless compiled with -DKOSHER or
+-DIOSRETURN an iostat= clause by itself will not cause a return on any
+error. Return is made only if one of the err= or end= clauses is present.
+The other option, suppressed with -DKOSHER, is that end= is allowed in write
+statements.  This copy of 'io.c' is included on the distribution tape.
+
+
+                               -+-+-+-+-+-
+
+To use the tape:
+       1. Load, using tar, into an appropriate directory. This is basically
+          the source for libI77 so /usr/src/libI77 would be appropriate.
+
+       2. Link or copy or move 'io.c' into the source directory for f77pass1.
+          Usually /usr/src/cmd/f77.
+          NOTE Jan, 1980: This may be /usr/src/cmd/f77/vaxvax
+
+       3. 'make f77pass1', 'make install' while in the /f77 directory.
+
+       4. Return to the /libI77 directory. 'make lib' if necessary.
+          Otherwise 'make install' to put the new lib in place.
+
+       5. If you modify the writeup.tx file, you can 'make writeup' to
+          create the nroff'ed version.
+
+                               -+-+-+-+-+-
+
+       David Wasley
+       431 Davis Hall
+       University of California
+       Berkeley, Calif. 94720
+       (415) 642-3478

diff --git a/usr/src/lib/libI77uc/backspace.c b/usr/src/lib/libI77uc/backspace.c
new file mode 100644 (file)
index 0000000..da2d5f9
--- /dev/null
+++ b/usr/src/lib/libI77uc/backspace.c
@@ -0,0 +1,49 @@
+/*
+ * Backspace records
+ */
+
+#include "fio.h"
+
+char *bksp = "backspace";
+char last_char();
+
+f_back(a) alist *a;
+{      unit *b;
+       int n,i;
+       long x,y;
+       lfname = NULL;
+       elist = NO;
+       external = YES;
+       errflag = a->aerr;
+       lunit = a->aunit;
+       if (not_legal(lunit)) err(errflag,101,bksp)
+       b= &units[lunit];
+       if(!b->ufd && (n=fk_open(READ,SEQ,FMT,(ftnint)lunit)) )
+               err(errflag,n,bksp)
+       lfname = b->ufnm;
+       if(b->uend)
+       {       b->uend = NO;
+               return(OK);
+       }
+       if((x=ftell(b->ufd))==0) return(OK);
+       if(!b->useek) err(errflag,106,bksp)
+       if(b->uwrt) t_runc(b,errflag);
+       if(b->url)              /* direct access, purely academic */
+       {       y = x%(long)b->url;
+               x -= y?y:b->url;
+               fseek(b->ufd,x,0);
+               return(OK);
+       }
+       if(!b->ufmt)            /* unformatted sequential */
+       {       fseek(b->ufd,-(long)sizeof(int),1);
+               fread((char *)&n,sizeof(int),1,b->ufd);
+               fseek(b->ufd,-(long)n-2*sizeof(int),1);
+               return(OK);
+       }
+       if(x==1)                        /* formatted sequential */
+       {       rewind(b->ufd);
+               return(OK);
+       }
+       while(last_char(b->ufd)!='\n'); /* slow but simple */
+       return(OK);
+}

diff --git a/usr/src/lib/libI77uc/close.c b/usr/src/lib/libI77uc/close.c
new file mode 100644 (file)
index 0000000..3a814be
--- /dev/null
+++ b/usr/src/lib/libI77uc/close.c
@@ -0,0 +1,66 @@
+/*
+ * close.c  -  f77 file close, flush, exit routines
+ */
+
+#include "fio.h"
+
+#define FROM_OPEN      '\1'
+
+f_clos(a) cllist *a;
+{      unit *b;
+       lfname = NULL;
+       elist = NO;
+       external = YES;
+       errflag = a->cerr;
+       lunit = a->cunit;
+       if(not_legal(lunit)) err(errflag,101,"close");
+       if(lunit==STDERR && (!a->csta || *a->csta != FROM_OPEN))
+               err(errflag,101,"can't close stderr");
+       b= &units[lunit];
+       if(!b->ufd) err(errflag,114,"close");
+       if(a->csta)
+               switch(lcase(*a->csta))
+               {
+       delete:
+               case 'd':
+                       fclose(b->ufd);
+                       if(b->ufnm) unlink(b->ufnm); /*SYSDEP*/
+                       break;
+               default:
+       keep:
+               case 'k':
+                       if(b->uwrt) t_runc(b,errflag);
+                       fclose(b->ufd);
+                       break;
+               }
+       else if(b->uscrtch) goto delete;
+       else goto keep;
+       if(b->ufnm) free(b->ufnm);
+       b->ufnm=NULL;
+       b->ufd=NULL;
+       return(OK);
+}
+
+f_exit()
+{
+       ftnint lu, dofirst = YES;
+       cllist xx;
+       xx.cerr=1;
+       xx.csta=NULL;
+       for(lu=STDOUT; (dofirst || lu!=STDOUT); lu = ++lu % MXUNIT)
+       {
+               xx.cunit=lu;
+               f_clos(&xx);
+               dofirst = NO;
+       }
+}
+
+ftnint
+flush_(u) ftnint *u;
+{
+       FILE *F = units[*u].ufd;
+       if(F)
+               return(fflush(F));
+       else
+               return(114);
+}

diff --git a/usr/src/lib/libI77uc/dballoc.c b/usr/src/lib/libI77uc/dballoc.c
new file mode 100644 (file)
index 0000000..5ffc553
--- /dev/null
+++ b/usr/src/lib/libI77uc/dballoc.c
@@ -0,0 +1,157 @@
+/*     C storage allocator
+ *     circular first-fit strategy
+ *     works with noncontiguous, but monotonically linked, arena
+ *     each block is preceded by a ptr to the (pointer of) 
+ *     the next following block
+ *     blocks are exact number of words long; BUSY
+ *     bit in ptr is 1 for busy, 0 for idle
+ *     gaps in arena are merely noted as busy blocks
+ *     last block of arena (pointed to by alloct) is empty and
+ *     has a pointer to first
+ *     idle blocks are coalesced during space search
+*/
+
+#include       <stdio.h>
+
+/*     all these defines must be powers of 2 */
+#define WORD sizeof(struct store)
+#define BLOCK 1024
+#define BUSY 1
+#define NULL 0
+#define testbusy(p) ((int)(p)&BUSY)
+#define setbusy(p) (struct store *)((int)(p)+BUSY)
+#define clearbusy(p) (struct store *)((int)(p)&~BUSY)
+
+/*
+#define debug YES
+*/
+
+#ifndef debug
+#define ASSERT(p)
+#endif
+
+#ifdef debug
+#define ASSERT(p) if(!(p))botch("p");else
+
+botch(s) char *s;
+{
+       fatal(119,s);
+}
+#endif
+
+struct store { struct store *ptr; };
+
+struct store allocs[] = {      /*initial arena*/
+       setbusy(&allocs[1].ptr),
+       setbusy(&allocs[0].ptr)
+};
+struct store *allocp = &allocs[1];     /*search ptr*/
+struct store *alloct = &allocs[1];     /*arena top*/
+struct store *allocx = 0;              /*for benefit of realloc*/
+struct store *sbrk();
+
+struct store *
+malloc(nbytes)
+unsigned nbytes;
+{
+       struct store *p, *q;
+       register nw;
+       static temp;    /*coroutines assume no auto*/
+
+#ifdef verbose
+       printf("malloc(%d) ",nbytes);
+#endif
+       nw = (nbytes+2*WORD-1)/WORD;
+       ASSERT(allocp>allocs && allocp<=alloct);
+       for(p=allocp; ; ) {
+               for(temp=0; ; ) {
+                       if(!testbusy(p->ptr)) {
+                               while(!testbusy((q=p->ptr)->ptr)) {
+                                       ASSERT(q>p&&q<alloct);
+                                       p->ptr = q->ptr;
+                               }
+                               if(q>=p+nw && p+nw>=p)
+                                       goto found;
+                       }
+                       q = p;
+                       p = clearbusy(p->ptr);
+                       if(p>q)
+                               ASSERT(p<=alloct);
+                       else if(q!=alloct || p!=allocs) {
+                               fatal(119,"dballoc");
+                       } else if(++temp>1)
+                               break;
+               }
+               temp = (nw+BLOCK/WORD)&~(BLOCK/WORD-1);
+               q = sbrk(temp*WORD); /*SYSDEP*/
+               if((int)q == -1)
+                       return(NULL);
+               ASSERT(q>alloct);
+               alloct->ptr = q;
+               if(q!=alloct+1)
+                       alloct->ptr = setbusy(alloct->ptr);
+               alloct = q->ptr = q+temp-1;
+               alloct->ptr = setbusy(allocs);
+       }
+found:
+       allocp = p + nw;
+       ASSERT(allocp<=alloct);
+       if(q>allocp) {
+               allocx = allocp->ptr;
+               allocp->ptr = p->ptr;
+       }
+       p->ptr = setbusy(allocp);
+#ifdef verbose
+       printf("= %o\n",p+1);
+#endif
+       return(p+1);
+}
+
+/*
+ *     freeing strategy tuned for LIFO allocation
+ */
+free(p)
+struct store *p;
+{
+       struct store *savep=p;
+#ifdef verbose
+       printf("free(%o)\n",p);
+#endif
+       ASSERT(p>clearbusy(allocs[1].ptr)&&p<=alloct);
+       allocp = --p;
+       ASSERT(testbusy(p->ptr));
+       p->ptr = clearbusy(p->ptr);
+       ASSERT(p->ptr > allocp && p->ptr <= alloct);
+}
+
+char *calloc(nbytes,count)
+{      char *c;
+       c=(char *)malloc(nbytes*count);
+       return(c);
+}
+
+struct store *
+realloc(p, nbytes)
+register struct store *p;
+unsigned nbytes;
+{
+       register struct store *q;
+       struct store *s, *t;
+       register unsigned nw;
+       unsigned onw;
+
+       onw = p[-1].ptr - p;
+       q = malloc(nbytes);
+       if(q==NULL || q==p)
+               return(q);
+       s = p;
+       t = q;
+       nw = (nbytes+WORD-1)/WORD;
+       if(nw<onw)
+               onw = nw;
+       while(onw--!=0)
+               (t++)->ptr = (s++)->ptr;
+       if(q<p && q+nw>=p)
+               (q+(q+nw-p))->ptr = allocx;
+       return(q);
+}

diff --git a/usr/src/lib/libI77uc/dfe.c b/usr/src/lib/libI77uc/dfe.c
new file mode 100644 (file)
index 0000000..dd03e73
--- /dev/null
+++ b/usr/src/lib/libI77uc/dfe.c
@@ -0,0 +1,183 @@
+/*
+ * direct formatted external i/o
+ */
+
+#include "fio.h"
+
+extern int rd_ed(),rd_ned(),w_ed(),w_ned();
+int y_getc(),y_putc(),y_rnew(),y_wnew(),y_tab();
+
+char *dfe = "dfe";
+char *rdfe = "read dfe";
+char *wdfe = "write dfe";
+
+s_rdfe(a) cilist *a;
+{
+       int n;
+       reading = YES;
+       if(n=c_dfe(a,READ)) return(n);
+       if(curunit->uwrt) nowreading(curunit);
+       getn = y_getc;
+       doed = rd_ed;
+       doned = rd_ned;
+       dotab = y_tab;
+       dorevert = doend = donewrec = y_rnew;
+       if(pars_f(fmtbuf)) err(errflag,100,rdfe)
+       fmt_bg();
+       return(OK);
+}
+
+s_wdfe(a) cilist *a;
+{
+       int n;
+       reading = NO;
+       if(n=c_dfe(a,WRITE)) return(n);
+       curunit->uend = NO;
+       if(!curunit->uwrt) nowwriting(curunit);
+       putn = y_putc;
+       doed = w_ed;
+       doned = w_ned;
+       dotab = y_tab;
+       dorevert = doend = donewrec = y_wnew;
+       if(pars_f(fmtbuf)) err(errflag,100,wdfe)
+       fmt_bg();
+       return(OK);
+}
+
+e_rdfe()
+{
+       en_fio();
+       return(OK);
+}
+
+e_wdfe()
+{
+       en_fio();
+       return(OK);
+}
+
+c_dfe(a,flag) cilist *a;
+{      int n;
+       sequential = NO;
+       external = formatted = FORMATTED;
+       lfname = NULL;
+       elist = NO;
+       cursor=scale=recpos=reclen=0;
+       radix = 10;
+       signit = YES;
+       fmtbuf = a->cifmt;
+       errflag = a->cierr;
+       endflag = a->ciend;
+       lunit = a->ciunit;
+       if(not_legal(lunit)) err(errflag,101,dfe);
+       curunit = &units[lunit];
+       if(!curunit->ufd && (n=fk_open(flag,DIR,FMT,(ftnint)lunit)))
+               err(errflag,n,dfe)
+       cf = curunit->ufd;
+       elist = YES;
+       lfname = curunit->ufnm;
+       if(!curunit->ufmt) err(errflag,102,dfe)
+       if(!curunit->useek || !curunit->url) err(errflag,104,dfe)
+       recnum = a->cirec - 1;
+       fseek(cf, (long)curunit->url * recnum, 0);
+       cblank = curunit->ublnk;
+       cplus = NO;
+       return(OK);
+}
+
+y_getc()
+{
+       int ch;
+       if(curunit->uend) return(EOF);
+       if(curunit->url==1 || recpos++ < curunit->url)
+       {
+               if((ch=getc(cf))!=EOF)
+               {
+                               return(ch);
+               }
+               if(feof(cf))
+               {
+                       curunit->uend = YES;
+                       return(EOF);
+               }
+               err(errflag,errno,rdfe);
+       }
+       else return(' ');
+}
+
+y_putc(c)
+{
+       if(curunit->url!=1 && recpos++ >= curunit->url) err(errflag,110,wdfe)
+       putc(c,cf);
+       return(OK);
+}
+
+y_tab()
+{      int n;
+       if(curunit->url==1)
+       {
+               if(cursor < 0 && -cursor > ftell(cf)) return(107);
+       }
+       else
+       {       if(reclen < recpos) reclen = recpos;
+               if((recpos + cursor) < 0) return(107);
+               n = reclen - recpos;            /* n >= 0 */
+               if(!reading && (cursor-n) > 0)
+               {       recpos = reclen;
+                       cursor -= n;
+                       fseek(cf,(long)n,1);
+                       while(cursor--) if(n=(*putn)(' ')) return(n);
+                       return(cursor=0);
+               }
+               recpos += cursor;
+               if(recpos >= curunit->url) err(errflag,110,dfe)
+       }
+       fseek(cf,(long)cursor,1);
+       return(cursor=0);
+}
+
+/*
+/*y_rev()
+/*{    /*what about work done?*/
+/*     if(curunit->url==1) return(0);
+/*     while(recpos<curunit->url) (*putn)(' ');
+/*     recpos=0;
+/*     return(0);
+/*}
+/*
+/*y_err()
+/*{
+/*     err(errflag, 110, dfe);
+/*}
+*/
+
+y_rnew()
+{      if(curunit->url != 1)
+       {       fseek(cf,(long)curunit->url*(++recnum),0);
+               recpos = reclen = cursor = 0;
+       }
+       return(OK);
+}
+
+y_wnew()
+{      if(curunit->url != 1)
+       {       if(reclen > recpos)
+               {       fseek(cf,(long)(reclen-recpos),1);
+                       recpos = reclen;
+               }
+               while(recpos < curunit->url) (*putn)(' ');
+               recnum++;
+               recpos = reclen = cursor = 0;
+       }
+       return(OK);
+}
+
+y_rend()
+{
+       return(OK);
+}
+
+y_wend()
+{
+       return(y_wnew());
+}

diff --git a/usr/src/lib/libI77uc/dofio.c b/usr/src/lib/libI77uc/dofio.c
new file mode 100644 (file)
index 0000000..4fabfe6
--- /dev/null
+++ b/usr/src/lib/libI77uc/dofio.c
@@ -0,0 +1,143 @@
+/*
+ * fortran format executer
+ */
+
+#include "fio.h"
+#include "fmt.h"
+
+#define DO(x)  if(n=x) err(n>0?errflag:endflag,n,dfio)
+#define STKSZ 10
+int cnt[STKSZ],ret[STKSZ],cp,rp;
+char *dfio = "dofio";
+
+en_fio()
+{      ftnint one=1;
+       return(do_fio(&one,NULL,0l));
+}
+
+do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
+{      struct syl *p;
+       int n,i,more;
+       more = *number;
+       for(;;)
+       switch(type_f((p= &syl[pc])->op))
+       {
+       case NED:
+               DO((*doned)(p,ptr))
+               pc++;
+               break;
+       case ED:
+               if(ptr==NULL)
+               {       DO((*doend)('\n'))
+                       return(OK);
+               }
+               if(cnt[cp]<=0)
+               {       cp--;
+                       pc++;
+                       break;
+               }
+               if(!more) return(OK);
+               DO((*doed)(p,ptr,len))
+               cnt[cp]--;
+               ptr += len;
+               more--;
+               break;
+       case STACK:             /* repeat count */
+               if(++cp==STKSZ) err(errflag,100,"too many nested ()")
+               cnt[cp]=p->p1;
+               pc++;
+               break;
+       case RET:               /* open paren */
+               if(++rp==STKSZ) err(errflag,100,"too many nested ()")
+               ret[rp]=p->p1;
+               pc++;
+               break;
+       case GOTO:              /* close paren */
+               if(--cnt[cp]<=0)
+               {       cp--;
+                       rp--;
+                       pc++;
+               }
+               else pc = ret[rp--] + 1;
+               break;
+       case REVERT:            /* end of format */
+               if(ptr==NULL)
+               {       DO((*doend)('\n'))
+                       return(OK);
+               }
+               if(!more) return(OK);
+               rp=cp=0;
+               pc = p->p1;
+               DO((*dorevert)())
+               break;
+       case COLON:
+#ifndef KOSHER
+       case DOLAR:                             /*** NOT STANDARD FORTRAN ***/
+#endif
+               if (ptr == NULL)
+               {       DO((*doend)((char)p->p1))
+                       return(OK);
+               }
+               if (!more) return(OK);
+               pc++;
+               break;
+#ifndef KOSHER
+       case SU:                                /*** NOT STANDARD FORTRAN ***/
+#endif
+       case SS:
+       case SP:
+       case S: cplus = p->p1;
+               signit = p->p2;
+               pc++;
+               break;
+       case P:
+               scale = p->p1;
+               pc++;
+               break;
+#ifndef KOSHER
+       case R:                                 /*** NOT STANDARD FORTRAN ***/
+               radix = p->p1;
+               pc++;
+               break;
+#endif
+       case BN:
+       case BZ:
+               cblank = p->p1;
+               pc++;
+               break;
+       default:
+               err(errflag,100,"impossible code")
+       }
+}
+
+fmt_bg()
+{
+       cp=rp=pc=cursor=0;
+       cnt[0]=ret[0]=0;
+}
+
+type_f(n)
+{
+#ifdef debug
+       fprintf(stderr," pc=%d, cnt[%d]=%d, ret[%d]=%d, op=%d\n",
+               pc,cp,cnt[cp],rp,ret[rp],n); /*for debug*/
+#endif
+       switch(n)
+       {
+       case X:                 /* non-editing specifications */
+       case SLASH:
+       case APOS: case H:
+       case T: case TL: case TR:
+                               return(NED);
+
+       case F:                 /* editing conversions */
+       case I: case IM:
+       case A: case AW:
+       case L:
+       case E: case EE: case D: case DE:
+       case G: case GE:
+                               return(ED);
+
+       default: return(n);
+       }
+}

diff --git a/usr/src/lib/libI77uc/dolio.c b/usr/src/lib/libI77uc/dolio.c
new file mode 100644 (file)
index 0000000..feaec87
--- /dev/null
+++ b/usr/src/lib/libI77uc/dolio.c
@@ -0,0 +1,35 @@
+/*
+ * list directed i/o common routines
+ */
+
+#include "fio.h"
+#include "lio.h"
+
+
+c_le(a,flag) cilist *a;
+{      int n;
+       lfname = NULL;
+       elist = NO;
+       sequential=external=formatted= LISTDIRECTED;
+       fmtbuf = "ext list io";
+       errflag = a->cierr;
+       endflag = a->ciend;
+       lunit = a->ciunit;
+       if(not_legal(lunit)) err(errflag,101,fmtbuf)
+       curunit = &units[lunit];
+       if(!curunit->ufd && (n=fk_open(flag,SEQ,FMT,(ftnint)lunit)))
+               err(errflag,n,fmtbuf)
+       cf = curunit->ufd;
+       elist = YES;
+       lfname = curunit->ufnm;
+       scale=recpos=cursor=0;
+       cplus=cblank=NO;
+       if(!curunit->ufmt) err(errflag,102,fmtbuf)
+       if(curunit->url) err(errflag,105,fmtbuf)
+       return(OK);
+}
+
+do_lio(type,number,ptr,len) ftnint *number,*type; flex *ptr; ftnlen len;
+{
+       return((*lioproc)(number,ptr,len,*type));
+}

diff --git a/usr/src/lib/libI77uc/douio.c b/usr/src/lib/libI77uc/douio.c
new file mode 100644 (file)
index 0000000..31bfb63
--- /dev/null
+++ b/usr/src/lib/libI77uc/douio.c
@@ -0,0 +1,60 @@
+/*
+ * unformatted external i/o
+ */
+
+#include "fio.h"
+
+char *eor = "eor/uio";
+char *uio = "uio";
+
+do_us(number,ptr,len) ftnint *number; ftnlen len; char *ptr;  /* sequential */
+{
+       if(reading)
+       {
+               recpos += *number * len;
+               if (recpos > reclen)
+                       err(errflag,110,eor);
+
+               if (fread(ptr,(int)len,(int)(*number),cf) != *number)
+                       return(due_err(uio));
+       }
+       else
+       {
+               reclen += *number * len;
+               fwrite(ptr,(int)len,(int)(*number),cf);
+       }
+       return(OK);
+}
+
+do_uio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
+{
+       if(sequential)
+               return(do_us(number,ptr,len));
+       else
+               return(do_ud(number,ptr,len));
+}
+
+do_ud(number,ptr,len) ftnint *number; ftnlen len; char *ptr;  /* direct */
+{
+       recpos += *number * len;
+       if(recpos > curunit->url && curunit->url!=1)
+               err(errflag,110,eor);
+       if(reading)
+       {
+               if (fread(ptr, (int)len, (int)(*number), cf) != *number)
+                       return(due_err(uio));
+       }
+       else
+               fwrite(ptr,(int)len,(int)(*number),cf);
+       return(OK);
+}
+
+due_err(s) char *s;
+{
+       if(feof(cf))
+               err(endflag,EOF,s)
+       else
+       {       clearerr(cf);
+               err(errflag,errno,s)
+       }
+}

diff --git a/usr/src/lib/libI77uc/due.c b/usr/src/lib/libI77uc/due.c
new file mode 100644 (file)
index 0000000..ab70a79
--- /dev/null
+++ b/usr/src/lib/libI77uc/due.c
@@ -0,0 +1,66 @@
+/*
+ * direct unformatted external i/o
+ */
+
+#include "fio.h"
+
+char *due = "due";
+
+s_rdue(a) cilist *a;
+{
+       int n;
+       reading = YES;
+       if(n=c_due(a,READ)) return(n);
+       if(curunit->uwrt) nowreading(curunit);
+       return(OK);
+}
+
+s_wdue(a) cilist *a;
+{
+       int n;
+       reading = NO;
+       if(n=c_due(a,WRITE)) return(n);
+       curunit->uend = NO;
+       if(!curunit->uwrt) nowwriting(curunit);
+       return(OK);
+}
+
+c_due(a,flag) cilist *a;
+{      int n;
+       lfname = NULL;
+       elist = NO;
+       sequential=formatted=NO;
+       recpos = reclen = 0;
+       external = YES;
+       errflag = a->cierr;
+       endflag = a->ciend;
+       lunit = a->ciunit;
+       if(not_legal(lunit)) err(errflag,101,due);
+       curunit = &units[lunit];
+       if (!curunit->ufd && (n=fk_open(flag,DIR,UNF,(ftnint)lunit)) )
+               err(errflag,n,due)
+       cf = curunit->ufd;
+       elist = YES;
+       lfname = curunit->ufnm;
+       if (curunit->ufmt) err(errflag,103,due)
+       if (!curunit->useek || !curunit->url) err(errflag,104,due)
+       if (fseek(cf, (long)((a->cirec-1)*curunit->url), 0) < 0)
+               return(due_err(due));
+       else
+               return(OK);
+}
+
+e_rdue()
+{
+       return(OK);
+}
+
+e_wdue()
+{/*    This is to ensure full records. It is really necessary. */
+       int n = 0;
+       if (curunit->url!=1 && recpos!=curunit->url &&
+           (fseek(cf, (long)(curunit->url-recpos-1), 1) < 0
+               || fwrite(&n, 1, 1, cf) != 1))
+                       return(due_err(due));
+       return(OK);
+}

diff --git a/usr/src/lib/libI77uc/endfile.c b/usr/src/lib/libI77uc/endfile.c
new file mode 100644 (file)
index 0000000..dc16ba1
--- /dev/null
+++ b/usr/src/lib/libI77uc/endfile.c
@@ -0,0 +1,66 @@
+/*
+ * endfile
+ */
+
+#include "fio.h"
+
+char *endf = "endfile";
+extern char *tmplate;
+
+f_end(a) alist *a;
+{
+       unit *b;
+       lfname = NULL;
+       elist = NO;
+       errflag = a->aerr;
+       lunit = a->aunit;
+       if (not_legal(lunit)) err(errflag,101,endf)
+       b = &units[lunit];
+       if(!b->ufd) err(errflag,114,endf)
+       if(b->uend) return(0);
+       lfname = b->ufnm;
+       b->uend = YES;
+       return(t_runc(b,errflag));
+}
+
+t_runc(b,flag) unit *b; ioflag flag;
+{
+       char buf[128],nm[16];
+       FILE *tmp;
+       int n,m;
+       long loc,len;
+       fflush(b->ufd);
+       if(b->uwrt) nowreading(b);
+       if(b->url || !b->useek || !b->ufnm) return(OK); /*don't trunc dir files*/
+       loc=ftell(b->ufd);
+       fseek(b->ufd,0L,2);
+       len=ftell(b->ufd);
+       if (loc==len) return(OK);
+       strcpy(nm,tmplate);
+       mktemp(nm);
+       if(!(tmp=fopen(nm,"w"))) err(flag,errno,endf);
+       fseek(b->ufd,0L,0);
+       while (loc)
+       {
+               n=fread(buf,1,loc>sizeof(buf)?sizeof(buf):(int)loc,b->ufd);
+               loc -= n;
+               fwrite(buf,1,n,tmp);
+       }
+       fflush(tmp);
+       for(n=0;n<10;n++)
+       {
+               if((m=fork())==-1) continue;
+               else if(m==0)
+               {
+                       execl("/bin/cp","cp",nm,b->ufnm,0);
+                       execl("/usr/bin/cp","cp",nm,b->ufnm,0);
+                       fatal(119,"no cp for trunc");
+               }
+               wait(&m);
+               if(m) err(flag,111,endf);
+               fclose(tmp);
+               unlink(nm);
+               return(OK);
+       }
+       err(flag,111,endf);
+}

diff --git a/usr/src/lib/libI77uc/err.c b/usr/src/lib/libI77uc/err.c
new file mode 100644 (file)
index 0000000..76e78eb
--- /dev/null
+++ b/usr/src/lib/libI77uc/err.c
@@ -0,0 +1,175 @@
+/*
+ * file i/o error and initialization routines
+ */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <signal.h>
+#include "fiodefs.h"
+
+/*
+ * global definitions
+ */
+
+char *tmplate = "tmp.FXXXXXX"; /* scratch file template */
+char *fortfile = "fort.%d";    /* default file template */
+
+unit units[MXUNIT] = 0;        /*unit table*/
+flag reading;          /*1 if reading,         0 if writing*/
+flag external;         /*1 if external io,     0 if internal */
+flag sequential;       /*1 if sequential io,   0 if direct*/
+flag formatted;                /*1 if formatted io,    0 if unformatted, -1 if list*/
+char *fmtbuf, *icptr, *icend, *fmtptr;
+int (*doed)(),(*doned)();
+int (*doend)(),(*donewrec)(),(*dorevert)(),(*dotab)();
+int (*lioproc)();
+int (*getn)(),(*putn)(),(*ungetn)();   /*for formatted io*/
+icilist *svic;         /* active internal io list */
+FILE *cf;              /*current file structure*/
+unit *curunit;         /*current unit structure*/
+int lunit;             /*current logical unit*/
+char *lfname;          /*current filename*/
+int recpos;            /*place in current record*/
+ftnint recnum;         /* current record number */
+int reclen;            /* current record length */
+int cursor,scale;
+int radix;
+ioflag signit,tab,cplus,cblank,elist,errflag,endflag,lquit,l_first;
+flag leof;
+int lcount,line_len;
+
+/*error messages*/
+
+extern char *sys_errlist[];
+
+char *F_err[] =
+{
+/* 100 */      "error in format",
+/* 101 */      "illegal unit number",
+/* 102 */      "formatted io not allowed",
+/* 103 */      "unformatted io not allowed",
+/* 104 */      "direct io not allowed",
+/* 105 */      "sequential io not allowed",
+/* 106 */      "can't backspace file",
+/* 107 */      "off beginning of record",
+/* 108 */      "can't stat file",
+/* 109 */      "no * after repeat count",
+/* 110 */      "off end of record",
+/* 111 */      "truncation failed",
+/* 112 */      "incomprehensible list input",
+/* 113 */      "out of free space",
+/* 114 */      "unit not connected",
+/* 115 */      "read unexpected character",
+/* 116 */      "blank logical input field",
+/* 117 */      "'new' file exists",
+/* 118 */      "can't find 'old' file",
+/* 119 */      "unknown system error",
+/* 120 */      "requires seek ability",
+/* 121 */      "illegal argument",
+/* 122 */      "negative repeat count",
+};
+
+#define MAXERR (sizeof(F_err)/sizeof(char *)+100)
+
+
+fatal(n,s) char *s;
+{
+       ftnint lu;
+
+       for (lu=1; lu < MXUNIT; lu++)
+               flush_(&lu);
+       if(n<100 && n>=0)
+               fprintf(stderr,"%s: [%d] %s\n",s,n,sys_errlist[n]);
+       else if(n>=(int)MAXERR)
+               fprintf(stderr,"%s: [%d] illegal error number\n",s,n);
+       else if(n<0)
+               fprintf(stderr,"%s: [%d] end of file\n",s,n);
+       else
+               fprintf(stderr,"%s: [%d] %s\n",s,n,F_err[n-100]);
+       if(external)
+       {
+               if(!lfname) switch (lunit)
+               {       case STDERR: lfname = "stderr";
+                                       break;
+                       case STDIN:  lfname = "stdin";
+                                       break;
+                       case STDOUT: lfname = "stdout";
+                                       break;
+                       default:     lfname = "";
+               }
+               fprintf(stderr,"logical unit %d, named '%s'\n",lunit,lfname);
+       }
+       if (elist)
+       {       fprintf(stderr,"lately: %s %s %s %s IO\n",
+                       reading?"reading":"writing",
+                       sequential?"sequential":"direct",
+                       formatted>0?"formatted":(formatted<0?"list":"unformatted"),
+                       external?"external":"internal");
+               if (formatted)
+               {       if(fmtbuf) prnt_fmt(n);
+                       if (external)
+                       {       if(reading && curunit->useek)
+                                       prnt_ext();  /* print external data */
+                       }
+                       else prnt_int();        /* print internal array */
+               }
+       }
+       f_exit();
+       _cleanup();
+       abort();
+}
+
+prnt_ext()
+{      int ch;
+       int i=1;
+       long loc;
+       fprintf (stderr, "part of last data: ");
+       loc = ftell(curunit->ufd);
+       if(loc)
+       {       if(loc==1L) rewind(curunit->ufd);
+               else for(;i<12 && last_char(curunit->ufd)!='\n';i++);
+               while(i--) fputc(fgetc(curunit->ufd),stderr);
+       }
+       fputc('|',stderr);
+       for(i=0;i<5 && (ch=fgetc(curunit->ufd)!=EOF);i++) fputc(ch,stderr);
+       fputc('\n',stderr);
+}
+
+prnt_int()
+{      char *ep;
+       fprintf (stderr,"part of last string: ");
+       ep = icptr - (recpos<12?recpos:12);
+       while (ep<icptr) fputc(*ep++,stderr);
+       fputc('|',stderr);
+       while (ep<(icptr+5) && ep<icend) fputc(*ep++,stderr);
+       fputc('\n',stderr);
+}
+
+prnt_fmt(n) int n;
+{      int i; char *ep;
+       fprintf(stderr, "part of last format: ");
+       if(n==100)
+       {       i = fmtptr - fmtbuf;
+               ep = fmtptr - (i<20?i:20);
+               i = i + 5;
+       }
+       else
+       {       ep = fmtbuf;
+               i = 25;
+               fmtptr = fmtbuf - 1;
+       }
+       while(i && *ep)
+       {       fputc((*ep==GLITCH)?'"':*ep,stderr);
+               if(ep==fmtptr) fputc('|',stderr);
+               ep++; i--;
+       }
+       fputc('\n',stderr);
+}
+
+/*initialization routine*/
+f_init()
+{      ini_std(STDERR, stderr, WRITE);
+       ini_std(STDIN, stdin, READ);
+       ini_std(STDOUT, stdout, WRITE);
+}
+

diff --git a/usr/src/lib/libI77uc/fio.h b/usr/src/lib/libI77uc/fio.h
new file mode 100644 (file)
index 0000000..2b91d64
--- /dev/null
+++ b/usr/src/lib/libI77uc/fio.h
@@ -0,0 +1,37 @@
+/*
+ * f77 file i/o common definitions
+ */
+
+#include "fiodefs.h"
+
+#define err(f,n,s)     {if(f) return(errno=n); else fatal(n,s);}
+#define not_legal(u)   (u>=MXUNIT || u<0)
+#define GET(x)         if((x=(*getn)())<0) return(x)
+#define VAL(x)         (x!='\n'?x:' ')
+#define PUT(x)         {if(n=(*putn)(x)) return(n);}
+#define lcase(s)       ((s >= 'A') && (s <= 'Z') ? s+('a'-'A') : s)
+
+#define MAXINTLENGTH   32      /* to accomodate binary format */
+
+long ftell();
+
+extern int errno;
+extern ioflag init;
+extern icilist *svic;  /* active internal io list */
+extern flag reading,external,sequential,formatted;
+extern int (*getn)(),(*putn)(),(*ungetn)();    /*for formatted io*/
+extern FILE *cf;       /*current file structure*/
+extern unit *curunit;  /*current unit structure */
+extern int lunit;      /*current logical unit*/
+extern char *lfname;   /*current filename*/
+extern unit units[];   /*logical units table*/
+extern int recpos;             /*position in current record*/
+extern ftnint recnum;          /*current record number*/
+extern int reclen;             /* current record length */
+extern int (*doed)(), (*doned)();
+extern int (*dorevert)(), (*donewrec)(), (*doend)(), (*dotab)();
+extern ioflag cblank, cplus, tab, elist, signit, errflag, endflag;
+extern char *fmtbuf, *icptr, *icend, *fmtptr;
+extern int scale;
+extern int cursor;
+extern int radix;

diff --git a/usr/src/lib/libI77uc/fiodefs.h b/usr/src/lib/libI77uc/fiodefs.h
new file mode 100644 (file)
index 0000000..ed39177
--- /dev/null
+++ b/usr/src/lib/libI77uc/fiodefs.h
@@ -0,0 +1,132 @@
+/*
+ * fortran file i/o type definitions
+ */
+
+#include <stdio.h>
+
+/* Logical Unit Table Size */
+#define MXUNIT _NFILE
+
+#define GLITCH '\2'    /* special quote for Stu, generated in f77pass1 */
+
+#define LISTDIRECTED  -1
+#define FORMATTED      1
+
+#define ERROR  1
+#define OK     0
+#define YES    1
+#define NO     0
+
+#define STDERR 0
+#define STDIN  5
+#define STDOUT 6
+
+#define WRITE  1
+#define READ   2
+#define SEQ    3
+#define DIR    4
+#define FMT    5
+#define UNF    6
+#define EXT    7
+#define INT    8
+
+typedef char ioflag;
+typedef long ftnint;
+typedef ftnint flag;
+typedef long ftnlen;
+
+typedef struct         /*external read, write*/
+{      flag cierr;
+       ftnint ciunit;
+       flag ciend;
+       char *cifmt;
+       ftnint cirec;
+} cilist;
+
+typedef struct         /*internal read, write*/
+{      flag icierr;
+       char *iciunit;
+       flag iciend;
+       char *icifmt;
+       ftnint icirlen;
+       ftnint icirnum;
+       ftnint icirec;
+} icilist;
+
+typedef struct         /*open*/
+{      flag oerr;
+       ftnint ounit;
+       char *ofnm;
+       ftnlen ofnmlen;
+       char *osta;
+       char *oacc;
+       char *ofm;
+       ftnint orl;
+       char *oblnk;
+} olist;
+
+typedef struct         /*close*/
+{      flag cerr;
+       ftnint cunit;
+       char *csta;
+} cllist;
+
+typedef struct         /*rewind, backspace, endfile*/
+{      flag aerr;
+       ftnint aunit;
+} alist;
+
+typedef struct         /*units*/
+{      FILE *ufd;      /*0=unconnected*/
+       char *ufnm;
+       long uinode;
+       int url;        /*0=sequential*/
+       flag useek;     /*true=can backspace, use dir, ...*/
+       flag ufmt;
+       flag uprnt;
+       flag ublnk;
+       flag uend;
+       flag uwrt;      /*last io was write*/
+       flag uscrtch;
+} unit;
+
+typedef struct         /* inquire */
+{      flag inerr;
+       ftnint inunit;
+       char *infile;
+       ftnlen infilen;
+       ftnint  *inex;  /*parameters in standard's order*/
+       ftnint  *inopen;
+       ftnint  *innum;
+       ftnint  *innamed;
+       char    *inname;
+       ftnlen  innamlen;
+       char    *inacc;
+       ftnlen  inacclen;
+       char    *inseq;
+       ftnlen  inseqlen;
+       char    *indir;
+       ftnlen  indirlen;
+       char    *inform;
+       ftnlen  informlen;
+       char    *infmt;
+       ftnint  infmtlen;
+       char    *inunf;
+       ftnlen  inunflen;
+       ftnint  *inrecl;
+       ftnint  *innrec;
+       char    *inblank;
+       ftnlen  inblanklen;
+} inlist;
+
+typedef union
+{      float pf;
+       double pd;
+} ufloat;
+
+typedef union
+{      short is;
+       char ic;
+       long il;
+} uint;
+

diff --git a/usr/src/lib/libI77uc/fmt.c b/usr/src/lib/libI77uc/fmt.c
new file mode 100644 (file)
index 0000000..0df7251
--- /dev/null
+++ b/usr/src/lib/libI77uc/fmt.c
@@ -0,0 +1,294 @@
+/*
+ * fortran format parser
+ */
+
+#include "fio.h"
+#include "fmt.h"
+
+#define isdigit(x)     (x>='0' && x<='9')
+#define isspace(s)     (s==' ')
+#define skip(s)                while(isspace(*s)) s++
+
+#ifdef interdata
+#define SYLMX 300
+#endif
+
+#ifdef pdp11
+#define SYLMX 300
+#endif
+
+#ifdef vax
+#define SYLMX 300
+#endif
+
+struct syl syl[SYLMX];
+int parenlvl,pc,revloc;
+char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();
+
+pars_f(s) char *s;
+{
+       parenlvl=revloc=pc=0;
+       return((f_s(s,0)==FMTERR)? ERROR : OK);
+}
+
+char *f_s(s,curloc) char *s;
+{
+       skip(s);
+       if(*s++!='(')
+       {
+               fmtptr = s;
+               return(FMTERR);
+       }
+       if(parenlvl++ ==1) revloc=curloc;
+       op_gen(RET,curloc,0,0,s);
+       if((s=f_list(s))==FMTERR)
+       {
+               return(FMTERR);
+       }
+       skip(s);
+       return(s);
+}
+
+char *f_list(s) char *s;
+{
+       while (*s)
+       {       skip(s);
+               if((s=i_tem(s))==FMTERR) return(FMTERR);
+               skip(s);
+               if(*s==',') s++;
+               else if(*s==')')
+               {       if(--parenlvl==0)
+                       {
+                               op_gen(REVERT,revloc,0,0,s);
+                       }
+                       else    op_gen(GOTO,0,0,0,s);
+                       return(++s);
+               }
+       }
+       fmtptr = s;
+       return(FMTERR);
+}
+
+char *i_tem(s) char *s;
+{      char *t;
+       int n,curloc;
+       if(*s==')') return(s);
+       if(ne_d(s,&t)) return(t);
+       if(e_d(s,&t)) return(t);
+       s=gt_num(s,&n);
+       curloc = op_gen(STACK,n,0,0,s);
+       return(f_s(s,curloc));
+}
+
+ne_d(s,p) char *s,**p;
+{      int n,x,sign=0,pp1,pp2;
+       switch(lcase(*s))
+       {
+       case ':': op_gen(COLON,(int)('\n'),0,0,s); break;
+#ifndef KOSHER
+       case '$': op_gen(DOLAR,(int)('\0'),0,0,s); break;  /*** NOT STANDARD FORTRAN ***/
+#endif
+       case 'b':
+               switch(lcase(*(s+1)))
+               {
+                       case 'z': s++; op_gen(BZ,1,0,0,s); break;
+                       case 'n': s++;
+                       default:  op_gen(BN,0,0,0,s); break;
+               }
+               break;
+       case 's':
+               switch(lcase(*(s+1)))
+               {
+                       case 'p': s++; x=SP; pp1=1; pp2=1; break;
+#ifndef KOSHER
+                       case 'u': s++; x=SU; pp1=0; pp2=0; break;  /*** NOT STANDARD FORTRAN ***/
+#endif
+                       case 's': s++; x=SS; pp1=0; pp2=1; break;
+                       default:  x=S; pp1=0; pp2=1; break;
+               }
+               op_gen(x,pp1,pp2,0,s);
+               break;
+       case '/': op_gen(SLASH,0,0,0,s); break;
+       case '-': sign=1; s++;  /*OUTRAGEOUS CODING TRICK*/
+       case '0': case '1': case '2': case '3': case '4':
+       case '5': case '6': case '7': case '8': case '9':
+               s=gt_num(s,&n);
+               switch(lcase(*s))
+               {
+               case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break;
+#ifndef KOSHER
+               case 'r': if(n<=1)              /*** NOT STANDARD FORTRAN ***/
+                       {       fmtptr = s; return(FMTERR); }
+                       op_gen(R,n,0,0,s); break;
+               case 't': op_gen(T,0,n,0,s); break;     /* NOT STANDARD FORT */
+#endif
+               case 'x': op_gen(X,n,0,0,s); break;
+               case 'h': op_gen(H,n,(int)(s+1),0,s);
+                       s+=n;
+                       break;
+               default: fmtptr = s; return(0);
+               }
+               break;
+       case GLITCH:
+       case '"':
+       case '\'': op_gen(APOS,(int)s,0,0,s);
+               *p = ap_end(s);
+               return(FMTOK);
+       case 't':
+               switch(lcase(*(s+1)))
+               {
+                       case 'l': s++; x=TL; break;
+                       case 'r': s++; x=TR; break;
+                       default:  x=T; break;
+               }
+               if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;}
+#ifndef KOSHER
+               else n = 0;     /* NOT STANDARD FORTRAN, should be error */
+#endif
+#ifdef KOSHER
+               fmtptr = s; return(FMTERR);
+#endif
+               op_gen(x,n,1,0,s);
+               break;
+       case 'x': op_gen(X,1,0,0,s); break;
+       case 'p': op_gen(P,0,0,0,s); break;
+#ifndef KOSHER
+       case 'r': op_gen(R,10,1,0,s); break;  /*** NOT STANDARD FORTRAN ***/
+#endif
+
+       default: fmtptr = s; return(0);
+       }
+       s++;
+       *p=s;
+       return(FMTOK);
+}
+
+e_d(s,p) char *s,**p;
+{      int n,w,d,e,x=0;
+       char *sv=s;
+       char c;
+       s=gt_num(s,&n);
+       op_gen(STACK,n,0,0,s);
+       c = lcase(*s); s++;
+       switch(c)
+       {
+       case 'd':
+       case 'e':
+       case 'g':
+               s = gt_num(s, &w);
+               if (w==0) break;
+               if(*s=='.')
+               {       s++;
+                       s=gt_num(s,&d);
+               }
+               else d=0;
+               if(lcase(*s) == 'e'
+#ifndef KOSHER
+               || *s == '.'             /*** '.' is NOT STANDARD FORTRAN ***/
+#endif
+               )
+               {       s++;
+                       s=gt_num(s,&e);
+                       if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
+               }
+               else
+               {       e=2;
+                       if(c=='e') n=E; else if(c=='d') n=D; else n=G;
+               }
+               op_gen(n,w,d,e,s);
+               break;
+       case 'l':
+               s = gt_num(s, &w);
+               if (w==0) break;
+               op_gen(L,w,0,0,s);
+               break;
+       case 'a':
+               skip(s);
+               if(*s>='0' && *s<='9')
+               {       s=gt_num(s,&w);
+                       if(w==0) break;
+                       op_gen(AW,w,0,0,s);
+                       break;
+               }
+               op_gen(A,0,0,0,s);
+               break;
+       case 'f':
+               s = gt_num(s, &w);
+               if (w==0) break;
+               if(*s=='.')
+               {       s++;
+                       s=gt_num(s,&d);
+               }
+               else d=0;
+               op_gen(F,w,d,0,s);
+               break;
+       case 'i':
+               s = gt_num(s, &w);
+               if (w==0) break;
+               if(*s =='.')
+               {
+                       s++;
+                       s=gt_num(s,&d);
+                       x = IM;
+               }
+               else
+               {       d = 1;
+                       x = I;
+               }
+               op_gen(x,w,d,0,s);
+               break;
+       default:
+               pc--;   /* unSTACK */
+               *p = sv;
+               fmtptr = s;
+               return(FMTERR);
+       }
+       *p = s;
+       return(FMTOK);
+}
+
+op_gen(a,b,c,d,s) char *s;
+{      struct syl *p= &syl[pc];
+       if(pc>=SYLMX)
+       {       fmtptr = s;
+               fatal(100,"format too complex");
+       }
+#ifdef debug
+       fprintf(stderr,"%3d opgen: %d %d %d %d %c\n",
+               pc,a,b,c,d,*s==GLITCH?'"':*s); /* for debug */
+#endif
+       p->op=a;
+       p->p1=b;
+       p->p2=c;
+       p->p3=d;
+       return(pc++);
+}
+
+char *gt_num(s,n) char *s; int *n;
+{      int m=0,a_digit=NO;
+       skip(s);
+       while(isdigit(*s) || isspace(*s))
+       {
+               if (isdigit(*s))
+               {
+                       m = 10*m + (*s)-'0';
+                       a_digit = YES;
+               }
+               s++;
+       }
+       if(a_digit) *n=m;
+       else *n=1;
+       return(s);
+}
+
+char *ap_end(s) char *s;
+{
+       char quote;
+       quote = *s++;
+       for(;*s;s++)
+       {
+               if(*s==quote && *++s!=quote) return(s);
+       }
+       fmtptr = s;
+       fatal(100,"bad string");
+}

diff --git a/usr/src/lib/libI77uc/fmt.h b/usr/src/lib/libI77uc/fmt.h
new file mode 100644 (file)
index 0000000..d34309d
--- /dev/null
+++ b/usr/src/lib/libI77uc/fmt.h
@@ -0,0 +1,49 @@
+/*
+ * format parser definitions
+ */
+
+struct syl
+{      int op,p1,p2,p3;
+};
+#define RET    1
+#define REVERT         2
+#define GOTO   3
+#define X      4
+#define SLASH  5
+#define STACK  6
+#define I      7
+#define ED     8
+#define NED    9
+#define IM     10
+#define APOS   11
+#define H      12
+#define TL     13
+#define TR     14
+#define T      15
+#define COLON  16
+#define S      17
+#define SP     18
+#define SS     19
+#define P      20
+#define BN     21
+#define BZ     22
+#define F      23
+#define E      24
+#define EE     25
+#define D      26
+#define DE     27              /*** NOT STANDARD FORTRAN ***/
+#define G      28
+#define GE     29
+#define L      30
+#define A      31
+#define AW     32
+#define R      33              /*** NOT STANDARD FORTRAN ***/
+#define DOLAR  34              /*** NOT STANDARD FORTRAN ***/
+#define SU     35              /*** NOT STANDARD FORTRAN ***/
+
+#define FMTOK  1
+#define FMTERR 0
+
+extern struct syl syl[];
+extern int pc,parenlvl,revloc;
+

diff --git a/usr/src/lib/libI77uc/fmtlib.c b/usr/src/lib/libI77uc/fmtlib.c
new file mode 100644 (file)
index 0000000..1b204d6
--- /dev/null
+++ b/usr/src/lib/libI77uc/fmtlib.c
@@ -0,0 +1,59 @@
+/*
+ * integer to ascii conversion
+ */
+
+#include "fio.h"
+
+#define digit(c)       ( (c > 9) ? (c - 10 + 'a') : c + '0')
+
+char *icvt(value,ndigit,sign) long value; int *ndigit,*sign;
+{
+       static char buf[MAXINTLENGTH+1];
+       register int i;
+       long kludge, rem, mask = 0x7fffffff;
+       int one = 1;
+       char c;
+
+       if (value == 0)
+       {       *sign=0;
+               *ndigit=one;
+               buf[MAXINTLENGTH]='0';
+               return(&buf[MAXINTLENGTH]);
+       }
+       else if (signit)        /* signed ? */
+       {
+               if (value > 0) *sign = 0;
+               else
+               {       value = -value;
+                       *sign = 1;
+               }
+               c = (int)(value % radix);
+               value /= radix;
+       }
+       else                    /* unsigned */
+       {       *sign = 0;
+               if (value < 0)
+               {       /* ALL THIS IS TO SIMULATE UNSIGNED MOD & DIV */
+                       kludge = mask - (radix - one);
+                       value &= mask;
+                       rem = (kludge % radix) + (value % radix);
+                       value = (kludge / radix) + (value / radix)
+                                + (rem / radix) + one;
+                       c = (int)(rem % radix);
+               }
+               else
+               {
+                       c = (int)(value % radix);
+                       value /= radix;
+               }
+       }
+       *(buf+MAXINTLENGTH) = digit(c);
+       for(i=MAXINTLENGTH-one; value!=0; i--)
+       {
+               c = (int)(value % radix);
+               *(buf+i) = digit(c);
+               value /= radix;
+       }
+       *ndigit = MAXINTLENGTH - i;
+       return(&buf[i+one]);
+}

diff --git a/usr/src/lib/libI77uc/iio.c b/usr/src/lib/libI77uc/iio.c
new file mode 100644 (file)
index 0000000..6e38257
--- /dev/null
+++ b/usr/src/lib/libI77uc/iio.c
@@ -0,0 +1,246 @@
+/*
+ * internal (character array) i/o
+ */
+
+#include "fio.h"
+#include "lio.h"
+
+extern int rd_ed(),rd_ned(),w_ed(),w_ned();
+extern int l_read(),l_write();
+int z_wnew(),z_rnew(),z_tab();
+
+z_getc()
+{
+       if(icptr >= icend && !recpos)   /* new rec beyond eof */
+       {       leof = EOF;
+               return(EOF);
+       }
+       if(recpos++ < svic->icirlen) return(*icptr++);
+       return(' ');
+}
+
+z_putc(c) char c;
+{
+       if(icptr < icend)
+       {       if(c=='\n') return(z_wnew());
+               if(recpos++ < svic->icirlen)
+               {       *icptr++ = c;
+                       return(OK);
+               }
+               else err(errflag,110,"iio")
+       }
+       leof = EOF;
+#ifndef KOSHER
+       err(endflag,EOF,"iio")   /* NOT STANDARD, end-of-file on writes */
+#endif
+#ifdef KOSHER
+       err(errflag,110,"iio")
+#endif
+}
+
+z_ungetc(ch,cf) char ch;
+{      if(ch==EOF || --recpos >= svic->icirlen) return(OK);
+       if(--icptr < svic->iciunit || recpos < 0) err(errflag,107,"ilio")
+       *icptr = ch;
+       return(OK);
+}
+
+s_rsfi(a) icilist *a;
+{
+       reading = YES;
+       doed=rd_ed;
+       doned=rd_ned;
+       getn=z_getc;
+       doend = donewrec = z_rnew;
+       dorevert = z_rnew;
+       dotab = z_tab;
+       return(c_si(a));
+}
+
+s_wsfi(a) icilist *a;
+{
+       reading = NO;
+       doed=w_ed;
+       doned=w_ned;
+       putn=z_putc;
+       doend = donewrec = z_wnew;
+       dorevert = z_wnew;
+       dotab = z_tab;
+       return(c_si(a));
+}
+
+s_rdfi(a) icilist *a;
+{
+       reading = YES;
+       doed = rd_ed;
+       doned = rd_ned;
+       getn = z_getc;
+       donewrec = z_rnew;
+       dorevert = doend = z_rnew;
+       dotab = z_tab;
+       return(c_di(a));
+}
+
+s_wdfi(a) icilist *a;
+{
+       reading = NO;
+       doed = w_ed;
+       doned = w_ned;
+       putn = z_putc;
+       donewrec = z_wnew;
+       dorevert = doend = z_wnew;
+       dotab = z_tab;
+       return(c_di(a));
+}
+
+c_fi(a) icilist *a;
+{
+       fmtbuf=a->icifmt;
+       formatted = FORMATTED;
+       external = NO;
+       cblank=cplus=NO;
+       scale=cursor=0;
+       radix = 10;
+       signit = YES;
+       elist = YES;
+       svic = a;
+       recpos=reclen=0;
+       icend = a->iciunit + a->icirnum*a->icirlen;
+       errflag = a->icierr;
+       endflag = a->iciend;
+       if(pars_f(fmtbuf)) err(errflag,100,"ifio")
+       fmt_bg();
+       return(OK);
+}
+
+c_si(a) icilist *a;
+{
+       sequential = YES;
+       recnum = 0;
+       icptr = a->iciunit;
+       return(c_fi(a));
+}
+
+c_di(a) icilist *a;
+{
+       sequential = NO;
+       recnum = a->icirec - 1;
+       icptr = a->iciunit + recnum*a->icirlen;
+       return(c_fi(a));
+}
+
+z_rnew()
+{
+       icptr = svic->iciunit + (++recnum)*svic->icirlen;
+       recpos = reclen = cursor = 0;
+       return(OK);
+}
+
+z_wnew()
+{
+       if(reclen > recpos)
+       {       icptr += (reclen - recpos);
+               recpos = reclen;
+       }
+       while(recpos < svic->icirlen) (*putn)(' ');
+       recpos = reclen = cursor = 0;
+       recnum++;
+       return(OK);
+}
+
+z_tab()
+{      int n;
+       if(reclen < recpos) reclen = recpos;
+       if((recpos + cursor) < 0) return(107);
+       n = reclen - recpos;
+       if(!reading && (cursor-n) > 0)
+       {       icptr += n;
+               recpos = reclen;
+               cursor -= n;
+               while(cursor--) if(n=(*putn)(' ')) return(n);
+       }
+       else
+       {       icptr += cursor;
+               recpos += cursor;
+       }
+       return(cursor=0);
+}
+
+e_rsfi()
+{      int n;
+       n = en_fio();
+       fmtbuf = NULL;
+       return(n);
+}
+
+e_wsfi()
+{
+       return(e_rsfi());
+}
+
+e_rdfi()
+{
+       return(e_rsfi());
+}
+
+e_wdfi()
+{
+       return(e_wsfi());
+}
+
+c_li(a) icilist *a;
+{
+       fmtbuf="int list io";
+       sequential = formatted = LISTDIRECTED;
+       external = NO;
+       elist = YES;
+       svic = a;
+       recnum = recpos = 0;
+       cplus = cblank = NO;
+       icptr = a->iciunit;
+       icend = icptr + a->icirlen * a->icirnum;
+       errflag = a->icierr;
+       endflag = a->iciend;
+       leof = NO;
+       return(OK);
+}
+
+s_rsli(a) icilist *a;
+{
+       reading = YES;
+       lioproc = l_read;
+       getn = z_getc;
+       ungetn = z_ungetc;
+       l_first = YES;
+       lcount = 0;
+       lquit = NO;
+       return(c_li(a));
+}
+
+s_wsli(a) icilist *a;
+{
+       reading = NO;
+       putn = z_putc;
+       lioproc = l_write;
+       line_len = a->icirlen;
+       return(c_li(a));
+}
+
+e_rsli()
+{      fmtbuf = NULL;
+       return(OK);
+}
+
+e_wsli()
+{      fmtbuf = NULL;
+       reclen = recpos;
+       return(z_wnew());
+}
+
+ftnint
+iiorec_()
+{      return(recnum); }
+
+ftnint
+iiopos_()
+{      return(recpos); }

diff --git a/usr/src/lib/libI77uc/inquire.c b/usr/src/lib/libI77uc/inquire.c
new file mode 100644 (file)
index 0000000..faf3b93
--- /dev/null
+++ b/usr/src/lib/libI77uc/inquire.c
@@ -0,0 +1,101 @@
+/*
+ * inquire.c - f77 i/o inquire statement routine
+ */
+
+#include "fio.h"
+
+f_inqu(a) inlist *a;
+{      char *byfile;
+       int i;
+       unit *p;
+       char buf[256], *s;
+       long x_inode;
+
+       elist = NO;
+       lfname = a->infile;
+       lunit = a->inunit;
+       external = YES;
+       p = NULL;
+       if(byfile=a->infile)
+       {
+               g_char(a->infile,a->infilen,buf);
+               if((x_inode=inode(buf))==-1)
+               {       if(a->inex) *a->inex = NO;  /* doesn't exist */
+                       return(OK);
+               }
+               for(i=0;i<MXUNIT;i++)
+                       if(units[i].ufd && (units[i].uinode==x_inode))
+                       {
+                               p = &units[i];
+                               break;
+                       }
+       }
+       else
+       {
+               if (not_legal(lunit)) err(a->inerr,101,"inquire")
+               else
+                       if (units[lunit].ufd)
+                       {       p= &units[lunit];
+                               lfname = p->ufnm;
+                       }
+       }
+       if(a->inex) *a->inex= ((byfile && x_inode) || (!byfile && p));
+       if(a->inopen) *a->inopen=(p!=NULL);
+       if(a->innum) *a->innum= (p?(p-units):-1);
+       if(a->innamed) *a->innamed= (byfile || (p && p->ufnm));
+       if(a->inname)
+       {
+               if(byfile) s = buf;
+               else if(p && p->ufnm) s = p->ufnm;
+               else s="";
+               b_char(s,a->inname,a->innamlen);
+       }
+       if(a->inacc && p)
+       {
+               if(p->url) s = "direct";
+               else    s = "sequential";
+               b_char(s,a->inacc,a->inacclen);
+       }
+       if(a->inseq)
+       {
+               s= ((byfile && !p) || (p && !p->url))? "yes" : "no";
+               b_char(s,a->inseq,a->inseqlen);
+       }
+       if(a->indir)
+       {
+               s= ((byfile && !p) || (p && p->useek && p->url))? "yes" : "no";
+               b_char(s,a->indir,a->indirlen);
+       }
+       if(a->inform)
+       {       if(p)
+               {
+#ifndef KOSHER
+                       if(p->uprnt) s = "print"; /*** NOT STANDARD FORTRAN ***/
+                       else
+#endif
+                               s = p->ufmt?"formatted":"unformatted";
+               }
+               else s = "unknown";
+               b_char(s,a->inform,a->informlen);
+       }
+       if(a->infmt)
+       {
+               if (p) s= p->ufmt? "yes" : "no";
+               else s= "unknown";
+               b_char(s,a->infmt,a->infmtlen);
+       }
+       if(a->inunf)
+       {
+               if (p) s= p->ufmt? "no" : "yes";
+               else s= "unknown";
+               b_char(s,a->inunf,a->inunflen);
+       }
+       if(a->inrecl && p) *a->inrecl=p->url;
+       if(a->innrec && p && p->url)
+               *a->innrec=(ftell(p->ufd)/p->url)+1;
+       if(a->inblank && p && p->ufmt)
+       {
+               b_char(p->ublnk? "zero" : "blank",a->inblank,a->inblanklen);
+       }
+       return(OK);
+}

diff --git a/usr/src/lib/libI77uc/io.c b/usr/src/lib/libI77uc/io.c
new file mode 100644 (file)
index 0000000..53c6984
--- /dev/null
+++ b/usr/src/lib/libI77uc/io.c
@@ -0,0 +1,791 @@
+/* Routines to generate code for I/O statements.
+   Some corrections and improvements due to David Wasley, U. C. Berkeley
+   Compile with -DKOSHER to force exact conformity with the ANSI std.
+*/
+
+#ifdef KOSHER
+#define IOSRETURN 1  /* to force ANSI std return on iostat= */
+#endif
+
+/* TEMPORARY */
+#define TYIOINT TYLONG
+#define SZIOINT SZLONG
+
+#include "defs"
+
+
+LOCAL char ioroutine[XL+1];
+
+LOCAL int ioendlab;
+LOCAL int ioerrlab;
+LOCAL int iostest;
+LOCAL int iosreturn;
+LOCAL int jumplab;
+LOCAL int skiplab;
+LOCAL int ioformatted;
+
+#define UNFORMATTED 0
+#define FORMATTED 1
+#define LISTDIRECTED 2
+
+#define V(z)   ioc[z].iocval
+
+#define IOALL 07777
+
+LOCAL struct Ioclist
+       {
+       char *iocname;
+       int iotype;
+       expptr iocval;
+       } ioc[ ] =
+       {
+               { "", 0 },
+               { "unit", IOALL },
+               { "fmt", M(IOREAD) | M(IOWRITE) },
+               { "err", IOALL },
+#ifdef KOSHER
+               { "end", M(IOREAD) },
+#else
+               { "end", M(IOREAD) | M(IOWRITE) },
+#endif
+               { "iostat", IOALL },
+               { "rec", M(IOREAD) | M(IOWRITE) },
+               { "recl", M(IOOPEN) | M(IOINQUIRE) },
+               { "file", M(IOOPEN) | M(IOINQUIRE) },
+               { "status", M(IOOPEN) | M(IOCLOSE) },
+               { "access", M(IOOPEN) | M(IOINQUIRE) },
+               { "form", M(IOOPEN) | M(IOINQUIRE) },
+               { "blank", M(IOOPEN) | M(IOINQUIRE) },
+               { "exist", M(IOINQUIRE) },
+               { "opened", M(IOINQUIRE) },
+               { "number", M(IOINQUIRE) },
+               { "named", M(IOINQUIRE) },
+               { "name", M(IOINQUIRE) },
+               { "sequential", M(IOINQUIRE) },
+               { "direct", M(IOINQUIRE) },
+               { "formatted", M(IOINQUIRE) },
+               { "unformatted", M(IOINQUIRE) },
+               { "nextrec", M(IOINQUIRE) }
+       } ;
+
+#define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
+#define MAXIO  SZFLAG + 10*SZIOINT + 15*SZADDR
+
+#define IOSUNIT 1
+#define IOSFMT 2
+#define IOSERR 3
+#define IOSEND 4
+#define IOSIOSTAT 5
+#define IOSREC 6
+#define IOSRECL 7
+#define IOSFILE 8
+#define IOSSTATUS 9
+#define IOSACCESS 10
+#define IOSFORM 11
+#define IOSBLANK 12
+#define IOSEXIST 13
+#define IOSOPENED 14
+#define IOSNUMBER 15
+#define IOSNAMED 16
+#define IOSNAME 17
+#define IOSSEQUENTIAL 18
+#define IOSDIRECT 19
+#define IOSFORMATTED 20
+#define IOSUNFORMATTED 21
+#define IOSNEXTREC 22
+
+#define IOSTP V(IOSIOSTAT)
+#define        IOSRW (iostmt==IOREAD || iostmt==IOWRITE)
+
+
+/* offsets in generated structures */
+
+#define SZFLAG SZIOINT
+
+/* offsets for external READ and WRITE statements */
+
+#define XERR 0
+#define XUNIT  SZFLAG
+#define XEND   SZFLAG + SZIOINT
+#define XFMT   2*SZFLAG + SZIOINT
+#define XREC   2*SZFLAG + SZIOINT + SZADDR
+
+/* offsets for internal READ and WRITE statements */
+
+#define XIERR  0
+#define XIUNIT SZFLAG
+#define XIEND  SZFLAG + SZADDR
+#define XIFMT  2*SZFLAG + SZADDR
+#define XIRLEN 2*SZFLAG + 2*SZADDR
+#define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT
+#define XIREC  2*SZFLAG + 2*SZADDR + 2*SZIOINT
+
+/* offsets for OPEN statements */
+
+#define XFNAME SZFLAG + SZIOINT
+#define XFNAMELEN      SZFLAG + SZIOINT + SZADDR
+#define XSTATUS        SZFLAG + 2*SZIOINT + SZADDR
+#define XACCESS        SZFLAG + 2*SZIOINT + 2*SZADDR
+#define XFORMATTED     SZFLAG + 2*SZIOINT + 3*SZADDR
+#define XRECLEN        SZFLAG + 2*SZIOINT + 4*SZADDR
+#define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR
+
+/* offset for CLOSE statement */
+
+#define XCLSTATUS      SZFLAG + SZIOINT
+
+/* offsets for INQUIRE statement */
+
+#define XFILE  SZFLAG + SZIOINT
+#define XFILELEN       SZFLAG + SZIOINT + SZADDR
+#define XEXISTS        SZFLAG + 2*SZIOINT + SZADDR
+#define XOPEN  SZFLAG + 2*SZIOINT + 2*SZADDR
+#define XNUMBER        SZFLAG + 2*SZIOINT + 3*SZADDR
+#define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR
+#define XNAME  SZFLAG + 2*SZIOINT + 5*SZADDR
+#define XNAMELEN       SZFLAG + 2*SZIOINT + 6*SZADDR
+#define XQACCESS       SZFLAG + 3*SZIOINT + 6*SZADDR
+#define XQACCLEN       SZFLAG + 3*SZIOINT + 7*SZADDR
+#define XSEQ   SZFLAG + 4*SZIOINT + 7*SZADDR
+#define XSEQLEN        SZFLAG + 4*SZIOINT + 8*SZADDR
+#define XDIRECT        SZFLAG + 5*SZIOINT + 8*SZADDR
+#define XDIRLEN        SZFLAG + 5*SZIOINT + 9*SZADDR
+#define XFORM  SZFLAG + 6*SZIOINT + 9*SZADDR
+#define XFORMLEN       SZFLAG + 6*SZIOINT + 10*SZADDR
+#define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR
+#define XFMTEDLEN      SZFLAG + 7*SZIOINT + 11*SZADDR
+#define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR
+#define XUNFMTLEN      SZFLAG + 8*SZIOINT + 12*SZADDR
+#define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR
+#define XNEXTREC       SZFLAG + 9*SZIOINT + 13*SZADDR
+#define XQBLANK        SZFLAG + 9*SZIOINT + 14*SZADDR
+#define XQBLANKLEN     SZFLAG + 9*SZIOINT + 15*SZADDR
+\f
+fmtstmt(lp)
+register struct Labelblock *lp;
+{
+if(lp == NULL)
+       {
+       execerr("unlabeled format statement" , 0);
+       return(-1);
+       }
+if(lp->labtype == LABUNKNOWN)
+       {
+       lp->labtype = LABFORMAT;
+       lp->labelno = newlabel();
+       }
+else if(lp->labtype != LABFORMAT)
+       {
+       execerr("bad format number", 0);
+       return(-1);
+       }
+return(lp->labelno);
+}
+
+
+
+setfmt(lp)
+struct Labelblock *lp;
+{
+ftnint n;
+char *s, *lexline();
+
+s = lexline(&n);
+preven(ALILONG);
+prlabel(asmfile, lp->labelno);
+putstr(asmfile, s, n);
+flline();
+}
+
+
+
+startioctl()
+{
+register int i;
+
+inioctl = YES;
+nioctl = 0;
+ioformatted = UNFORMATTED;
+for(i = 1 ; i<=NIOS ; ++i)
+       V(i) = NULL;
+}
+
+
+
+endioctl()
+{
+int i;
+expptr p;
+
+inioctl = NO;
+if(ioblkp == NULL)
+       ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, NULL);
+
+/* set up for error recovery */
+
+ioerrlab = ioendlab = jumplab = 0;
+skiplab = iosreturn = NO;
+
+if(p = V(IOSEND))
+       if(ISICON(p))
+               ioendlab = mklabel(p->constblock.const.ci)->labelno;
+       else
+               err("bad end= clause");
+
+if(p = V(IOSERR))
+       if(ISICON(p))
+               ioerrlab = mklabel(p->constblock.const.ci)->labelno;
+       else
+               err("bad err= clause");
+
+if(IOSTP)
+       if(IOSTP->headblock.tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
+               {
+               err("iostat must be an integer variable");
+               frexpr(IOSTP);
+               IOSTP = NULL;
+               }
+#ifdef IOSRETURN
+       else
+               iosreturn = YES;
+
+if(iosreturn && IOSRW && !(ioerrlab && ioendlab) )
+       {
+       jumplab = newlabel();
+       iostest = OPEQ;
+       if(ioerrlab || ioendlab) skiplab = YES;
+       }
+else if(ioerrlab && !ioendlab)
+
+#else
+if(ioerrlab && !ioendlab)
+#endif
+       {
+       jumplab = ioerrlab;
+       iostest = IOSRW ? OPLE : OPEQ;
+       }
+else if(!ioerrlab && ioendlab)
+       {
+       jumplab = ioendlab;
+       iostest = OPGE;
+       }
+else if(ioerrlab && ioendlab)
+       {
+       iostest = OPEQ;
+       if(ioerrlab == ioendlab)
+               jumplab = ioerrlab;
+       else
+               {
+               if(!IOSTP) IOSTP = mktemp(TYINT, NULL);
+               jumplab = newlabel();
+               skiplab = YES;
+               }
+       }
+/*else if(IOSTP)  /* the standard requires this return! */
+/*     {
+/*     iosreturn = YES;
+/*     if(iostmt==IOREAD || iostmt==IOWRITE)
+/*             {
+/*             jumplab = newlabel();
+/*             iostest = OPEQ;
+/*             }
+/*     }
+ */
+
+
+ioset(TYIOINT, XERR, ICON(ioerrlab!=0 || iosreturn) );
+
+switch(iostmt)
+       {
+       case IOOPEN:
+               dofopen();  break;
+
+       case IOCLOSE:
+               dofclose();  break;
+
+       case IOINQUIRE:
+               dofinquire();  break;
+
+       case IOBACKSPACE:
+               dofmove("f_back"); break;
+
+       case IOREWIND:
+               dofmove("f_rew");  break;
+
+       case IOENDFILE:
+               dofmove("f_end");  break;
+
+       case IOREAD:
+       case IOWRITE:
+               startrw();  break;
+
+       default:
+               fatali("impossible iostmt %d", iostmt);
+       }
+for(i = 1 ; i<=NIOS ; ++i)
+       if(i!=IOSIOSTAT && V(i)!=NULL)
+               frexpr(V(i));
+}
+
+
+
+iocname()
+{
+register int i;
+int found, mask;
+
+found = 0;
+mask = M(iostmt);
+for(i = 1 ; i <= NIOS ; ++i)
+       if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname))
+               if(ioc[i].iotype & mask)
+                       return(i);
+               else    found = i;
+if(found)
+       errstr("invalid control %s for statement", ioc[found].iocname);
+else
+       errstr("unknown iocontrol %s", varstr(toklen, token) );
+return(IOSBAD);
+}
+
+
+ioclause(n, p)
+register int n;
+register expptr p;
+{
+struct Ioclist *iocp;
+
+++nioctl;
+if(n == IOSBAD)
+       return;
+if(n == IOSPOSITIONAL)
+       {
+       if(nioctl > IOSFMT)
+               {
+               err("illegal positional iocontrol");
+               return;
+               }
+       n = nioctl;
+       }
+
+if(p == NULL)
+       {
+       if(n == IOSUNIT)
+               p = (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
+       else if(n != IOSFMT)
+               {
+               err("illegal * iocontrol");
+               return;
+               }
+       }
+if(n == IOSFMT)
+       ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
+
+iocp = & ioc[n];
+if(iocp->iocval == NULL)
+       {
+       if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) )
+               p = fixtype(p);
+       iocp->iocval = p;
+}
+else
+       errstr("iocontrol %s repeated", iocp->iocname);
+}
+
+/* io list item */
+
+doio(list)
+chainp list;
+{
+struct Exprblock *call0();
+doiolist(list);
+ioroutine[0] = 'e';
+putiocall( call0(TYINT, ioroutine) );
+}
+
+
+
+
+
+LOCAL doiolist(p0)
+chainp p0;
+{
+chainp p;
+register tagptr q;
+register expptr qe;
+register struct Nameblock *qn;
+struct Addrblock *tp, *mkscalar();
+int range;
+
+for (p = p0 ; p ; p = p->nextp)
+       {
+       q = p->datap;
+       if(q->headblock.tag == TIMPLDO)
+               {
+               exdo(range=newlabel(), q->impldoblock.varnp);
+               doiolist(q->impldoblock.datalist);
+               enddo(range);
+               free(q);
+               }
+       else    {
+               if(q->headblock.tag==TPRIM && q->primblock.argsp==NULL
+                   && q->primblock.namep->vdim!=NULL)
+                       {
+                       vardcl(qn = q->primblock.namep);
+                       if(qn->vdim->nelt)
+                               putio( fixtype(cpexpr(qn->vdim->nelt)),
+                                       mkscalar(qn) );
+                       else
+                               err("attempt to i/o array of unknown size");
+                       }
+               else if(q->headblock.tag==TPRIM && q->primblock.argsp==NULL &&
+                   (qe = memversion(q->primblock.namep)) )
+                       putio(ICON(1),qe);
+               else if( (qe = fixtype(cpexpr(q)))->headblock.tag==TADDR)
+                       putio(ICON(1), qe);
+               else if(qe->headblock.vtype != TYERROR)
+                       {
+                       if(iostmt == IOWRITE)
+                               {
+                               tp = mktemp(qe->headblock.vtype, qe->headblock.vleng);
+                               puteq( cpexpr(tp), qe);
+                               putio(ICON(1), tp);
+                               }
+                       else
+                               err("non-left side in READ list");
+                       }
+               frexpr(q);
+               }
+       }
+frchain( &p0 );
+}
+
+
+
+
+
+LOCAL putio(nelt, addr)
+expptr nelt;
+register expptr addr;
+{
+int type;
+register struct Exprblock *q;
+
+type = addr->headblock.vtype;
+if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
+       {
+       nelt = mkexpr(OPSTAR, ICON(2), nelt);
+       type -= (TYCOMPLEX-TYREAL);
+       }
+
+/* pass a length with every item.  for noncharacter data, fake one */
+if(type != TYCHAR)
+       {
+       if( ISCONST(addr) )
+               addr = putconst(addr);
+       addr->headblock.vtype = TYCHAR;
+       addr->headblock.vleng = ICON( typesize[type] );
+       }
+
+nelt = fixtype( mkconv(TYLENG,nelt) );
+if(ioformatted == LISTDIRECTED)
+       q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr);
+else
+       q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"),
+               nelt, addr);
+putiocall(q);
+}
+
+
+
+
+endio()
+{
+if(skiplab)
+       {
+       putlabel(jumplab);
+       if(ioendlab) putif( mkexpr(OPGE, cpexpr(IOSTP), ICON(0)), ioendlab);
+       if(ioerrlab) putif( mkexpr(OPLE, cpexpr(IOSTP), ICON(0)), ioerrlab);
+       }
+else if(iosreturn && jumplab)
+       putlabel(jumplab);
+if(IOSTP)
+       frexpr(IOSTP);
+}
+
+
+
+LOCAL putiocall(q)
+register struct Exprblock *q;
+{
+if(IOSTP)
+       {
+       q->vtype = TYINT;
+       q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q));
+       }
+
+if(jumplab)
+       putif( mkexpr(iostest, q, ICON(0) ), jumplab);
+else
+       putexpr(q);
+}
+\f
+
+startrw()
+{
+register expptr p;
+register struct Nameblock *np;
+register struct Addrblock *unitp, *nump;
+struct Constblock *mkaddcon();
+int k, fmtoff;
+int intfile, sequential;
+
+intfile = NO;
+if(p = V(IOSUNIT))
+       {
+       if( ISINT(p->headblock.vtype) )
+               ioset(TYIOINT, XUNIT, cpexpr(p) );
+       else if(p->headblock.vtype == TYCHAR)
+               {
+               intfile = YES;
+               if(p->headblock.tag==TPRIM && p->primblock.argsp==NULL &&
+                   (np = p->primblock.namep)->vdim!=NULL)
+                       {
+                       vardcl(np);
+                       if(np->vdim->nelt)
+                               nump = cpexpr(np->vdim->nelt);
+                       else
+                               {
+                               err("attempt to use internal unit array of unknown size");
+                               nump = ICON(1);
+                               }
+                       unitp = mkscalar(np);
+                       }
+               else    {
+                       nump = ICON(1);
+                       unitp = fixtype(cpexpr(p));
+                       }
+               ioset(TYIOINT, XIRNUM, nump);
+               ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
+               ioset(TYADDR, XIUNIT, addrof(unitp) );
+               }
+       }
+else
+       err("bad unit specifier");
+
+sequential = YES;
+if(p = V(IOSREC))
+       if( ISINT(p->headblock.vtype) )
+               {
+               ioset(TYIOINT, (intfile ? XIREC : XREC), cpexpr(p) );
+               sequential = NO;
+               }
+       else
+               err("bad REC= clause");
+
+ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(ioendlab!=0 || iosreturn) );
+
+fmtoff = (intfile ? XIFMT : XFMT);
+
+if(p = V(IOSFMT))
+       {
+       if(p->headblock.tag==TPRIM && p->primblock.argsp==NULL)
+               {
+               vardcl(np = p->primblock.namep);
+               if(np->vdim)
+                       {
+                       ioset(TYADDR, fmtoff, addrof(mkscalar(np)) );
+                       goto endfmt;
+                       }
+               if( ISINT(np->vtype) )
+                       {
+                       ioset(TYADDR, fmtoff, p);
+                       goto endfmt;
+                       }
+               }
+       p = V(IOSFMT) = fixtype(p);
+       if(p->headblock.vtype == TYCHAR)
+               ioset(TYADDR, fmtoff, addrof(cpexpr(p)) );
+       else if( ISICON(p) )
+               {
+               if( (k = fmtstmt( mklabel(p->constblock.const.ci) )) > 0 )
+                       ioset(TYADDR, fmtoff, mkaddcon(k) );
+               else
+                       ioformatted = UNFORMATTED;
+               }
+       else    {
+               err("bad format descriptor");
+               ioformatted = UNFORMATTED;
+               }
+       }
+else
+       ioset(TYADDR, fmtoff, ICON(0) );
+
+endfmt:
+       if(intfile && ioformatted==UNFORMATTED)
+               err("unformatted internal I/O not allowed");
+       if(!sequential && ioformatted==LISTDIRECTED)
+               err("direct list-directed I/O not allowed");
+
+ioroutine[0] = 's';
+ioroutine[1] = '_';
+ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w');
+ioroutine[3] = (sequential ? 's' : 'd');
+ioroutine[4] = "ufl" [ioformatted];
+ioroutine[5] = (intfile ? 'i' : 'e');
+ioroutine[6] = '\0';
+putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) ));
+}
+
+
+
+LOCAL dofopen()
+{
+register expptr p;
+
+if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+       ioset(TYIOINT, XUNIT, cpexpr(p) );
+else
+       err("bad unit in open");
+if( (p = V(IOSFILE)) )
+       if(p->headblock.vtype == TYCHAR)
+               ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
+       else
+               err("bad file in open");
+
+iosetc(XFNAME, p);
+
+if(p = V(IOSRECL))
+       if( ISINT(p->headblock.vtype) )
+               ioset(TYIOINT, XRECLEN, cpexpr(p) );
+       else
+               err("bad recl");
+else
+       ioset(TYIOINT, XRECLEN, ICON(0) );
+
+iosetc(XSTATUS, V(IOSSTATUS));
+iosetc(XACCESS, V(IOSACCESS));
+iosetc(XFORMATTED, V(IOSFORM));
+iosetc(XBLANK, V(IOSBLANK));
+
+putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) ));
+}
+
+
+LOCAL dofclose()
+{
+register expptr p;
+
+if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+       {
+       ioset(TYIOINT, XUNIT, cpexpr(p) );
+       iosetc(XCLSTATUS, V(IOSSTATUS));
+       putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) );
+       }
+else
+       err("bad unit in close statement");
+}
+
+
+LOCAL dofinquire()
+{
+register expptr p;
+if(p = V(IOSUNIT))
+       {
+       if( V(IOSFILE) )
+               err("inquire by unit or by file, not both");
+       ioset(TYIOINT, XUNIT, cpexpr(p) );
+       }
+else if( ! V(IOSFILE) )
+       err("must inquire by unit or by file");
+iosetlc(IOSFILE, XFILE, XFILELEN);
+iosetip(IOSEXISTS, XEXISTS);
+iosetip(IOSOPENED, XOPEN);
+iosetip(IOSNUMBER, XNUMBER);
+iosetip(IOSNAMED, XNAMED);
+iosetlc(IOSNAME, XNAME, XNAMELEN);
+iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
+iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
+iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
+iosetlc(IOSFORM, XFORM, XFORMLEN);
+iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
+iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
+iosetip(IOSRECL, XQRECL);
+iosetip(IOSNEXTREC, XNEXTREC);
+iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
+
+putiocall( call1(TYINT,  "f_inqu", cpexpr(ioblkp) ));
+}
+
+
+
+LOCAL dofmove(subname)
+char *subname;
+{
+register expptr p;
+
+if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+       {
+       ioset(TYIOINT, XUNIT, cpexpr(p) );
+       putiocall( call1(TYINT, subname, cpexpr(ioblkp) ));
+       }
+else
+       err("bad unit in I/O motion statement");
+}
+
+
+
+LOCAL ioset(type, offset, p)
+int type, offset;
+expptr p;
+{
+register struct Addrblock *q;
+
+q = cpexpr(ioblkp);
+q->vtype = type;
+q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) );
+puteq(q, p);
+}
+
+
+
+
+LOCAL iosetc(offset, p)
+int offset;
+register expptr p;
+{
+if(p == NULL)
+       ioset(TYADDR, offset, ICON(0) );
+else if(p->headblock.vtype == TYCHAR)
+       ioset(TYADDR, offset, addrof(cpexpr(p) ));
+else
+       err("non-character control clause");
+}
+
+
+
+LOCAL iosetip(i, offset)
+int i, offset;
+{
+register expptr p;
+
+if(p = V(i))
+       if(p->headblock.tag==TADDR &&
+           ONEOF(p->addrblock.vtype, M(TYLONG)|M(TYLOGICAL)) )
+               ioset(TYADDR, offset, addrof(cpexpr(p)) );
+       else
+               errstr("impossible inquire parameter %s", ioc[i].iocname);
+else
+       ioset(TYADDR, offset, ICON(0) );
+}
+
+
+
+LOCAL iosetlc(i, offp, offl)
+int i, offp, offl;
+{
+register expptr p;
+if( (p = V(i)) && p->headblock.vtype==TYCHAR)
+       ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
+iosetc(offp, p);
+}

diff --git a/usr/src/lib/libI77uc/lio.h b/usr/src/lib/libI77uc/lio.h
new file mode 100644 (file)
index 0000000..16731a9
--- /dev/null
+++ b/usr/src/lib/libI77uc/lio.h
@@ -0,0 +1,58 @@
+/*     copy of ftypes from the compiler */
+/* variable types
+ * numeric assumptions:
+ *     int < reals < complexes
+ *     TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
+ */
+
+#define TYUNKNOWN 0
+#define TYADDR 1
+#define TYSHORT 2
+#define TYLONG 3
+#define TYREAL 4
+#define TYDREAL 5
+#define TYCOMPLEX 6
+#define TYDCOMPLEX 7
+#define TYLOGICAL 8
+#define TYCHAR 9
+#define TYSUBR 10
+#define TYERROR 11
+
+#define NTYPES (TYERROR+1)
+ 
+#define        LINE    80
+#define LINTW  (strlen(buf))
+#define        LLOGW   3
+#define LSTRW  (len+2)
+#define        LLOW    1.0e-1
+#define        LHIGH   1.0e+LFD
+#define LDHIGH 1.0e+LDFD
+#define        LFD     6
+#define        LFW     (LFD+4)
+#define LDFD   14
+#define LDFW   (LDFD+4)
+#define        LED     LFD
+#define        LEW     LFW+4
+#define        LEE     2
+#define LDED   LDFD
+#define LDEW   LDFW+4
+#define LDEE   2
+#define LCW    (width(a)+width(b)+5)
+#define LDCW   (dwidth(a)+dwidth(b)+5)
+
+#define abs(z) (z<0?-z:z)
+#define width(z) ((z!=0.0 && (abs(z)>=LHIGH || abs(z)<LLOW))?LEW:LFW)
+#define dwidth(z) ((z!=0.0 && (abs(z)>=LDHIGH || abs(z)<LLOW))?LDEW:LDFW)
+#define ERR(x) if(n=(x)) err(n>0?errflag:endflag,n,"list io")
+
+typedef union
+{      short   flshort;
+       ftnint  flint;
+       float   flreal;
+       double  fldouble;
+} flex;
+
+extern int (*lioproc)();
+extern flag leof;
+extern ioflag lquit,l_first;
+extern int lcount,line_len;

diff --git a/usr/src/lib/libI77uc/lwrite.c b/usr/src/lib/libI77uc/lwrite.c
new file mode 100644 (file)
index 0000000..b31badb
--- /dev/null
+++ b/usr/src/lib/libI77uc/lwrite.c
@@ -0,0 +1,188 @@
+/*
+ * list directed write
+ */
+
+#include "fio.h"
+#include "lio.h"
+
+int l_write(), t_putc();
+
+s_wsle(a) cilist *a;
+{
+       int n;
+       reading = NO;
+       if(n=c_le(a,WRITE)) return(n);
+       putn = t_putc;
+       lioproc = l_write;
+       line_len = LINE;
+       curunit->uend = NO;
+       leof = NO;
+       if(!curunit->uwrt) nowwriting(curunit);
+       return(OK);
+}
+
+t_putc(c) char c;
+{
+       if(c=='\n') recpos=0;
+       else recpos++;
+       putc(c,cf);
+       return(OK);
+}
+
+e_wsle()
+{      int n;
+       PUT('\n')
+       return(OK);
+}
+
+l_write(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len;
+{
+       int i,n;
+       ftnint x;
+       float y,z;
+       double yd,zd;
+       float *xx;
+       double *yy;
+       for(i=0;i< *number; i++)
+       {
+               switch((int)type)
+               {
+               case TYSHORT:
+                       x=ptr->flshort;
+                       goto xint;
+               case TYLONG:
+                       x=ptr->flint;
+       xint:           ERR(lwrt_I(x));
+                       break;
+               case TYREAL:
+                       ERR(lwrt_F(ptr->flreal));
+                       break;
+               case TYDREAL:
+                       ERR(lwrt_D(ptr->fldouble));
+                       break;
+               case TYCOMPLEX:
+                       xx= &(ptr->flreal);
+                       y = *xx++;
+                       z = *xx;
+                       ERR(lwrt_C(y,z));
+                       break;
+               case TYDCOMPLEX:
+                       yy = &(ptr->fldouble);
+                       yd= *yy++;
+                       zd = *yy;
+                       ERR(lwrt_DC(yd,zd));
+                       break;
+               case TYLOGICAL:
+                       ERR(lwrt_L(ptr->flint));
+                       break;
+               case TYCHAR:
+                       ERR(lwrt_A((char *)ptr,len));
+                       break;
+               default:
+                       fatal(119,"unknown type in lwrite");
+               }
+               ptr = (char *)ptr + len;
+       }
+       return(OK);
+}
+
+lwrt_I(in) ftnint in;
+{      int n;
+       char buf[16],*p;
+       sprintf(buf,"  %ld",(long)in);
+       if(n=chk_len(LINTW)) return(n);
+       for(p=buf;*p;) PUT(*p++)
+       return(OK);
+}
+
+lwrt_L(ln) ftnint ln;
+{      int n;
+       if(n=chk_len(LLOGW)) return(n);
+       return(wrt_L(&ln,LLOGW));
+}
+
+lwrt_A(p,len) char *p; ftnlen len;
+{      int i,n;
+       if(n=chk_len(LSTRW)) return(n);
+       PUT(' ')
+       PUT(' ')
+       for(i=0;i<len;i++) PUT(*p++)
+       return(OK);
+}
+
+lwrt_F(fn) float fn;
+{      int d,n; float x; ufloat f;
+       if(fn==0.0) return(lwrt_0());
+       f.pf = fn;
+       d = width(fn);
+       if(n=chk_len(d)) return(n);
+       if(d==LFW)
+       {
+               scale = 0;
+               for(d=LFD,x=abs(fn);x>=1.0;x/=10.0,d--);
+               return(wrt_F(&f,LFW,d,(ftnlen)sizeof(float)));
+       }
+       else
+       {
+               scale = 1;
+               return(wrt_E(&f,LEW,LED-scale,LEE,(ftnlen)sizeof(float)));
+       }
+}
+
+lwrt_D(dn) double dn;
+{      int d,n; double x; ufloat f;
+       if(dn==0.0) return(lwrt_0());
+       f.pd = dn;
+       d = dwidth(dn);
+       if(n=chk_len(d)) return(n);
+       if(d==LDFW)
+       {
+               scale = 0;
+               for(d=LDFD,x=abs(dn);x>=1.0;x/=10.0,d--);
+               return(wrt_F(&f,LDFW,d,(ftnlen)sizeof(double)));
+       }
+       else
+       {
+               scale = 1;
+               return(wrt_E(&f,LDEW,LDED-scale,LDEE,(ftnlen)sizeof(double)));
+       }
+}
+
+lwrt_C(a,b) float a,b;
+{      int n;
+       if(n=chk_len(LCW)) return(n);
+       PUT(' ')
+       PUT(' ')
+       PUT('(')
+       if(n=lwrt_F(a)) return(n);
+       PUT(',')
+       if(n=lwrt_F(b)) return(n);
+       PUT(')')
+       return(OK);
+}
+
+lwrt_DC(a,b) double a,b;
+{      int n;
+       if(n=chk_len(LDCW)) return(n);
+       PUT(' ')
+       PUT(' ')
+       PUT('(')
+       if(n=lwrt_D(a)) return(n);
+       PUT(',')
+       if(n=lwrt_D(b)) return(n);
+       PUT(')')
+       return(OK);
+}
+
+lwrt_0()
+{      int n; char *z = "  0.";
+       if(n=chk_len(4)) return(n);
+       while(*z) PUT(*z++)
+       return(OK);
+}
+
+chk_len(w)
+{      int n;
+       if(recpos+w > line_len) PUT('\n')
+       return(OK);
+}

diff --git a/usr/src/lib/libI77uc/open.c b/usr/src/lib/libI77uc/open.c
new file mode 100644 (file)
index 0000000..c14dd14
--- /dev/null
+++ b/usr/src/lib/libI77uc/open.c
@@ -0,0 +1,133 @@
+/*
+ * open.c  -  f77 file open routines
+ */
+
+#include       <sys/types.h>
+#include       <sys/stat.h>
+#include       <errno.h>
+#include       "fio.h"
+
+#define SCRATCH        (st=='s')
+#define NEW    (st=='n')
+#define OLD    (st=='o')
+#define OPEN   (b->ufd)
+#define FROM_OPEN      "\1"    /* for use in f_clos() */
+
+extern char *tmplate;
+extern char *fortfile;
+
+f_open(a) olist *a;
+{      unit *b;
+       int n,exists;
+       char buf[256],st;
+       cllist x;
+
+       lfname = NULL;
+       elist = NO;
+       external = YES;                 /* for err */
+       errflag = a->oerr;
+       lunit = a->ounit;
+       if(not_legal(lunit)) err(errflag,101,"open")
+       b= &units[lunit];
+       if(a->osta) st = lcase(*a->osta);
+       else st = 'u';
+       if(SCRATCH)
+       {       strcpy(buf,tmplate);
+               mktemp(buf);
+       }
+       else if(a->ofnm) g_char(a->ofnm,a->ofnmlen,buf);
+       else sprintf(buf,fortfile,lunit);
+       lfname = &buf[0];
+       if(OPEN)
+       {
+               if(!a->ofnm || inode(buf)==b->uinode)
+               {
+                       if(a->oblnk) b->ublnk= (lcase(*a->oblnk)== 'z');
+#ifndef KOSHER
+                       if(a->ofm && b->ufmt) b->uprnt = (lcase(*a->ofm)== 'p');
+#endif
+                       return(OK);
+               }
+               x.cunit=lunit;
+               x.csta=FROM_OPEN;
+               x.cerr=errflag;
+               if(n=f_clos(&x)) return(n);
+       }
+       exists = (access(buf,0)==NULL);
+       if(!exists && OLD) err(errflag,118,"open");
+       if( exists && NEW) err(errflag,117,"open");
+       if(isdev(buf))
+       {       if((b->ufd = fopen(buf,"r")) != NULL) b->uwrt = NO;
+               else    err(errflag,errno,buf)
+       }
+       else
+       {       if((b->ufd = fopen(buf, "a")) != NULL) b->uwrt = YES;
+               else if((b->ufd = fopen(buf, "r")) != NULL)
+               {       fseek(b->ufd, 0L, 2);
+                       b->uwrt = NO;
+               }
+               else    err(errflag, errno, buf)
+       }
+       if((b->uinode=finode(b->ufd))==-1) err(errflag,108,"open")
+       b->ufnm = (char *) calloc(strlen(buf)+1,sizeof(char));
+       if(b->ufnm==NULL) err(errflag,113,"open")
+       strcpy(b->ufnm,buf);
+       b->uscrtch = SCRATCH;
+       b->uend = NO;
+       b->useek = canseek(b->ufd);
+       b->url = a->orl;
+       b->ublnk = (a->oblnk && (lcase(*a->oblnk)=='z'));
+       if (a->ofm)
+       {
+               switch(lcase(*a->ofm))
+               {
+               case 'f':
+                       b->ufmt = YES;
+                       b->uprnt = NO;
+                       break;
+#ifndef KOSHER
+               case 'p':       /* print file *** NOT STANDARD FORTRAN ***/
+                       b->ufmt = YES;
+                       b->uprnt = YES;
+                       break;
+#endif
+               case 'u':
+                       b->ufmt = NO;
+                       b->uprnt = NO;
+                       break;
+               default:
+                       err(errflag,121,"open form=")
+               }
+       }
+       else    /* not specified */
+       {       b->ufmt = (b->url==0);
+               b->uprnt = NO;
+       }
+       if(b->url && b->useek) rewind(b->ufd);
+       return(OK);
+}
+
+fk_open(rd,seq,fmt,n) ftnint n;
+{      char nbuf[10];
+       olist a;
+       sprintf(nbuf, fortfile, (int)n);
+       a.oerr=errflag;
+       a.ounit=n;
+       a.ofnm=nbuf;
+       a.ofnmlen=strlen(nbuf);
+       a.osta=NULL;
+       a.oacc= seq==SEQ?"s":"d";
+       a.ofm = fmt==FMT?"f":"u";
+       a.orl = seq==DIR?1:0;
+       a.oblnk=NULL;
+       return(f_open(&a));
+}
+
+isdev(s) char *s;
+{      struct stat x;
+       int j;
+       if(stat(s, &x) == -1) return(NO);
+       if((j = (x.st_mode&S_IFMT)) == S_IFREG || j == S_IFDIR) return(NO);
+       else    return(YES);
+}
+

diff --git a/usr/src/lib/libI77uc/rdfmt.c b/usr/src/lib/libI77uc/rdfmt.c
new file mode 100644 (file)
index 0000000..3ef94f2
--- /dev/null
+++ b/usr/src/lib/libI77uc/rdfmt.c
@@ -0,0 +1,251 @@
+/*
+ * formatted read routines
+ */
+
+#include "fio.h"
+#include "fmt.h"
+
+#define isdigit(c)     (c>='0' && c<='9')
+#define isalpha(c)     (c>='a' && c<='z')
+
+rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
+{      int n;
+       if(cursor && (n=rd_mvcur())) return(n);
+       switch(p->op)
+       {
+       case I:
+       case IM:
+               n = (rd_I(ptr,p->p1,len));
+               break;
+       case L:
+               n = (rd_L(ptr,p->p1));
+               break;
+       case A:
+               p->p1 = len;    /* cheap trick */
+       case AW:
+               n = (rd_AW(ptr,p->p1,len));
+               break;
+       case E:
+       case EE:
+       case D:
+       case DE:
+       case G:
+       case GE:
+       case F:
+               n = (rd_F(ptr,p->p1,p->p2,len));
+               break;
+       default:
+               return(errno=100);
+       }
+       if (n < 0)
+       {
+               if(feof(cf)) return(EOF);
+               n = errno;
+               clearerr(cf);
+       }
+       return(n);
+}
+
+rd_ned(p,ptr) char *ptr; struct syl *p;
+{
+       switch(p->op)
+       {
+/*     case APOS:
+/*             return(rd_POS(p->p1));
+/*     case H:
+/*             return(rd_H(p->p1,p->p2));      */
+       case SLASH:
+               return((*donewrec)());
+       case TR:
+       case X:
+               cursor += p->p1;
+               tab = (p->op==TR);
+               return(OK);
+       case T:
+               if(p->p1) cursor = p->p1 - recpos - 1;
+#ifndef KOSHER
+               else cursor = 8*p->p2 - recpos%8;       /* NOT STANDARD FORT */
+#endif
+               tab = YES;
+               return(OK);
+       case TL:
+               cursor -= p->p1;
+               tab = YES;
+               return(OK);
+       default:
+               return(errno=100);
+       }
+}
+
+rd_mvcur()
+{      int n;
+       if(tab) return((*dotab)());
+       while(cursor--) if((n=(*getn)()) < 0) return(n);
+       return(cursor=0);
+}
+
+rd_I(n,w,len) ftnlen len; uint *n;
+{      long x=0;
+       int i,sign=0,ch,c;
+       for(i=0;i<w;i++)
+       {
+               if((ch=(*getn)())<0) return(ch);
+               switch(ch=lcase(ch))
+               {
+               case ',': goto done;
+               case '+': break;
+               case '-':
+                       sign=1;
+                       break;
+               case ' ':
+                       if(cblank) x *= radix;
+                       break;
+               case '\n':  goto done;
+               default:
+                       if(isdigit(ch))
+                       {       if ((c=(ch-'0')) < radix)
+                               {       x = (x * radix) + c;
+                                       break;
+                               }
+                       }
+                       else if(isalpha(ch))
+                       {       if ((c=(ch-'a'+10)) < radix)
+                               {       x = (x * radix) + c;
+                                       break;
+                               }
+                       }
+                       return(errno=115);
+               }
+       }
+done:
+       if(sign) x = -x;
+       if(len==sizeof(short)) n->is=x;
+       else n->il=x;
+       return(OK);
+}
+
+rd_L(n,w) ftnint *n;
+{      int ch,i,v = -1;
+       for(i=0;i<w;i++)
+       {       if((ch=(*getn)()) < 0) return(ch);
+               if((ch=lcase(ch))=='t' && v==-1) v=1;
+               else if(ch=='f' && v==-1) v=0;
+               else if(ch==',') break;
+       }
+       if(v==-1) return(errno=116);
+       *n=v;
+       return(OK);
+}
+
+rd_F(p,w,d,len) ftnlen len; ufloat *p;
+{      double x,y;
+       int i,sx,sz,ch,dot,ny,z,sawz;
+       x=y=0;
+       sawz=z=ny=dot=sx=sz=0;
+       for(i=0;i<w;)
+       {       i++;
+               if((ch=(*getn)())<0) return(ch);
+               ch=lcase(ch);
+               if(ch==' ' && !cblank || ch=='+') continue;
+               else if(ch=='-') sx=1;
+               else if(ch<='9' && ch>='0')
+                       x=10*x+ch-'0';
+               else if(ch=='e' || ch=='d' || ch=='.')
+                       break;
+               else if(cblank && ch==' ') x*=10;
+               else if(ch==',')
+               {       i=w;
+                       break;
+               }
+               else if(ch!='\n') return(errno=115);
+       }
+       if(ch=='.') dot=1;
+       while(i<w && ch!='e' && ch!='d' && ch!='+' && ch!='-')
+       {       i++;
+               if((ch=(*getn)())<0) return(ch);
+               ch = lcase(ch);
+               if(ch<='9' && ch>='0')
+                       y=10*y+ch-'0';
+               else if(cblank && ch==' ')
+                       y *= 10;
+               else if(ch==',') {i=w; break;}
+               else if(ch==' ') continue;
+               else continue;
+               ny++;
+       }
+       if(ch=='-') sz=1;
+       while(i<w)
+       {       i++;
+               sawz=1;
+               if((ch=(*getn)())<0) return(ch);
+               ch = lcase(ch);
+               if(ch=='-') sz=1;
+               else if(ch<='9' && ch>='0')
+                       z=10*z+ch-'0';
+               else if(cblank && ch==' ')
+                       z *= 10;
+               else if(ch==',') break;
+               else if(ch==' ') continue;
+               else if(ch=='+') continue;
+               else if(ch!='\n') return(errno=115);
+       }
+       if(!dot)
+               for(i=0;i<d;i++) x /= 10;
+       for(i=0;i<ny;i++) y /= 10;
+       x=x+y;
+       if(sz)
+               for(i=0;i<z;i++) x /=10;
+       else    for(i=0;i<z;i++) x *= 10;
+       if(sx) x = -x;
+       if(!sawz)
+       {
+               for(i=scale;i>0;i--) x /= 10;
+               for(i=scale;i<0;i++) x *= 10;
+       }
+       if(len==sizeof(float)) p->pf=x;
+       else p->pd=x;
+       return(OK);
+}
+
+rd_AW(p,w,len) char *p; ftnlen len;
+{      int i,ch;
+       if(w >= len)
+       {
+               for(i=0;i<w-len;i++) GET(ch);
+               for(i=0;i<len;i++)
+               {       GET(ch);
+                       *p++=VAL(ch);
+               }
+       }
+       else
+       {
+               for(i=0;i<w;i++)
+               {       GET(ch);
+                       *p++=VAL(ch);
+               }
+               for(i=0;i<len-w;i++) *p++=' ';
+       }
+       return(OK);
+}
+
+/* THIS IS NOT ALLOWED IN THE NEW STANDARD 'CAUSE IT'S WEIRD */
+/*rd_H(n,s) char *s;
+/*{    int i,ch;
+/*     for(i=0;i<n;i++)
+/*             if((ch=(*getn)())<0) return(ch);
+/*             else if(ch=='\n') for(;i<n;i++) *s++ = ' ';
+/*             else *s++ = ch;
+/*     return(OK);
+/*}
+*/
+/*rd_POS(s) char *s;
+/*{    char quote;
+/*     int ch;
+/*     quote= *s++;
+/*     for(;*s;s++)
+/*             if(*s==quote && *(s+1)!=quote) break;
+/*             else if((ch=(*getn)())<0) return(ch);
+/*             else *s = ch=='\n'?' ':ch;
+/*     return(OK);
+/*}
+*/

diff --git a/usr/src/lib/libI77uc/rewind.c b/usr/src/lib/libI77uc/rewind.c
new file mode 100644 (file)
index 0000000..450b13d
--- /dev/null
+++ b/usr/src/lib/libI77uc/rewind.c
@@ -0,0 +1,27 @@
+/*
+ * rewind.c  -  f77 file rewind
+ */
+
+#include "fio.h"
+
+f_rew(a) alist *a;
+{      int n;
+       unit *b;
+
+       lfname = NULL;
+       elist = NO;
+       external = YES;                 /* for err */
+       lunit = a->aunit;
+       errflag = a->aerr;
+       if(not_legal(lunit)) err(errflag,101,"rewind")
+       b = &units[lunit];
+       if(!b->ufd && (n=fk_open(READ,SEQ,FMT,(ftnint)lunit)) )
+               err(errflag,n,"rewind")
+       lfname = b->ufnm;
+       if(!b->useek) err(errflag,106,"rewind")
+       b->uend = NO;
+       if(b->uwrt)
+               if(n=t_runc(b,errflag)) return(n);
+       rewind(b->ufd);
+       return(OK);
+}

diff --git a/usr/src/lib/libI77uc/sfe.c b/usr/src/lib/libI77uc/sfe.c
new file mode 100644 (file)
index 0000000..f5366d8
--- /dev/null
+++ b/usr/src/lib/libI77uc/sfe.c
@@ -0,0 +1,192 @@
+/*
+ * sequential formatted external routines
+ */
+
+#include "fio.h"
+
+/*
+ * read sequential formatted external
+ */
+
+extern int rd_ed(),rd_ned();
+int x_rnew(),x_getc(),x_tab();
+
+s_rsfe(a) cilist *a; /* start */
+{      int n;
+       reading = YES;
+       if(n=c_sfe(a,READ)) return(n);
+       if(curunit->uwrt) nowreading(curunit);
+       getn= x_getc;
+       doed= rd_ed;
+       doned= rd_ned;
+       donewrec = dorevert = doend = x_rnew;
+       dotab = x_tab;
+       if(pars_f(fmtbuf)) err(errflag,100,"read sfe")
+       fmt_bg();
+       return(OK);
+}
+
+x_rnew()                       /* find next record */
+{      int ch;
+       if(!curunit->uend)
+               while((ch=getc(cf))!='\n' && ch!=EOF);
+       cursor=recpos=reclen=0;
+       return(OK);
+}
+
+x_getc()
+{      int ch;
+       if(curunit->uend) return(EOF);
+       if((ch=getc(cf))!=EOF && ch!='\n')
+       {       recpos++;
+               return(ch);
+       }
+       if(ch=='\n')
+       {       ungetc(ch,cf);
+               return(ch);
+       }
+       if(feof(cf)) curunit->uend = YES;
+       return(EOF);
+}
+
+e_rsfe()
+{      int n;
+       n=en_fio();
+       fmtbuf=NULL;
+       return(n);
+}
+
+c_sfe(a,flag) cilist *a; /* check */
+{      unit *p;
+       int n;
+       external=sequential=formatted=FORMATTED;
+       fmtbuf=a->cifmt;
+       lfname = NULL;
+       elist = NO;
+       errflag = a->cierr;
+       endflag = a->ciend;
+       lunit = a->ciunit;
+       if(not_legal(lunit)) err(errflag,101,"sfe");
+       curunit = p = &units[lunit];
+       if(!p->ufd && (n=fk_open(flag,SEQ,FMT,(ftnint)lunit)) )
+               err(errflag,n,"sfe")
+       cf = curunit->ufd;
+       elist = YES;
+       lfname = curunit->ufnm;
+       if(!p->ufmt) err(errflag,102,"sfe")
+       if(p->url) err(errflag,105,"sfe")
+       cursor=recpos=scale=reclen=0;
+       radix = 10;
+       signit = YES;
+       cblank = curunit->ublnk;
+       cplus = NO;
+       return(OK);
+}
+
+/*
+ * write sequential formatted external
+ */
+
+extern int w_ed(),w_ned();
+int x_putc(),pr_put(),x_wend(),x_wnew();
+ioflag new;
+
+s_wsfe(a) cilist *a;   /*start*/
+{      int n;
+       reading = NO;
+       if(n=c_sfe(a,WRITE)) return(n);
+       if(!curunit->uwrt) nowwriting(curunit);
+       curunit->uend = NO;
+       if (curunit->uprnt) putn = pr_put;
+       else putn = x_putc;
+       new = YES;
+       doed= w_ed;
+       doned= w_ned;
+       doend = x_wend;
+       dorevert = donewrec = x_wnew;
+       dotab = x_tab;
+       if(pars_f(fmtbuf)) err(errflag,100,"write sfe")
+       fmt_bg();
+       return(OK);
+}
+
+x_putc(c)
+{
+       if(c=='\n') recpos = reclen = cursor = 0;
+       else recpos++;
+       if (c) putc(c,cf);
+       return(OK);
+}
+
+pr_put(c)
+{
+       if(c=='\n')
+       {       new = YES;
+               recpos = reclen = cursor = 0;
+       }
+       else if(new)
+       {       new = NO;
+               if(c=='0') c = '\n';
+               else if(c=='1') c = '\f';
+               else return(OK);
+       }
+       else recpos++;
+       if (c) putc(c,cf);
+       return(OK);
+}
+
+x_tab()
+{      int n;
+       if(reclen < recpos) reclen = recpos;
+       if(curunit->useek)
+       {       if((recpos+cursor) < 0) return(107);
+               n = reclen - recpos;    /* distance to eor, n>=0 */
+               if((cursor-n) > 0)
+               {       fseek(cf,(long)n,1);  /* find current eor */
+                       recpos = reclen;
+                       cursor -= n;
+               }
+               else
+               {       fseek(cf,(long)cursor,1);  /* do not pass go */
+                       recpos += cursor;
+                       return(cursor=0);
+               }
+       }
+       else
+               if(cursor < 0) return(120);     /* cant go back */
+       while(cursor--)
+       {       if(reading)
+               {       n = (*getn)();
+                       if(n=='\n')
+                       {       (*ungetn)(n,cf);
+                               return(110);
+                       }
+                       if(n==EOF) return(EOF);
+               }
+               else    (*putn)(' ');   /* fill in the empty record */
+       }
+       return(cursor=0);
+}
+
+x_wnew()
+{
+       if(reclen>recpos) fseek(cf,(long)(reclen-recpos),1);
+       return((*putn)('\n'));
+}
+
+x_wend(last) char last;
+{
+       if(reclen>recpos) fseek(cf,(long)(reclen-recpos),1);
+       return((*putn)(last));
+}
+
+/*
+/*xw_rev()
+/*{
+/*     if(workdone) x_wSL();
+/*     return(workdone=0);
+/*}
+/*
+*/
+e_wsfe()
+{      return(e_rsfe()); }

diff --git a/usr/src/lib/libI77uc/sue.c b/usr/src/lib/libI77uc/sue.c
new file mode 100644 (file)
index 0000000..2831b4d
--- /dev/null
+++ b/usr/src/lib/libI77uc/sue.c
@@ -0,0 +1,77 @@
+/*
+ * sequential unformatted external read/write routines
+ */
+
+#include "fio.h"
+
+extern int reclen;
+long recloc;
+char *rsue = "read sue";
+char *sue = "sue";
+
+s_rsue(a) cilist *a;
+{
+       int n;
+       reading = YES;
+       if(n=c_sue(a,READ)) return(n);
+       if(curunit->uwrt) nowreading(curunit);
+       recpos = 0;
+       if(fread(&reclen,sizeof(int),1,cf) == 1) return(OK);
+       if(feof(cf))
+       {       curunit->uend = YES;
+               err(endflag, EOF, rsue)
+       }
+       clearerr(cf);
+       err(errflag, errno, rsue)
+}
+
+s_wsue(a) cilist *a;
+{
+       int n;
+       reading = NO;
+       if(n=c_sue(a,WRITE)) return(n);
+       if(!curunit->uwrt) nowwriting(curunit);
+       reclen = 0;
+       recloc=ftell(cf);
+       fseek(cf,(long)sizeof(int),1);
+       curunit->uend = NO;
+       return(OK);
+}
+
+c_sue(a,flag) cilist *a;
+{      int n;
+       external = sequential = YES;
+       formatted = NO;
+       lfname = NULL;
+       elist = NO;
+       errflag = a->cierr;
+       endflag = a->ciend;
+       lunit = a->ciunit;
+       if(not_legal(lunit)) err(errflag,101,sue)
+       curunit = &units[lunit];
+       if(!curunit->ufd && (n=fk_open(flag,SEQ,UNF,(ftnint)lunit)))
+               err(errflag,n,sue)
+       cf = curunit->ufd;
+       elist = YES;
+       lfname = curunit->ufnm;
+       if(curunit->ufmt) err(errflag,103,sue)
+       if(curunit->url) err(errflag,105,sue)
+       if(!curunit->useek) err(errflag,120,sue)
+       return(OK);
+}
+
+e_wsue()
+{      long loc;
+       fwrite(&reclen,sizeof(int),1,cf);
+       loc=ftell(cf);
+       fseek(cf,recloc,0);
+       fwrite(&reclen,sizeof(int),1,cf);
+       fseek(cf,loc,0);
+       return(OK);
+}
+
+e_rsue()
+{
+       fseek(cf,(long)(reclen-recpos+sizeof(int)),1);
+       return(OK);
+}

diff --git a/usr/src/lib/libI77uc/util.c b/usr/src/lib/libI77uc/util.c
new file mode 100644 (file)
index 0000000..85cbc2a
--- /dev/null
+++ b/usr/src/lib/libI77uc/util.c
@@ -0,0 +1,82 @@
+/*
+ * utility routines
+ */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include "fio.h"
+
+
+ini_std(u,F,w) FILE *F;
+{      unit *p;
+       p = &units[u];
+       p->ufd = F;
+       p->ufnm = NULL;
+       p->useek = canseek(F);
+       p->ufmt = YES;
+       p->uwrt = (w==WRITE)? YES : NO;
+       p->ublnk = p->uscrtch = p->uprnt = p->uend = NO;
+       p->url = 0;
+       p->uinode = finode(F);
+}
+
+canseek(f) FILE *f; /*SYSDEP*/
+{      struct stat x;
+       return( (fstat(fileno(f),&x)==0) &&
+       (x.st_nlink > 0 /*!pipe*/) && !isatty(fileno(f)) );
+}
+
+nowreading(x) unit *x;
+{
+       long loc;
+       x->uwrt = NO;
+       loc=ftell(x->ufd);
+       freopen(x->ufnm,"r",x->ufd);
+       fseek(x->ufd,loc,0);
+}
+
+nowwriting(x) unit *x;
+{
+       long loc;
+       x->uwrt = YES;
+       loc=ftell(x->ufd);
+       freopen(x->ufnm,"a",x->ufd);
+       fseek(x->ufd,loc,0);
+}
+
+g_char(a,alen,b) char *a,*b; ftnlen alen;
+{      char *x=a+alen-1, *y=b+alen-1;
+       while (x >= a  &&  *x == ' ') {x--; y--;}
+       *(y+1) = '\0';
+       while (x >= a) *y-- = *x--;
+}
+
+b_char(from, to, tolen) char *from, *to; ftnlen tolen;
+{      int i=0;
+       while (*from && i < tolen) {
+               *to++ = *from++;
+               i++;
+       }
+       while (i++ < tolen)
+               *to++ = ' ';
+}
+
+inode(a) char *a;
+{      struct stat x;
+       if(stat(a,&x)==0) return(x.st_ino);
+       else return(-1);
+}
+
+finode(f) FILE *f;
+{      struct stat x;
+       if(fstat(fileno(f),&x)==0) return(x.st_ino);
+       else return(-1);
+}
+
+char
+last_char(f) FILE *f;
+{
+       fseek(f,-2L,1);
+       if(ftell(f)) return(getc(f));
+       else return('\n');
+}

diff --git a/usr/src/lib/libI77uc/writeup.tx b/usr/src/lib/libI77uc/writeup.tx
new file mode 100644 (file)
index 0000000..cc9f288
--- /dev/null
+++ b/usr/src/lib/libI77uc/writeup.tx
@@ -0,0 +1,395 @@
+.ND
+.nr ll 7.0i
+.nr LL 7.0i
+.TL
+Update to the f77 I/O Library
+ September 1980
+.AU
+David L. Wasley
+.AI
+University of California
+ Berkeley, Calif. 94720
+.PP
+The fortran-77 I/O library, libI77.a,
+performs all the various types of formatted and unformatted FORTRAN
+input and output.
+I/O error reporting is generated by these routines.
+Several non-standard extensions to FORTRAN I/O have been added.
+These routines use the C stdio library for it's efficient buffering scheme.
+.PP
+Some general concepts regarding f77 I/O deserve clarification. There are three
+forms of I/O: formatted, unformatted, and list-directed. The last is
+related to formatted but does not obey all the rules for formatted I/O.
+There are two modes of access to external and internal files: direct
+and sequential. The definition of a logical record depends upon the
+combination of I/O form and mode specified by the fortran I/O statement.
+.PP
+A logical record in direct access external files is a string of bytes
+of a length specified when the file is opened.
+Read and write statements must not specify logical records longer than
+the original record size definition. Shorter logical records are allowed.
+Unformatted direct writes leave the unfilled part of the record undefined.
+Formatted direct writes cause the unfilled record to be padded with blanks.
+.PP
+Logical records in sequentially accessed external files may be of arbitrary
+and variable length.
+Logical record length for unformatted sequential files is determined by
+the size of items in the iolist.
+For formatted write statements, logical record length is determined by
+the format statement interacting with the iolist at execution time.
+Formatted sequential access causes one or more logical records
+ending with newline characters to be read or written.
+.PP
+Logical record length for list-directed I/O is relatively meaningless.
+On output, the record length is dependent on the magnitude of the
+data items.
+On input, the record length is determined by the data types and the file
+contents.
+An input record will be terminated by the occurance of a slash, ``/'',
+that is not part of a character string datum,
+and any input list items that have not been read will remain unchanged.
+If the input list is exhausted, the input stream is flushed
+until the next occurance of either a slash, or a newline (or end-of-file).
+.PP
+The logical record length for "internal" files is the length of the
+character variable or array element. Thus a simple character variable
+is a single logical record. A character variable array is similar to
+a fixed length direct access file, and obeys the same rules.
+Unformatted I/O is not allowed on "internal" files.
+.PP
+Note that each execution of a fortran unformatted I/O statement causes a single
+logical record to be read or written. Each execution of a fortran formatted
+I/O statement causes one or more logical records to be read or written.
+.PP
+Any error detected during I/O processing will cause the program to abort
+unless alternate action has been provided for specifically in the program.
+Any I/O statement may include an err= clause (and iostat= clause)
+to specify an
+alternate branch to be taken on errors (and return the specific error code).
+Read or write statements may include end= to branch on end-of-file.
+File position and the value of I/O list items is undefined following an error.
+
+I. Implementation details.
+.PP
+The maximum number of logical units that a program may have open at one
+time has been set to correspond with the UNIX system limit, currently 20.
+However, the I/O library uses UNIX file access for internal purposes.
+Therefore fatal errors are possible if the maximum number of files are open.
+Specifically, 'close' or 'endfile' on an old file,
+and "'inquire' by file" may fail.
+.PP
+Vertical format control is implemented. The logical unit must be opened
+for sequential access and "form = 'print'" (see below).
+Control codes '0' and '1' are replaced in the output file
+with '\\n' and '\\f' respectively.
+The control character '+' isn't implemented and, like
+any other character in the first position of a record
+written to a "print" file, is dropped.
+No vertical format control is recognized for direct formatted output
+or list directed output.
+.PP
+Default logical units 0, 5, and 6 can be re-defined with an 'open' statement.
+To preserve error reporting, it is an error to close logical unit 0.
+If you want to open the default filename for any preconnected logical unit,
+remember to 'close' the unit first.
+Redefining the standard units may impair normal console I/O.
+An alternative is to
+use shell re-direction to externally re-define the above units.
+To re-define default blank control or format of the standard input or output
+files, use the 'open' statement specifying the unit number and no
+filename (see below).
+.PP
+An 'open' statement need not specify a filename. If it refers to a logical
+unit that is already open, the "blank= " and "form= " specifiers may be
+redefined without affecting the current file position.
+Otherwise, if "status='scratch'" is specified, a temporary file with a
+name of the form 'tmp.FXXXXXX' will be opened,
+and, by default, will be deleted when closed or during
+termination of program execution.
+Any other "status= " specifier without an associated filename results in
+opening a file named 'fort.N' where N is the specified logical unit number.
+It is an error to try to open an existing file with "status='new'".
+It is an error to try to open a nonexistent file with "status='old'".
+By default "status='unknown'" will be assumed, and a file will be created
+if necessary.
+Existing files are never truncated on opening but are positioned
+at the end-of-file.
+.PP
+Sequentially accessed external files are truncated to the current file
+position on 'close', 'backspace', or 'rewind' only if the last
+access to the file was a write.
+.PP
+Upper as well as lower case characters are recognized in format statements
+and all alphabetic arguments to the I/O library routines.
+This has always been true for statements that are
+part of the source code, but not for format statements
+or character arguments from a file.
+.PP
+If the external representation of a datum
+is too large for the field width specified, the specified
+field is filled with asterisks (*).
+On 'Ew.dEe' output, the e field will be filled with asterisks if the
+exponent representation is too large.
+(This will only happen if e==0)
+.PP
+List-directed output of complex values now includes an appropriate comma.
+List-directed output now distinguishes between real*4 and real*8 values
+and formats them differently.
+Output of a character string that includes '\\n' now works correctly.
+.PP
+If I/O errors are not trapped by the user's program an appropriate
+error message will be written to 'stderr' before aborting.
+An error number will be printed in [ ] along with a brief error message
+showing the logical unit and I/O state.
+Error numbers < 100 refer to UNIX errors, and are described in the
+introduction to chapter 2 of the UNIX Programmer's Manual.
+Error numbers >= 100 come from the I/O library, and are described
+further in the appendix to this writeup.
+For internal I/O, part of the string will be printed with '|' at the
+current position in the string.
+For external I/O, part of the current record will be displayed if
+the error was caused during reading from a file that can backspace.
+.PP
+Direct access list-directed I/O is not allowed.
+Unformatted internal I/O is not allowed.
+Both the above will be caught by the compiler.
+All other flavors of I/O are allowed, although some are not part of the ANSI
+standard.
+.PP
+The standard units, 0, 5, and 6, are now named internally 'stderr', 'stdin',
+and 'stdout' respectively.
+These are not actual filenames and can not be used for opening these units.
+\'inquire' will not return these names and will indicate
+that the above units are not named unless they have been opened to real files.
+The names are meant to make error reporting more meaningful.
+.PP
+On output, a real value that is truly zero will display as '0.' to
+distinguish it from a very small non-zero value.
+This occurs in 'F', 'E', 'D', and 'G' format conversions.
+.PP
+Non-destructive tabbing is implemented for both internal and external
+formatted I/O.
+Tabbing left or right on output
+does not affect previously written portions of a record.
+Tabbing right on output
+causes unwritten portions of a record to be filled with blanks.
+Tabbing left or right off the end of a logical record is an error.
+The format specifier 'T' must be followed by a positive non-zero number.
+If it is not, it will have a different meaning (See below).
+Note that spacing with 'X' always writes blanks in the output record.
+
+II. Non-"ANSI Standard" Extensions
+.PP
+B is an acceptable edit control specifier. It causes return to the
+default mode of blank interpretation (NULL) and is identical to BN.
+This is consistent with S which returns to default sign control.
+.PP
+P by itself is equivalent to 0P. It resets the scale factor to the
+default value, 0.
+.PP
+The form of the 'Ew.dEe' format specifier has been extended to 'D' also.
+The form 'Ew.d.e' is allowed but is not standard.
+The 'e' field specifies the minimum number of digits or spaces in the
+exponent field on output.
+If the value of the exponent is too large, the exponent notation 'e'
+or 'd' will be dropped from the output to allow one
+more character position.
+If this is still not adequate, the 'e' field will be filled with
+asterisks (*). The default value for 'e' is 2.
+.PP
+An additional form of tab control specification has been added.
+The ANSI standard forms 'TRn', 'TLn', and 'Tn' are supported where n is
+a positive non-zero number. If 'T' or 'nT' is specified, tabbing will
+be to the next (or n-th) 8-column tab stop.
+Thus columns of alphanumerics can be lined up without counting.
+(See above for a description of the tabbing implementation.)
+.PP
+A format control specifier has been added to suppress the newline
+at the end of the last record of a formatted sequential write. The
+specifier is a dollar sign ($). It is constrained by the same rules
+as the colon (:). It is used typically for console prompts.
+For example:
+
+.DS
+write (*, "('enter value for x: ',$)")
+read (*,*) x
+.DE
+.PP
+Radices other than 10 can be specified for formatted integer I/O
+conversion. The specifier is patterned after P, the pre-scale factor for
+floating point conversion. It remains in effect until another radix is
+specified or format interpretation is complete. The specifier is defined
+as [n]R where 2 <= n <= 36. If n is omitted,
+the default decimal radix is restored.
+.PP
+In conjunction with the above, a sign control specifier has been added
+to cause integer values to be interpreted as unsigned during output
+conversion. The specifier is SU and remains in effect until another
+sign control specifier is encountered, or format interpretation is
+complete. Radix and 'unsigned' specifiers could be used to format
+a hexadecimal dump, as follows:
+
+.DS
+2000   format( SU, 16R, 8I10.8)
+.DE
+
+Note: Unsigned integer values greater than (2**30 - 1),
+i.e. any signed negative value, can not be read by FORTRAN input routines.
+All internal values will be output correctly.
+.PP
+The ANSI standard is ambiguous regarding the definition of a "print" file.
+Since UNIX has no default "print" file, an additional 'form' specifier
+is now recognized in the 'open' statement.
+Specifying "form='print'" implies 'formatted' and enables vertical format
+control for that logical unit (see above).
+Vertical format control is interpreted only on sequential formatted writes
+to a "print" file.
+.PP
+The 'inquire' statement will return 'print' in the 'FORM=' string variable
+for logical units opened as "print" files.
+It will return -1 for the unit number of an unconnected file.
+.PP
+If a logical unit is already open, an 'open' statement including the
+'form=' option or the 'blank=' option will do nothing but
+re-define those options.
+This instance of the 'open' statement need not include the filename, and
+must not include a filename if 'unit=' refers to the standard input or outputs.
+Therefore, to re-define the standard output as a "print" file, use:
+
+.DS
+open (unit=6, form='print')
+.DE
+.PP
+In a 'close' statement, "status='keep'" may be specified for temporary files.
+This is the default for all other files.
+Remember to get the file's real name,
+using 'inquire', if you want to re-open it later.
+.PP
+List directed read has been modified to allow input of a string not enclosed
+in quotes. The string must not start with a digit, and can not contain a
+separator (, or /) or blank (space or tab). A newline will terminate the
+string unless escaped with \\. Any string not meeting the above restrictions
+must be enclosed in quotes (" or ').
+.PP
+Internal list-directed I/O has been implemented. During internal list reads,
+bytes are consummed until the iolist is satisfied, or the 'end-of-file'
+is reached.
+During internal list writes, records are filled until the iolist is satisfied.
+The length of an internal array element should be at least 20 bytes to
+avoid logical record overflow when writing double precision values.
+Internal list read was implemented to make command line decoding easier.
+Internal list write should be avoided.
+.bp
+.ce 2
+Appendix A
+I/O Library Error Messages
+.PP
+The following error messages are generated by the I/O library.
+The error numbers are returned in the "iostat=" variable if the "err="
+return is taken. Error numbers < 100 are generated by UNIX. See the
+UNIX Programmers Manual, introduction to chapter 2.
+.DS
+/* 100 */      "error in format"
+               See error message output for the location
+               of the error in the format. Can be caused
+               by more than 10 levels of nested (), or
+               an extremely long format statement.
+
+/* 101 */      "illegal unit number"
+               It is illegal to close logical unit 0.
+               Negative unit numbers are not allowed.
+               The upper limit is system dependent.
+
+/* 102 */      "formatted io not allowed"
+               The logical unit was opened for
+               unformatted I/O.
+
+/* 103 */      "unformatted io not allowed"
+               The logical unit was opened for
+               formatted I/O.
+
+/* 104 */      "direct io not allowed"
+               The logical unit was opened for sequential
+               access, or the logical record length was
+               specified as 0.
+
+/* 105 */      "sequential io not allowed"
+               The logical unit was opened for direct
+               access I/O.
+
+/* 106 */      "can't backspace file"
+               The file associated with the logical unit
+               can't seek. May be a device or a pipe.
+
+/* 107 */      "off beginning of record"
+               The format specified a left tab off the
+               beginning of the record.
+
+/* 108 */      "can't stat file"
+               The system can't return status information
+               about the file. Perhaps the directory is
+               unreadable.
+
+/* 109 */      "no * after repeat count"
+               Repeat counts in list-directed I/O must be
+               followed by an * with no blank spaces.
+
+.DE
+.DS
+/* 110 */      "off end of record"
+               A formatted write tried to go beyond the
+               logical end-of-record. An unformatted read
+               or write will also cause this.
+
+/* 111 */      "truncation failed"
+               The truncation of external sequential files
+               on 'close', 'backspace', or 'rewind' tries
+               to do a copy. It failed. Perhaps the temp
+               file couldn't be created.
+
+/* 112 */      "incomprehensible list input"
+               List input has to be just right.
+
+/* 113 */      "out of free space"
+               The library dynamically creates buffers for
+               internal use. You ran out of memory for this.
+               Your program is too big!
+
+/* 114 */      "unit not connected"
+               The logical unit was not open.
+
+/* 115 */      "read unexpected character"
+               Certain format conversions can't tolerate
+               non-numeric data. Logical data must be
+               T or F.
+
+/* 116 */      "blank logical input field"
+
+/* 117 */      "'new' file exists"
+               You tried to open an existing file with
+               "status='new'".
+
+/* 118 */      "can't find 'old' file"
+               You tried to open a non-existent file
+               with "status='old'".
+
+/* 119 */      "unknown system error"
+               Shouldn't happen, but .....
+               (Send me a documented example.)
+
+/* 120 */      "requires seek ability"
+               Direct access requires seek ability.
+               Sequential unformatted I/O requires seek
+               ability on the file due to the special
+               data structure required. Tabbing left
+               also requires seek ability.
+
+/* 121 */      "illegal argument"
+               Certain arguments to 'open', etc. will be
+               checked for legitimacy. Often only non-
+               default forms are looked for.
+
+/* 122 */      "negative repeat count"
+               The repeat count on list directed input
+               must be a positive integer.
+.DE