summaryrefslogtreecommitdiffstats
path: root/usr.bin/f2c/io.c
diff options
context:
space:
mode:
Diffstat (limited to 'usr.bin/f2c/io.c')
-rw-r--r--usr.bin/f2c/io.c1420
1 files changed, 0 insertions, 1420 deletions
diff --git a/usr.bin/f2c/io.c b/usr.bin/f2c/io.c
deleted file mode 100644
index 761876c..0000000
--- a/usr.bin/f2c/io.c
+++ /dev/null
@@ -1,1420 +0,0 @@
-/****************************************************************
-Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore.
-
-Permission to use, copy, modify, and distribute this software
-and its documentation for any purpose and without fee is hereby
-granted, provided that the above copyright notice appear in all
-copies and that both that the copyright notice and this
-permission notice and warranty disclaimer appear in supporting
-documentation, and that the names of AT&T Bell Laboratories or
-Bellcore or any of their entities not be used in advertising or
-publicity pertaining to distribution of the software without
-specific, written prior permission.
-
-AT&T and Bellcore disclaim all warranties with regard to this
-software, including all implied warranties of merchantability
-and fitness. In no event shall AT&T or Bellcore be liable for
-any special, indirect or consequential damages or any damages
-whatsoever resulting from loss of use, data or profits, whether
-in an action of contract, negligence or other tortious action,
-arising out of or in connection with the use or performance of
-this software.
-****************************************************************/
-
-/* Routines to generate code for I/O statements.
- Some corrections and improvements due to David Wasley, U. C. Berkeley
-*/
-
-/* TEMPORARY */
-#define TYIOINT TYLONG
-#define SZIOINT SZLONG
-
-#include "defs.h"
-#include "names.h"
-#include "iob.h"
-
-extern int inqmask;
-
-LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(),
- doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(),
- putio(), putiocall();
-
-iob_data *iob_list;
-Addrp io_structs[9];
-
-LOCAL char ioroutine[12];
-
-LOCAL long ioendlab;
-LOCAL long ioerrlab;
-LOCAL int endbit;
-LOCAL int errbit;
-LOCAL long jumplab;
-LOCAL long skiplab;
-LOCAL int ioformatted;
-LOCAL int statstruct = NO;
-LOCAL struct Labelblock *skiplabel;
-Addrp ioblkp;
-
-#define UNFORMATTED 0
-#define FORMATTED 1
-#define LISTDIRECTED 2
-#define NAMEDIRECTED 3
-
-#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 },
- { "end", M(IOREAD) },
- { "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) },
- { "nml", M(IOREAD) | M(IOWRITE) }
-};
-
-#define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
-
-/* #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 IOSEXISTS 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 IOSNML 23
-
-#define IOSTP V(IOSIOSTAT)
-
-
-/* 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 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
-
-LOCAL char *cilist_names[] = {
- "cilist",
- "cierr",
- "ciunit",
- "ciend",
- "cifmt",
- "cirec"
- };
-LOCAL char *icilist_names[] = {
- "icilist",
- "icierr",
- "iciunit",
- "iciend",
- "icifmt",
- "icirlen",
- "icirnum"
- };
-LOCAL char *olist_names[] = {
- "olist",
- "oerr",
- "ounit",
- "ofnm",
- "ofnmlen",
- "osta",
- "oacc",
- "ofm",
- "orl",
- "oblnk"
- };
-LOCAL char *cllist_names[] = {
- "cllist",
- "cerr",
- "cunit",
- "csta"
- };
-LOCAL char *alist_names[] = {
- "alist",
- "aerr",
- "aunit"
- };
-LOCAL char *inlist_names[] = {
- "inlist",
- "inerr",
- "inunit",
- "infile",
- "infilen",
- "inex",
- "inopen",
- "innum",
- "innamed",
- "inname",
- "innamlen",
- "inacc",
- "inacclen",
- "inseq",
- "inseqlen",
- "indir",
- "indirlen",
- "infmt",
- "infmtlen",
- "inform",
- "informlen",
- "inunf",
- "inunflen",
- "inrecl",
- "innrec",
- "inblank",
- "inblanklen"
- };
-
-LOCAL char **io_fields;
-
-#define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
-
-LOCAL io_setup io_stuff[] = {
- zork(cilist_names, TYCILIST), /* external read/write */
- zork(inlist_names, TYINLIST), /* inquire */
- zork(olist_names, TYOLIST), /* open */
- zork(cllist_names, TYCLLIST), /* close */
- zork(alist_names, TYALIST), /* rewind */
- zork(alist_names, TYALIST), /* backspace */
- zork(alist_names, TYALIST), /* endfile */
- zork(icilist_names,TYICILIST), /* internal read */
- zork(icilist_names,TYICILIST) /* internal write */
- };
-
-#undef zork
-
-
-fmtstmt(lp)
-register struct Labelblock *lp;
-{
- if(lp == NULL)
- {
- execerr("unlabeled format statement" , CNULL);
- return(-1);
- }
- if(lp->labtype == LABUNKNOWN)
- {
- lp->labtype = LABFORMAT;
- lp->labelno = newlabel();
- }
- else if(lp->labtype != LABFORMAT)
- {
- execerr("bad format number", CNULL);
- return(-1);
- }
- return(lp->labelno);
-}
-
-
-setfmt(lp)
-struct Labelblock *lp;
-{
- int n;
- char *s0, *lexline();
- register char *s, *se, *t;
- register k;
-
- s0 = s = lexline(&n);
- se = t = s + n;
-
- /* warn of trivial errors, e.g. " 11 CONTINUE" (one too few spaces) */
- /* following FORMAT... */
-
- if (n <= 0)
- warn("No (...) after FORMAT");
- else if (*s != '(')
- warni("%c rather than ( after FORMAT", *s);
- else if (se[-1] != ')') {
- *se = 0;
- while(--t > s && *t != ')') ;
- if (t <= s)
- warn("No ) at end of FORMAT statement");
- else if (se - t > 30)
- warn1("Extraneous text at end of FORMAT: ...%s", se-12);
- else
- warn1("Extraneous text at end of FORMAT: %s", t+1);
- t = se;
- }
-
- /* fix MYQUOTES (\002's) and \\'s */
-
- while(s < se)
- switch(*s++) {
- case 2:
- t += 3; break;
- case '"':
- case '\\':
- t++; break;
- }
- s = s0;
- if (lp) {
- lp->fmtstring = t = mem((int)(t - s + 1), 0);
- while(s < se)
- switch(k = *s++) {
- case 2:
- t[0] = '\\';
- t[1] = '0';
- t[2] = '0';
- t[3] = '2';
- t += 4;
- break;
- case '"':
- case '\\':
- *t++ = '\\';
- /* no break */
- default:
- *t++ = k;
- }
- *t = 0;
- }
- flline();
-}
-
-
-
-startioctl()
-{
- register int i;
-
- inioctl = YES;
- nioctl = 0;
- ioformatted = UNFORMATTED;
- for(i = 1 ; i<=NIOS ; ++i)
- V(i) = NULL;
-}
-
- static long
-newiolabel() {
- long rv;
- rv = ++lastiolabno;
- skiplabel = mklabel(rv);
- skiplabel->labdefined = 1;
- return rv;
- }
-
-
-endioctl()
-{
- int i;
- expptr p;
- struct io_setup *ios;
-
- inioctl = NO;
-
- /* set up for error recovery */
-
- ioerrlab = ioendlab = skiplab = jumplab = 0;
-
- if(p = V(IOSEND))
- if(ISICON(p))
- execlab(ioendlab = p->constblock.Const.ci);
- else
- err("bad end= clause");
-
- if(p = V(IOSERR))
- if(ISICON(p))
- execlab(ioerrlab = p->constblock.Const.ci);
- else
- err("bad err= clause");
-
- if(IOSTP)
- if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
- {
- err("iostat must be an integer variable");
- frexpr(IOSTP);
- IOSTP = NULL;
- }
-
- if(iostmt == IOREAD)
- {
- if(IOSTP)
- {
- if(ioerrlab && ioendlab && ioerrlab==ioendlab)
- jumplab = ioerrlab;
- else
- skiplab = jumplab = newiolabel();
- }
- else {
- if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
- {
- IOSTP = (expptr) mktmp(TYINT, ENULL);
- skiplab = jumplab = newiolabel();
- }
- else
- jumplab = (ioerrlab ? ioerrlab : ioendlab);
- }
- }
- else if(iostmt == IOWRITE)
- {
- if(IOSTP && !ioerrlab)
- skiplab = jumplab = newiolabel();
- else
- jumplab = ioerrlab;
- }
- else
- jumplab = ioerrlab;
-
- endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */
- errbit = IOSTP!=NULL || ioerrlab!=0;
- if (jumplab && !IOSTP)
- IOSTP = (expptr) mktmp(TYINT, ENULL);
-
- if(iostmt!=IOREAD && iostmt!=IOWRITE)
- {
- ios = io_stuff + iostmt;
- io_fields = ios->fields;
- ioblkp = io_structs[iostmt];
- if(ioblkp == NULL)
- io_structs[iostmt] = ioblkp =
- autovar(1, ios->type, ENULL, "");
- ioset(TYIOINT, XERR, ICON(errbit));
- }
-
- 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(!strcmp(ioc[i].iocname, token))
- if(ioc[i].iotype & mask)
- return(i);
- else {
- found = i;
- break;
- }
- if(found) {
- if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) {
- NOEXT("open with \"name=\" treated as \"file=\"");
- for(i = 1; strcmp(ioc[i].iocname, "file"); i++);
- return i;
- }
- errstr("invalid control %s for statement", ioc[found].iocname);
- }
- else
- errstr("unknown iocontrol %s", token);
- return(IOSBAD);
-}
-
-
-ioclause(n, p)
-register int n;
-register expptr p;
-{
- struct Ioclist *iocp;
-
- ++nioctl;
- if(n == IOSBAD)
- return;
- if(n == IOSPOSITIONAL)
- {
- n = nioctl;
- if (n == IOSFMT) {
- if (iostmt == IOOPEN) {
- n = IOSFILE;
- NOEXT("file= specifier omitted from open");
- }
- else if (iostmt < IOREAD)
- goto illegal;
- }
- else if(n > IOSFMT)
- {
- illegal:
- err("illegal positional iocontrol");
- return;
- }
- }
- else if (n == IOSNML)
- n = IOSFMT;
-
- if(p == NULL)
- {
- if(n == IOSUNIT)
- p = (expptr) (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 && p->headblock.vtype!=TYCHAR) ) )
- p = fixtype(p);
- else if (p && p->tag == TPRIM
- && p->primblock.namep->vclass == CLUNKNOWN) {
- /* kludge made necessary by attempt to infer types
- * for untyped external parameters: given an error
- * in calling sequences, an integer argument might
- * tentatively be assumed TYCHAR; this would otherwise
- * be corrected too late in startrw after startrw
- * had decided this to be an internal file.
- */
- vardcl(p->primblock.namep);
- p->primblock.vtype = p->primblock.namep->vtype;
- }
- iocp->iocval = p;
- }
- else
- errstr("iocontrol %s repeated", iocp->iocname);
-}
-
-/* io list item */
-
-doio(list)
-chainp list;
-{
- expptr call0();
-
- if(ioformatted == NAMEDIRECTED)
- {
- if(list)
- err("no I/O list allowed in NAMELIST read/write");
- }
- else
- {
- doiolist(list);
- ioroutine[0] = 'e';
- if (skiplab || ioroutine[4] == 'l')
- jumplab = 0;
- putiocall( call0(TYINT, ioroutine) );
- }
-}
-
-
-
-
-
- LOCAL void
-doiolist(p0)
- chainp p0;
-{
- chainp p;
- register tagptr q;
- register expptr qe;
- register Namep qn;
- Addrp tp, mkscalar();
- int range;
- extern char *ohalign;
-
- for (p = p0 ; p ; p = p->nextp)
- {
- q = (tagptr)p->datap;
- if(q->tag == TIMPLDO)
- {
- exdo(range=newlabel(), (Namep)0,
- q->impldoblock.impdospec);
- doiolist(q->impldoblock.datalist);
- enddo(range);
- free( (charptr) q);
- }
- else {
- if(q->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)),
- (expptr)mkscalar(qn) );
- qn->vlastdim = 0;
- }
- else
- err("attempt to i/o array of unknown size");
- }
- else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
- (qe = (expptr) memversion(q->primblock.namep)) )
- putio(ICON(1),qe);
- else if (ISCONST(q) && q->constblock.vtype == TYCHAR) {
- halign = 0;
- putio(ICON(1), qe = fixtype(cpexpr(q)));
- halign = ohalign;
- }
- else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
- (qe->addrblock.uname_tag != UNAM_CONST ||
- !ISCOMPLEX(qe -> addrblock.vtype))) ||
- (qe -> tag == TCONST && !ISCOMPLEX(qe ->
- headblock.vtype))) {
- if (qe -> tag == TCONST)
- qe = (expptr) putconst((Constp)qe);
- putio(ICON(1), qe);
- }
- else if(qe->headblock.vtype != TYERROR)
- {
- if(iostmt == IOWRITE)
- {
- ftnint lencat();
- expptr qvl;
- qvl = NULL;
- if( ISCHAR(qe) )
- {
- qvl = (expptr)
- cpexpr(qe->headblock.vleng);
- tp = mktmp(qe->headblock.vtype,
- ICON(lencat(qe)));
- }
- else
- tp = mktmp(qe->headblock.vtype,
- qe->headblock.vleng);
- puteq( cpexpr((expptr)tp), qe);
- if(qvl) /* put right length on block */
- {
- frexpr(tp->vleng);
- tp->vleng = qvl;
- }
- putio(ICON(1), (expptr)tp);
- }
- else
- err("non-left side in READ list");
- }
- frexpr(q);
- }
- }
- frchain( &p0 );
-}
-
- int iocalladdr = TYADDR; /* for fixing TYADDR in saveargtypes */
- int typeconv[TYERROR+1] = {
-#ifdef TYQUAD
- 0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15
-#else
- 0, 1, 11, 2, 3, 4, 5, 6, 7, 12, 13, 8, 9, 10, 14
-#endif
- };
-
- LOCAL void
-putio(nelt, addr)
- expptr nelt;
- register expptr addr;
-{
- int type;
- register expptr q;
- register Addrp c = 0;
-
- 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 = (expptr) putconst((Constp)addr);
- c = ALLOC(Addrblock);
- c->tag = TADDR;
- c->vtype = TYLENG;
- c->vstg = STGAUTO;
- c->ntempelt = 1;
- c->isarray = 1;
- c->memoffset = ICON(0);
- c->uname_tag = UNAM_IDENT;
- c->charleng = 1;
- sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
- addr = mkexpr(OPCHARCAST, addr, ENULL);
- }
-
- nelt = fixtype( mkconv(tyioint,nelt) );
- if(ioformatted == LISTDIRECTED) {
- expptr mc = mkconv(tyioint, ICON(typeconv[type]));
- q = c ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
- : call3(TYINT, "do_lio", mc, nelt, addr);
- }
- else {
- char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
- q = c ? call3(TYINT, s, nelt, addr, (expptr)c)
- : call2(TYINT, s, nelt, addr);
- }
- iocalladdr = TYCHAR;
- putiocall(q);
- iocalladdr = TYADDR;
-}
-
-
-
-
-endio()
-{
- extern void p1_label();
-
- if(skiplab)
- {
- if (ioformatted != NAMEDIRECTED)
- p1_label((long)(skiplabel - labeltab));
- if(ioendlab) {
- exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
- exgoto(execlab(ioendlab));
- exendif();
- }
- if(ioerrlab) {
- exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
- ? OPGT : OPNE,
- cpexpr(IOSTP), ICON(0)));
- exgoto(execlab(ioerrlab));
- exendif();
- }
- }
-
- if(IOSTP)
- frexpr(IOSTP);
-}
-
-
-
- LOCAL void
-putiocall(q)
- register expptr q;
-{
- int tyintsave;
-
- tyintsave = tyint;
- tyint = tyioint; /* for -I2 and -i2 */
-
- if(IOSTP)
- {
- q->headblock.vtype = TYINT;
- q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
- }
- putexpr(q);
- if(jumplab) {
- exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
- exgoto(execlab(jumplab));
- exendif();
- }
- tyint = tyintsave;
-}
-
- void
-fmtname(np, q)
- Namep np;
- register Addrp q;
-{
- register int k;
- register char *s, *t;
- extern chainp assigned_fmts;
-
- if (!np->vfmt_asg) {
- np->vfmt_asg = 1;
- assigned_fmts = mkchain((char *)np, assigned_fmts);
- }
- k = strlen(s = np->fvarname);
- if (k < IDENT_LEN - 4) {
- q->uname_tag = UNAM_IDENT;
- t = q->user.ident;
- }
- else {
- q->uname_tag = UNAM_CHARP;
- q->user.Charp = t = mem(k + 5,0);
- }
- sprintf(t, "%s_fmt", s);
- }
-
-LOCAL Addrp asg_addr(p)
- union Expression *p;
-{
- register Addrp q;
-
- if (p->tag != TPRIM)
- badtag("asg_addr", p->tag);
- q = ALLOC(Addrblock);
- q->tag = TADDR;
- q->vtype = TYCHAR;
- q->vstg = STGAUTO;
- q->ntempelt = 1;
- q->isarray = 0;
- q->memoffset = ICON(0);
- fmtname(p->primblock.namep, q);
- return q;
- }
-
-startrw()
-{
- register expptr p;
- register Namep np;
- register Addrp unitp, fmtp, recp;
- register expptr nump;
- Addrp mkscalar();
- expptr mkaddcon();
- int iostmt1;
- flag intfile, sequential, ok, varfmt;
- struct io_setup *ios;
-
- /* First look at all the parameters and determine what is to be done */
-
- ok = YES;
- statstruct = YES;
-
- intfile = NO;
- if(p = V(IOSUNIT))
- {
- if( ISINT(p->headblock.vtype) ) {
- int_unit:
- unitp = (Addrp) cpexpr(p);
- }
- else if(p->headblock.vtype == TYCHAR)
- {
- if (nioctl == 1 && iostmt == IOREAD) {
- /* kludge to recognize READ(format expr) */
- V(IOSFMT) = p;
- V(IOSUNIT) = p = (expptr) IOSTDIN;
- ioformatted = FORMATTED;
- goto int_unit;
- }
- intfile = YES;
- if(p->tag==TPRIM && p->primblock.argsp==NULL &&
- (np = p->primblock.namep)->vdim!=NULL)
- {
- vardcl(np);
- if(nump = np->vdim->nelt)
- {
- nump = fixtype(cpexpr(nump));
- if( ! ISCONST(nump) ) {
- statstruct = NO;
- np->vlastdim = 0;
- }
- }
- else
- {
- err("attempt to use internal unit array of unknown size");
- ok = NO;
- nump = ICON(1);
- }
- unitp = mkscalar(np);
- }
- else {
- nump = ICON(1);
- unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
- }
- if(! isstatic((expptr)unitp) )
- statstruct = NO;
- }
- else {
- err("unit specifier not of type integer or character");
- ok = NO;
- }
- }
- else
- {
- err("bad unit specifier");
- ok = NO;
- }
-
- sequential = YES;
- if(p = V(IOSREC))
- if( ISINT(p->headblock.vtype) )
- {
- recp = (Addrp) cpexpr(p);
- sequential = NO;
- }
- else {
- err("bad REC= clause");
- ok = NO;
- }
- else
- recp = NULL;
-
-
- varfmt = YES;
- fmtp = NULL;
- if(p = V(IOSFMT))
- {
- if(p->tag==TPRIM && p->primblock.argsp==NULL)
- {
- np = p->primblock.namep;
- if(np->vclass == CLNAMELIST)
- {
- ioformatted = NAMEDIRECTED;
- fmtp = (Addrp) fixtype(p);
- V(IOSFMT) = (expptr)fmtp;
- if (skiplab)
- jumplab = 0;
- goto endfmt;
- }
- vardcl(np);
- if(np->vdim)
- {
- if( ! ONEOF(np->vstg, MSKSTATIC) )
- statstruct = NO;
- fmtp = mkscalar(np);
- goto endfmt;
- }
- if( ISINT(np->vtype) ) /* ASSIGNed label */
- {
- statstruct = NO;
- varfmt = YES;
- fmtp = asg_addr(p);
- goto endfmt;
- }
- }
- p = V(IOSFMT) = fixtype(p);
- if(p->headblock.vtype == TYCHAR
- /* Since we allow write(6,n) */
- /* we may as well allow write(6,n(2)) */
- || p->tag == TADDR && ISINT(p->addrblock.vtype))
- {
- if( ! isstatic(p) )
- statstruct = NO;
- fmtp = (Addrp) cpexpr(p);
- }
- else if( ISICON(p) )
- {
- struct Labelblock *lp;
- lp = mklabel(p->constblock.Const.ci);
- if (fmtstmt(lp) > 0)
- {
- fmtp = (Addrp)mkaddcon(lp->stateno);
- /* lp->stateno for names fmt_nnn */
- lp->fmtlabused = 1;
- varfmt = NO;
- }
- else
- ioformatted = UNFORMATTED;
- }
- else {
- err("bad format descriptor");
- ioformatted = UNFORMATTED;
- ok = NO;
- }
- }
- else
- fmtp = NULL;
-
-endfmt:
- if(intfile) {
- if (ioformatted==UNFORMATTED) {
- err("unformatted internal I/O not allowed");
- ok = NO;
- }
- if (recp) {
- err("direct internal I/O not allowed");
- ok = NO;
- }
- }
- if(!sequential && ioformatted==LISTDIRECTED)
- {
- err("direct list-directed I/O not allowed");
- ok = NO;
- }
- if(!sequential && ioformatted==NAMEDIRECTED)
- {
- err("direct namelist I/O not allowed");
- ok = NO;
- }
-
- if( ! ok ) {
- statstruct = NO;
- return;
- }
-
- /*
- Now put out the I/O structure, statically if all the clauses
- are constants, dynamically otherwise
-*/
-
- if (intfile) {
- ios = io_stuff + iostmt;
- iostmt1 = IOREAD;
- }
- else {
- ios = io_stuff;
- iostmt1 = 0;
- }
- io_fields = ios->fields;
- if(statstruct)
- {
- ioblkp = ALLOC(Addrblock);
- ioblkp->tag = TADDR;
- ioblkp->vtype = ios->type;
- ioblkp->vclass = CLVAR;
- ioblkp->vstg = STGINIT;
- ioblkp->memno = ++lastvarno;
- ioblkp->memoffset = ICON(0);
- ioblkp -> uname_tag = UNAM_IDENT;
- new_iob_data(ios,
- temp_name("io_", lastvarno, ioblkp->user.ident)); }
- else if(!(ioblkp = io_structs[iostmt1]))
- io_structs[iostmt1] = ioblkp =
- autovar(1, ios->type, ENULL, "");
-
- ioset(TYIOINT, XERR, ICON(errbit));
- if(iostmt == IOREAD)
- ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
-
- if(intfile)
- {
- ioset(TYIOINT, XIRNUM, nump);
- ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
- ioseta(XIUNIT, unitp);
- }
- else
- ioset(TYIOINT, XUNIT, (expptr) unitp);
-
- if(recp)
- ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp);
-
- if(varfmt)
- ioseta( intfile ? XIFMT : XFMT , fmtp);
- else
- ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
-
- ioroutine[0] = 's';
- ioroutine[1] = '_';
- ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
- ioroutine[3] = "ds"[sequential];
- ioroutine[4] = "ufln"[ioformatted];
- ioroutine[5] = "ei"[intfile];
- ioroutine[6] = '\0';
-
- putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));
-
- if(statstruct)
- {
- frexpr((expptr)ioblkp);
- statstruct = NO;
- ioblkp = 0; /* unnecessary */
- }
-}
-
-
-
- LOCAL void
-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((expptr)ioblkp) ));
-}
-
-
- LOCAL void
-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((expptr)ioblkp)) );
- }
- else
- err("bad unit in close statement");
-}
-
-
- LOCAL void
-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((expptr)ioblkp) ));
-}
-
-
-
- LOCAL void
-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((expptr)ioblkp) ));
- }
- else
- err("bad unit in I/O motion statement");
-}
-
-static int ioset_assign = OPASSIGN;
-
- LOCAL void
-ioset(type, offset, p)
- int type, offset;
- register expptr p;
-{
- offset /= SZLONG;
- if(statstruct && ISCONST(p)) {
- register char *s;
- switch(type) {
- case TYADDR: /* stmt label */
- s = "fmt_";
- break;
- case TYIOINT:
- s = "";
- break;
- default:
- badtype("ioset", type);
- }
- iob_list->fields[offset] =
- string_num(s, p->constblock.Const.ci);
- frexpr(p);
- }
- else {
- register Addrp q;
-
- q = ALLOC(Addrblock);
- q->tag = TADDR;
- q->vtype = type;
- q->vstg = STGAUTO;
- q->ntempelt = 1;
- q->isarray = 0;
- q->memoffset = ICON(0);
- q->uname_tag = UNAM_IDENT;
- sprintf(q->user.ident, "%s.%s",
- statstruct ? iob_list->name : ioblkp->user.ident,
- io_fields[offset + 1]);
- if (type == TYADDR && p->tag == TCONST
- && p->constblock.vtype == TYADDR) {
- /* kludge */
- register Addrp p1;
- p1 = ALLOC(Addrblock);
- p1->tag = TADDR;
- p1->vtype = type;
- p1->vstg = STGAUTO; /* wrong, but who cares? */
- p1->ntempelt = 1;
- p1->isarray = 0;
- p1->memoffset = ICON(0);
- p1->uname_tag = UNAM_IDENT;
- sprintf(p1->user.ident, "fmt_%ld",
- p->constblock.Const.ci);
- frexpr(p);
- p = (expptr)p1;
- }
- if (type == TYADDR && p->headblock.vtype == TYCHAR)
- q->vtype = TYCHAR;
- putexpr(mkexpr(ioset_assign, (expptr)q, p));
- }
-}
-
-
-
-
- LOCAL void
-iosetc(offset, p)
- int offset;
- register expptr p;
-{
- extern Addrp putchop();
-
- if(p == NULL)
- ioset(TYADDR, offset, ICON(0) );
- else if(p->headblock.vtype == TYCHAR) {
- p = putx(fixtype((expptr)putchop(cpexpr(p))));
- ioset(TYADDR, offset, addrof(p));
- }
- else
- err("non-character control clause");
-}
-
-
-
- LOCAL void
-ioseta(offset, p)
- int offset;
- register Addrp p;
-{
- char *s, *s1;
- static char who[] = "ioseta";
- expptr e, mo;
- Namep np;
- ftnint ci;
- int k;
- char buf[24], buf1[24];
- Extsym *comm;
- extern int usedefsforcommon;
-
- if(statstruct)
- {
- if (!p)
- return;
- if (p->tag != TADDR)
- badtag(who, p->tag);
- offset /= SZLONG;
- switch(p->uname_tag) {
- case UNAM_NAME:
- mo = p->memoffset;
- if (mo->tag != TCONST)
- badtag("ioseta/memoffset", mo->tag);
- np = p->user.name;
- np->visused = 1;
- ci = mo->constblock.Const.ci - np->voffset;
- if (np->vstg == STGCOMMON
- && !np->vcommequiv
- && !usedefsforcommon) {
- comm = &extsymtab[np->vardesc.varno];
- sprintf(buf, "%d.", comm->curno);
- k = strlen(buf) + strlen(comm->cextname)
- + strlen(np->cvarname);
- if (ci) {
- sprintf(buf1, "+%ld", ci);
- k += strlen(buf1);
- }
- else
- buf1[0] = 0;
- s = mem(k + 1, 0);
- sprintf(s, "%s%s%s%s", comm->cextname, buf,
- np->cvarname, buf1);
- }
- else if (ci) {
- sprintf(buf,"%ld", ci);
- s1 = p->user.name->cvarname;
- k = strlen(buf) + strlen(s1);
- sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
- }
- else
- s = cpstring(np->cvarname);
- break;
- case UNAM_CONST:
- s = tostring(p->user.Const.ccp1.ccp0,
- (int)p->vleng->constblock.Const.ci);
- break;
- default:
- badthing("uname_tag", who, p->uname_tag);
- }
- /* kludge for Hollerith */
- if (p->vtype != TYCHAR) {
- s1 = mem(strlen(s)+10,0);
- sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
- s = s1;
- }
- iob_list->fields[offset] = s;
- }
- else {
- if (!p)
- e = ICON(0);
- else if (p->vtype != TYCHAR) {
- NOEXT("non-character variable as format or internal unit");
- e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
- }
- else
- e = addrof((expptr)p);
- ioset(TYADDR, offset, e);
- }
-}
-
-
-
-
- LOCAL void
-iosetip(i, offset)
- int i, offset;
-{
- register expptr p;
-
- if(p = V(i))
- if(p->tag==TADDR &&
- ONEOF(p->addrblock.vtype, inqmask) ) {
- ioset_assign = OPASSIGNI;
- ioset(TYADDR, offset, addrof(cpexpr(p)) );
- ioset_assign = OPASSIGN;
- }
- else
- errstr("impossible inquire parameter %s", ioc[i].iocname);
- else
- ioset(TYADDR, offset, ICON(0) );
-}
-
-
-
- LOCAL void
-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);
-}
OpenPOWER on IntegriCloud