diff options
Diffstat (limited to 'usr.bin/f2c/io.c')
-rw-r--r-- | usr.bin/f2c/io.c | 1420 |
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); -} |