f2c from netlib.att.com Jan 4 1994

1 files changed, 1602 insertions, 0 deletions

diff --git a/usr.bin/f2c/proc.c b/usr.bin/f2c/proc.c
new file mode 100644
index 0000000..ca3043e
--- /dev/null
+++ b/usr.bin/f2c/proc.c
@@ -0,0 +1,1602 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 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.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+#include "output.h"
+#include "p1defs.h"
+
+#define EXNULL (union Expression *)0
+
+LOCAL dobss(), docomleng(), docommon(), doentry(),
+	epicode(), nextarg(), retval();
+
+static char Blank[] = BLANKCOMMON;
+
+ static char *postfix[] = { "g", "h", "i",
+#ifdef TYQUAD
+					"j",
+#endif
+					"r", "d", "c", "z", "g", "h", "i" };
+
+ chainp new_procs;
+ int prev_proc, proc_argchanges, proc_protochanges;
+
+ void
+changedtype(q)
+ Namep q;
+{
+	char buf[200];
+	int qtype, type1;
+	register Extsym *e;
+	Argtypes *at;
+
+	if (q->vtypewarned)
+		return;
+	q->vtypewarned = 1;
+	qtype = q->vtype;
+	e = &extsymtab[q->vardesc.varno];
+	if (!(at = e->arginfo)) {
+		if (!e->exused)
+			return;
+		}
+	else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
+		proc_protochanges++;
+	type1 = e->extype;
+	if (type1 == TYUNKNOWN)
+		return;
+	if (qtype == TYUNKNOWN)
+		/* e.g.,
+			subroutine foo
+			end
+			external foo
+			call goo(foo)
+			end
+		*/
+		return;
+	sprintf(buf, "%.90s: inconsistent declarations:\n\
+	here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
+		qtype == TYSUBR ? "" : " function",
+		ftn_types[type1], type1 == TYSUBR ? "" : " function");
+	warn(buf);
+	}
+
+ void
+unamstring(q, s)
+ register Addrp q;
+ register char *s;
+{
+	register int k;
+	register char *t;
+
+	k = strlen(s);
+	if (k < IDENT_LEN) {
+		q->uname_tag = UNAM_IDENT;
+		t = q->user.ident;
+		}
+	else {
+		q->uname_tag = UNAM_CHARP;
+		q->user.Charp = t = mem(k+1, 0);
+		}
+	strcpy(t, s);
+	}
+
+ static void
+fix_entry_returns()	/* for multiple entry points */
+{
+	Addrp a;
+	int i;
+	struct Entrypoint *e;
+	Namep np;
+
+	e = entries = (struct Entrypoint *)revchain((chainp)entries);
+	allargs = revchain(allargs);
+	if (!multitype)
+		return;
+
+	/* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
+
+	for(i = TYINT1; i <= TYLOGICAL; i++)
+		if (a = xretslot[i])
+			sprintf(a->user.ident, "(*ret_val).%s",
+				postfix[i-TYINT1]);
+
+	do {
+		np = e->enamep;
+		switch(np->vtype) {
+			case TYINT1:
+			case TYSHORT:
+			case TYLONG:
+#ifdef TYQUAD
+			case TYQUAD:
+#endif
+			case TYREAL:
+			case TYDREAL:
+			case TYCOMPLEX:
+			case TYDCOMPLEX:
+			case TYLOGICAL1:
+			case TYLOGICAL2:
+			case TYLOGICAL:
+				np->vstg = STGARG;
+			}
+		}
+		while(e = e->entnextp);
+	}
+
+ static void
+putentries(outfile)	/* put out wrappers for multiple entries */
+ FILE *outfile;
+{
+	char base[IDENT_LEN];
+	struct Entrypoint *e;
+	Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
+	chainp args, lengths, length_comp();
+	void listargs(), list_arg_types();
+	int i, k, mt, nL, type;
+	extern char *dfltarg[], **dfltproc;
+
+	e = entries;
+	if (!e->enamep) /* only possible with erroneous input */
+		return;
+	nL = (nallargs + nallchargs) * sizeof(Namep *);
+	A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
+	Ae = A + nallargs;
+	Alp = (Namep **)(Ae1 = Ae + nallchargs);
+	i = k = 0;
+	for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
+		np = (Namep)args->datap;
+		if (np->vtype == TYCHAR && np->vclass != CLPROC)
+			*a1 = &Ae[i++];
+		}
+
+	mt = multitype;
+	multitype = 0;
+	sprintf(base, "%s0_", e->enamep->cvarname);
+	do {
+		np = e->enamep;
+		lengths = length_comp(e, 0);
+		proctype = type = np->vtype;
+		if (protofile)
+			protowrite(protofile, type, np->cvarname, e, lengths);
+		nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
+		nice_printf(outfile, "%s", np->cvarname);
+		if (!Ansi) {
+			listargs(outfile, e, 0, lengths);
+			nice_printf(outfile, "\n");
+			}
+	    	list_arg_types(outfile, e, lengths, 0, "\n");
+		nice_printf(outfile, "{\n");
+		frchain(&lengths);
+		next_tab(outfile);
+		if (mt)
+			nice_printf(outfile,
+				"Multitype ret_val;\n%s(%d, &ret_val",
+				base, k); /*)*/
+		else if (ISCOMPLEX(type))
+			nice_printf(outfile, "%s(%d,%s", base, k,
+				xretslot[type]->user.ident); /*)*/
+		else if (type == TYCHAR)
+			nice_printf(outfile,
+				"%s(%d, ret_val, ret_val_len", base, k); /*)*/
+		else
+			nice_printf(outfile, "return %s(%d", base, k); /*)*/
+		k++;
+		memset((char *)A, 0, nL);
+		for(args = e->arglist; args; args = args->nextp) {
+			np = (Namep)args->datap;
+			A[np->argno] = np;
+			if (np->vtype == TYCHAR && np->vclass != CLPROC)
+				*Alp[np->argno] = np;
+			}
+		args = allargs;
+		for(a = A; a < Ae; a++, args = args->nextp)
+			nice_printf(outfile, ", %s", (np = *a)
+				? np->cvarname
+				: ((Namep)args->datap)->vclass == CLPROC
+				? dfltproc[((Namep)args->datap)->vtype]
+				: dfltarg[((Namep)args->datap)->vtype]);
+		for(; a < Ae1; a++)
+			if (np = *a)
+				nice_printf(outfile, ", %s_len", np->fvarname);
+			else
+				nice_printf(outfile, ", (ftnint)0");
+		nice_printf(outfile, /*(*/ ");\n");
+		if (mt) {
+			if (type == TYCOMPLEX)
+				nice_printf(outfile,
+		    "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
+			else if (type == TYDCOMPLEX)
+				nice_printf(outfile,
+		    "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
+			else if (type <= TYLOGICAL)
+				nice_printf(outfile, "return ret_val.%s;\n",
+					postfix[type-TYINT1]);
+			}
+		nice_printf(outfile, "}\n");
+		prev_tab(outfile);
+		}
+		while(e = e->entnextp);
+	free((char *)A);
+	}
+
+ static void
+entry_goto(outfile)
+ FILEP outfile;
+{
+	struct Entrypoint *e = entries;
+	int k = 0;
+
+	nice_printf(outfile, "switch(n__) {\n");
+	next_tab(outfile);
+	while(e = e->entnextp)
+		nice_printf(outfile, "case %d: goto %s;\n", ++k,
+			user_label((long)(extsymtab - e->entryname - 1)));
+	nice_printf(outfile, "}\n\n");
+	prev_tab(outfile);
+	}
+
+/* start a new procedure */
+
+newproc()
+{
+	if(parstate != OUTSIDE)
+	{
+		execerr("missing end statement", CNULL);
+		endproc();
+	}
+
+	parstate = INSIDE;
+	procclass = CLMAIN;	/* default */
+}
+
+ static void
+zap_changes()
+{
+	register chainp cp;
+	register Argtypes *at;
+
+	/* arrange to get correct count of prototypes that would
+	   change by running f2c again */
+
+	if (prev_proc && proc_argchanges)
+		proc_protochanges++;
+	prev_proc = proc_argchanges = 0;
+	for(cp = new_procs; cp; cp = cp->nextp)
+		if (at = ((Namep)cp->datap)->arginfo)
+			at->changes &= ~1;
+	frchain(&new_procs);
+	}
+
+/* end of procedure. generate variables, epilogs, and prologs */
+
+endproc()
+{
+	struct Labelblock *lp;
+	Extsym *ext;
+
+	if(parstate < INDATA)
+		enddcl();
+	if(ctlstack >= ctls)
+		err("DO loop or BLOCK IF not closed");
+	for(lp = labeltab ; lp < labtabend ; ++lp)
+		if(lp->stateno!=0 && lp->labdefined==NO)
+			errstr("missing statement label %s",
+				convic(lp->stateno) );
+
+/* Save copies of the common variables in extptr -> allextp */
+
+	for (ext = extsymtab; ext < nextext; ext++)
+		if (ext -> extstg == STGCOMMON && ext -> extp) {
+			extern int usedefsforcommon;
+
+/* Write out the abbreviations for common block reference */
+
+			copy_data (ext -> extp);
+			if (usedefsforcommon) {
+				wr_abbrevs (c_file, 1, ext -> extp);
+				ext -> used_here = 1;
+				}
+			else
+				ext -> extp = CHNULL;
+
+			}
+
+	if (nentry > 1)
+		fix_entry_returns();
+	epicode();
+	donmlist();
+	dobss();
+	start_formatting ();
+	if (nentry > 1)
+		putentries(c_file);
+
+	zap_changes();
+	procinit();	/* clean up for next procedure */
+}
+
+
+
+/* End of declaration section of procedure.  Allocate storage. */
+
+enddcl()
+{
+	register struct Entrypoint *ep;
+	struct Entrypoint *ep0;
+	extern void freetemps();
+	chainp cp;
+	extern char *err_proc;
+	static char comblks[] = "common blocks";
+
+	err_proc = comblks;
+	docommon();
+
+/* Now the hash table entries for fields of common blocks have STGCOMMON,
+   vdcldone, voffset, and varno.  And the common blocks themselves have
+   their full sizes in extleng. */
+
+	err_proc = "equivalences";
+	doequiv();
+
+	err_proc = comblks;
+	docomleng();
+
+/* This implies that entry points in the declarations are buffered in
+   entries   but not written out */
+
+	err_proc = "entries";
+	if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
+		/* entries could be 0 in case of an error */
+		do doentry(ep);
+			while(ep = ep->entnextp);
+		entries = (struct Entrypoint *)revchain((chainp)ep0);
+		}
+
+	err_proc = 0;
+	parstate = INEXEC;
+	p1put(P1_PROCODE);
+	freetemps();
+	if (earlylabs) {
+		for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
+			p1_label((long)cp->datap);
+		frchain(&earlylabs);
+		}
+	p1_line_number(lineno); /* for files that start with a MAIN program */
+				/* that starts with an executable statement */
+}
+
+/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
+
+/* Main program or Block data */
+
+startproc(progname, class)
+Extsym * progname;
+int class;
+{
+	register struct Entrypoint *p;
+
+	p = ALLOC(Entrypoint);
+	if(class == CLMAIN) {
+		puthead(CNULL, CLMAIN);
+		if (progname)
+		    strcpy (main_alias, progname->cextname);
+	} else
+		puthead(CNULL, CLBLOCK);
+	if(class == CLMAIN)
+		newentry( mkname(" MAIN"), 0 )->extinit = 1;
+	p->entryname = progname;
+	entries = p;
+
+	procclass = class;
+	fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
+	if(progname) {
+		fprintf(diagfile, " %s", progname->fextname);
+		procname = progname->cextname;
+		}
+	fprintf(diagfile, ":\n");
+	fflush(diagfile);
+}
+
+/* subroutine or function statement */
+
+Extsym *newentry(v, substmsg)
+ register Namep v;
+ int substmsg;
+{
+	register Extsym *p;
+	char buf[128], badname[64];
+	static int nbad = 0;
+	static char already[] = "external name already used";
+
+	p = mkext(v->fvarname, addunder(v->cvarname));
+
+	if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
+	{
+		sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
+		if (substmsg) {
+			sprintf(buf,"%s\n\tsubstituting \"%s\"",
+				already, badname);
+			dclerr(buf, v);
+			}
+		else
+			dclerr(already, v);
+		p = mkext(v->fvarname, badname);
+	}
+	v->vstg = STGAUTO;
+	v->vprocclass = PTHISPROC;
+	v->vclass = CLPROC;
+	if (p->extstg == STGEXT)
+		prev_proc = 1;
+	else
+		p->extstg = STGEXT;
+	p->extinit = YES;
+	v->vardesc.varno = p - extsymtab;
+	return(p);
+}
+
+
+entrypt(class, type, length, entry, args)
+int class, type;
+ftnint length;
+Extsym *entry;
+chainp args;
+{
+	register Namep q;
+	register struct Entrypoint *p;
+
+	if(class != CLENTRY)
+		puthead( procname = entry->cextname, class);
+	else
+		fprintf(diagfile, "       entry ");
+	fprintf(diagfile, "   %s:\n", entry->fextname);
+	fflush(diagfile);
+	q = mkname(entry->fextname);
+	if (type == TYSUBR)
+		q->vstg = STGEXT;
+
+	type = lengtype(type, length);
+	if(class == CLPROC)
+	{
+		procclass = CLPROC;
+		proctype = type;
+		procleng = type == TYCHAR ? length : 0;
+	}
+
+	p = ALLOC(Entrypoint);
+
+	p->entnextp = entries;
+	entries = p;
+
+	p->entryname = entry;
+	p->arglist = revchain(args);
+	p->enamep = q;
+
+	if(class == CLENTRY)
+	{
+		class = CLPROC;
+		if(proctype == TYSUBR)
+			type = TYSUBR;
+	}
+
+	q->vclass = class;
+	q->vprocclass = 0;
+	settype(q, type, length);
+	q->vprocclass = PTHISPROC;
+	/* hold all initial entry points till end of declarations */
+	if(parstate >= INDATA)
+		doentry(p);
+}
+
+/* generate epilogs */
+
+/* epicode -- write out the proper function return mechanism at the end of
+   the procedure declaration.  Handles multiple return value types, as
+   well as cooercion into the proper value */
+
+LOCAL epicode()
+{
+	extern int lastwasbranch;
+
+	if(procclass==CLPROC)
+	{
+		if(proctype==TYSUBR)
+		{
+
+/* Return a zero only when the alternate return mechanism has been
+   specified in the function header */
+
+			if ((substars || Ansi) && lastwasbranch != YES)
+			    p1_subr_ret (ICON(0));
+		}
+		else if (!multitype && lastwasbranch != YES)
+			retval(proctype);
+	}
+	else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
+		p1_subr_ret (ICON(0));
+	lastwasbranch = NO;
+}
+
+
+/* generate code to return value of type  t */
+
+LOCAL retval(t)
+register int t;
+{
+	register Addrp p;
+
+	switch(t)
+	{
+	case TYCHAR:
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		break;
+
+	case TYLOGICAL:
+		t = tylogical;
+	case TYINT1:
+	case TYADDR:
+	case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+	case TYREAL:
+	case TYDREAL:
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+		p = (Addrp) cpexpr((expptr)retslot);
+		p->vtype = t;
+		p1_subr_ret (mkconv (t, fixtype((expptr)p)));
+		break;
+
+	default:
+		badtype("retval", t);
+	}
+}
+
+
+/* Do parameter adjustments */
+
+procode(outfile)
+FILE *outfile;
+{
+	prolog(outfile, allargs);
+
+	if (nentry > 1)
+		entry_goto(outfile);
+	}
+
+/* Finish bound computations now that all variables are declared.
+ * This used to be in setbound(), but under -u the following incurred
+ * an erroneous error message:
+ *	subroutine foo(x,n)
+ *	real x(n)
+ *	integer n
+ */
+
+ static void
+dim_finish(v)
+ Namep v;
+{
+	register struct Dimblock *p;
+	register expptr q;
+	register int i, nd;
+	extern expptr make_int_expr();
+
+	p = v->vdim;
+	v->vdimfinish = 0;
+	nd = p->ndim;
+	doin_setbound = 1;
+	for(i = 0; i < nd; i++)
+		if (q = p->dims[i].dimexpr) {
+			q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
+			if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
+				errstr("bad dimension type for %.70s",
+					v->fvarname);
+			}
+	if (q = p->basexpr)
+		p->basexpr = make_int_expr(putx(fixtype(q)));
+	doin_setbound = 0;
+	}
+
+ static void
+duparg(q)
+ Namep q;
+{ errstr("duplicate argument %.80s", q->fvarname); }
+
+/*
+   manipulate argument lists (allocate argument slot positions)
+ * keep track of return types and labels
+ */
+
+LOCAL doentry(ep)
+struct Entrypoint *ep;
+{
+	register int type;
+	register Namep np;
+	chainp p, p1;
+	register Namep q;
+	Addrp mkarg(), rs;
+	int it, k;
+	extern char dflttype[26];
+	Extsym *entryname = ep->entryname;
+
+	if (++nentry > 1)
+		p1_label((long)(extsymtab - entryname - 1));
+
+/* The main program isn't allowed to have parameters, so any given
+   parameters are ignored */
+
+	if(procclass == CLMAIN || procclass == CLBLOCK)
+		return;
+
+/* So now we're working with something other than CLMAIN or CLBLOCK.
+   Determine the type of its return value. */
+
+	impldcl( np = mkname(entryname->fextname) );
+	type = np->vtype;
+	proc_argchanges = prev_proc && type != entryname->extype;
+	entryname->extseen = 1;
+	if(proctype == TYUNKNOWN)
+		if( (proctype = type) == TYCHAR)
+			procleng = np->vleng ? np->vleng->constblock.Const.ci
+					     : (ftnint) (-1);
+
+	if(proctype == TYCHAR)
+	{
+		if(type != TYCHAR)
+			err("noncharacter entry of character function");
+
+/* Functions returning type   char   can only have multiple entries if all
+   entries return the same length */
+
+		else if( (np->vleng ? np->vleng->constblock.Const.ci :
+		    (ftnint) (-1)) != procleng)
+			err("mismatched character entry lengths");
+	}
+	else if(type == TYCHAR)
+		err("character entry of noncharacter function");
+	else if(type != proctype)
+		multitype = YES;
+	if(rtvlabel[type] == 0)
+		rtvlabel[type] = newlabel();
+	ep->typelabel = rtvlabel[type];
+
+	if(type == TYCHAR)
+	{
+		if(chslot < 0)
+		{
+			chslot = nextarg(TYADDR);
+			chlgslot = nextarg(TYLENG);
+		}
+		np->vstg = STGARG;
+
+/* Put a new argument in the function, one which will hold the result of
+   a character function.  This will have to be named sometime, probably in
+   mkarg(). */
+
+		if(procleng < 0) {
+			np->vleng = (expptr) mkarg(TYLENG, chlgslot);
+			np->vleng->addrblock.uname_tag = UNAM_IDENT;
+			strcpy (np -> vleng -> addrblock.user.ident,
+				new_func_length());
+			}
+		if (!xretslot[TYCHAR]) {
+			xretslot[TYCHAR] = rs =
+				autovar(0, type, ISCONST(np->vleng)
+					? np->vleng : ICON(0), "");
+			strcpy(rs->user.ident, "ret_val");
+			}
+	}
+
+/* Handle a   complex   return type -- declare a new parameter (pointer to
+   a complex value) */
+
+	else if( ISCOMPLEX(type) ) {
+		if (!xretslot[type])
+			xretslot[type] =
+				autovar(0, type, EXNULL, " ret_val");
+				/* the blank is for use in out_addr */
+		np->vstg = STGARG;
+		if(cxslot < 0)
+			cxslot = nextarg(TYADDR);
+		}
+	else if (type != TYSUBR) {
+		if (type == TYUNKNOWN) {
+			dclerr("untyped function", np);
+			proctype = type = np->vtype =
+				dflttype[letter(np->fvarname[0])];
+			}
+		if (!xretslot[type])
+			xretslot[type] = retslot =
+				autovar(1, type, EXNULL, " ret_val");
+				/* the blank is for use in out_addr */
+		np->vstg = STGAUTO;
+		}
+
+	for(p = ep->arglist ; p ; p = p->nextp)
+		if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
+			q->vknownarg = 1;
+			q->vardesc.varno = nextarg(TYADDR);
+			allargs = mkchain((char *)q, allargs);
+			q->argno = nallargs++;
+			}
+		else if (nentry == 1)
+			duparg(q);
+		else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
+			if ((Namep)p1->datap == q)
+				duparg(q);
+
+	k = 0;
+	for(p = ep->arglist ; p ; p = p->nextp) {
+		if(! (( q = (Namep) (p->datap) )->vdcldone) )
+			{
+			impldcl(q);
+			q->vdcldone = YES;
+			if(q->vtype == TYCHAR)
+				{
+
+/* If we don't know the length of a char*(*) (i.e. a string), we must add
+   in this additional length argument. */
+
+				++nallchargs;
+				if (q->vclass == CLPROC)
+					nallchargs--;
+				else if (q->vleng == NULL) {
+					/* character*(*) */
+					q->vleng = (expptr)
+					    mkarg(TYLENG, nextarg(TYLENG) );
+					unamstring((Addrp)q->vleng,
+						new_arg_length(q));
+					}
+				}
+			}
+		if (q->vdimfinish)
+			dim_finish(q);
+		if (q->vtype == TYCHAR && q->vclass != CLPROC)
+			k++;
+		}
+
+	if (entryname->extype != type)
+		changedtype(np);
+
+	/* save information for checking consistency of arg lists */
+
+	it = infertypes;
+	if (entryname->exproto)
+		infertypes = 1;
+	save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
+			0, np->fvarname, STGEXT, k, np->vtype, 2);
+	infertypes = it;
+}
+
+
+
+LOCAL nextarg(type)
+int type;
+{ return(lastargslot++); }
+
+ LOCAL
+dim_check(q)
+ Namep q;
+{
+	register struct Dimblock *vdim = q->vdim;
+
+	if(!vdim->nelt || !ISICON(vdim->nelt))
+		dclerr("adjustable dimension on non-argument", q);
+	else if (vdim->nelt->constblock.Const.ci <= 0)
+		dclerr("nonpositive dimension", q);
+	}
+
+LOCAL dobss()
+{
+	register struct Hashentry *p;
+	register Namep q;
+	int qstg, qclass, qtype;
+	Extsym *e;
+
+	for(p = hashtab ; p<lasthash ; ++p)
+		if(q = p->varp)
+		{
+			qstg = q->vstg;
+			qtype = q->vtype;
+			qclass = q->vclass;
+
+			if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
+			    (qclass==CLVAR && qstg==STGUNKNOWN) ) {
+				if (!(q->vis_assigned | q->vimpldovar))
+					warn1("local variable %s never used",
+						q->fvarname);
+				}
+			else if(qclass==CLVAR && qstg==STGBSS)
+			{ ; }
+
+/* Give external procedures the proper storage class */
+
+			else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
+					&& qstg!=STGARG) {
+				e = mkext(q->fvarname,addunder(q->cvarname));
+				e->extstg = STGEXT;
+				q->vardesc.varno = e - extsymtab;
+				if (e->extype != qtype)
+					changedtype(q);
+				}
+			if(qclass==CLVAR) {
+			    if (qstg != STGARG && q->vdim)
+				dim_check(q);
+			} /* if qclass == CLVAR */
+		}
+
+}
+
+
+
+donmlist()
+{
+	register struct Hashentry *p;
+	register Namep q;
+
+	for(p=hashtab; p<lasthash; ++p)
+		if( (q = p->varp) && q->vclass==CLNAMELIST)
+			namelist(q);
+}
+
+
+/* iarrlen -- Returns the size of the array in bytes, or -1 */
+
+ftnint iarrlen(q)
+register Namep q;
+{
+	ftnint leng;
+
+	leng = typesize[q->vtype];
+	if(leng <= 0)
+		return(-1);
+	if(q->vdim)
+		if( ISICON(q->vdim->nelt) )
+			leng *= q->vdim->nelt->constblock.Const.ci;
+		else	return(-1);
+	if(q->vleng)
+		if( ISICON(q->vleng) )
+			leng *= q->vleng->constblock.Const.ci;
+		else return(-1);
+	return(leng);
+}
+
+namelist(np)
+Namep np;
+{
+	register chainp q;
+	register Namep v;
+	int y;
+
+	if (!np->visused)
+		return;
+	y = 0;
+
+	for(q = np->varxptr.namelist ; q ; q = q->nextp)
+	{
+		vardcl( v = (Namep) (q->datap) );
+		if( !ONEOF(v->vstg, MSKSTATIC) )
+			dclerr("may not appear in namelist", v);
+		else {
+			v->vnamelist = 1;
+			v->visused = 1;
+			v->vsave = 1;
+			y = 1;
+			}
+	np->visused = y;
+	}
+}
+
+/* docommon -- called at the end of procedure declarations, before
+   equivalences and the procedure body */
+
+LOCAL docommon()
+{
+    register Extsym *extptr;
+    register chainp q, q1;
+    struct Dimblock *t;
+    expptr neltp;
+    register Namep comvar;
+    ftnint size;
+    int i, k, pref, type;
+    extern int type_pref[];
+
+    for(extptr = extsymtab ; extptr<nextext ; ++extptr)
+	if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
+
+/* If a common declaration also had a list of variables ... */
+
+	    q = extptr->extp = revchain(q);
+	    pref = 1;
+	    for(k = TYCHAR; q ; q = q->nextp)
+	    {
+		comvar = (Namep) (q->datap);
+
+		if(comvar->vdcldone == NO)
+		    vardcl(comvar);
+		type = comvar->vtype;
+		if (pref < type_pref[type])
+			pref = type_pref[k = type];
+		if(extptr->extleng % typealign[type] != 0) {
+		    dclerr("common alignment", comvar);
+		    --nerr; /* don't give bad return code for this */
+#if 0
+		    extptr->extleng = roundup(extptr->extleng, typealign[type]);
+#endif
+		} /* if extptr -> extleng % */
+
+/* Set the offset into the common block */
+
+		comvar->voffset = extptr->extleng;
+		comvar->vardesc.varno = extptr - extsymtab;
+		if(type == TYCHAR)
+		    size = comvar->vleng->constblock.Const.ci;
+		else
+		    size = typesize[type];
+		if(t = comvar->vdim)
+		    if( (neltp = t->nelt) && ISCONST(neltp) )
+			size *= neltp->constblock.Const.ci;
+		    else
+			dclerr("adjustable array in common", comvar);
+
+/* Adjust the length of the common block so far */
+
+		extptr->extleng += size;
+	    } /* for */
+
+	    extptr->extype = k;
+
+/* Determine curno and, if new, save this identifier chain */
+
+	    q1 = extptr->extp;
+	    for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
+		if (struct_eq((chainp)q->datap, q1))
+			break;
+	    if (q)
+		extptr->curno = extptr->maxno - i;
+	    else {
+		extptr->curno = ++extptr->maxno;
+		extptr->allextp = mkchain((char *)extptr->extp,
+						extptr->allextp);
+		}
+	} /* if extptr -> extstg == STGCOMMON */
+
+/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
+   varno.  And the common block itself has its full size in extleng. */
+
+} /* docommon */
+
+
+/* copy_data -- copy the Namep entries so they are available even after
+   the hash table is empty */
+
+copy_data (list)
+chainp list;
+{
+    for (; list; list = list -> nextp) {
+	Namep namep = ALLOC (Nameblock);
+	int size, nd, i;
+	struct Dimblock *dp;
+
+	cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
+	namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
+		namep->fvarname);
+	namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
+		? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
+		: namep->fvarname;
+	if (namep -> vleng)
+	    namep -> vleng = (expptr) cpexpr (namep -> vleng);
+	if (namep -> vdim) {
+	    nd = namep -> vdim -> ndim;
+	    size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
+	    dp = (struct Dimblock *) ckalloc (size);
+	    cpn(size, (char *)namep->vdim, (char *)dp);
+	    namep -> vdim = dp;
+	    dp->nelt = (expptr)cpexpr(dp->nelt);
+	    for (i = 0; i < nd; i++) {
+		dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
+	    } /* for */
+	} /* if */
+	list -> datap = (char *) namep;
+    } /* for */
+} /* copy_data */
+
+
+
+LOCAL docomleng()
+{
+	register Extsym *p;
+
+	for(p = extsymtab ; p < nextext ; ++p)
+		if(p->extstg == STGCOMMON)
+		{
+			if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
+			    && strcmp(Blank, p->cextname) )
+				warn1("incompatible lengths for common block %.60s",
+				    p->fextname);
+			if(p->maxleng < p->extleng)
+				p->maxleng = p->extleng;
+			p->extleng = 0;
+		}
+}
+
+
+/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
+
+frtemp(p)
+Addrp p;
+{
+	/* put block on chain of temps to be reclaimed */
+	holdtemps = mkchain((char *)p, holdtemps);
+}
+
+ void
+freetemps()
+{
+	register chainp p, p1;
+	register Addrp q;
+	register int t;
+
+	p1 = holdtemps;
+	while(p = p1) {
+		q = (Addrp)p->datap;
+		t = q->vtype;
+		if (t == TYCHAR && q->varleng != 0) {
+			/* restore clobbered character string lengths */
+			frexpr(q->vleng);
+			q->vleng = ICON(q->varleng);
+			}
+		p1 = p->nextp;
+		p->nextp = templist[t];
+		templist[t] = p;
+		}
+	holdtemps = 0;
+	}
+
+/* allocate an automatic variable slot for each of   nelt   variables */
+
+Addrp autovar(nelt0, t, lengp, name)
+register int nelt0, t;
+expptr lengp;
+char *name;
+{
+	ftnint leng;
+	register Addrp q;
+	char *temp_name ();
+	register int nelt = nelt0 > 0 ? nelt0 : 1;
+	extern char *av_pfix[];
+
+	if(t == TYCHAR)
+		if( ISICON(lengp) )
+			leng = lengp->constblock.Const.ci;
+		else	{
+			Fatal("automatic variable of nonconstant length");
+		}
+	else
+		leng = typesize[t];
+
+	q = ALLOC(Addrblock);
+	q->tag = TADDR;
+	q->vtype = t;
+	if(t == TYCHAR)
+	{
+		q->vleng = ICON(leng);
+		q->varleng = leng;
+	}
+	q->vstg = STGAUTO;
+	q->ntempelt = nelt;
+	q->isarray = (nelt > 1);
+	q->memoffset = ICON(0);
+
+	/* kludge for nls so we can have ret_val rather than ret_val_4 */
+	if (*name == ' ')
+		unamstring(q, name);
+	else {
+		q->uname_tag = UNAM_IDENT;
+		temp_name(av_pfix[t], ++autonum[t], q->user.ident);
+		}
+	if (nelt0 > 0)
+		declare_new_addr (q);
+	return(q);
+}
+
+
+/* Returns a temporary of the appropriate type.  Will reuse existing
+   temporaries when possible */
+
+Addrp mktmpn(nelt, type, lengp)
+int nelt;
+register int type;
+expptr lengp;
+{
+	ftnint leng;
+	chainp p, oldp;
+	register Addrp q;
+
+	if(type==TYUNKNOWN || type==TYERROR)
+		badtype("mktmpn", type);
+
+	if(type==TYCHAR)
+		if(lengp && ISICON(lengp) )
+			leng = lengp->constblock.Const.ci;
+		else	{
+			err("adjustable length");
+			return( (Addrp) errnode() );
+		}
+	else if (type > TYCHAR || type < TYADDR) {
+		erri("mktmpn: unexpected type %d", type);
+		exit(1);
+		}
+/*
+ * if a temporary of appropriate shape is on the templist,
+ * remove it from the list and return it
+ */
+	for(oldp=CHNULL, p=templist[type];  p  ;  oldp=p, p=p->nextp)
+	{
+		q = (Addrp) (p->datap);
+		if(q->ntempelt==nelt &&
+		    (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
+		{
+			if(oldp)
+				oldp->nextp = p->nextp;
+			else
+				templist[type] = p->nextp;
+			free( (charptr) p);
+			return(q);
+		}
+	}
+	q = autovar(nelt, type, lengp, "");
+	return(q);
+}
+
+
+
+
+/* mktmp -- create new local variable; call it something like   name
+   lengp   is taken directly, not copied */
+
+Addrp mktmp(type, lengp)
+int type;
+expptr lengp;
+{
+	Addrp rv;
+	/* arrange for temporaries to be recycled */
+	/* at the end of this statement... */
+	rv = mktmpn(1,type,lengp);
+	frtemp((Addrp)cpexpr((expptr)rv));
+	return rv;
+}
+
+/* mktmp0 omits frtemp() */
+Addrp mktmp0(type, lengp)
+int type;
+expptr lengp;
+{
+	Addrp rv;
+	/* arrange for temporaries to be recycled */
+	/* when this Addrp is freed */
+	rv = mktmpn(1,type,lengp);
+	rv->istemp = YES;
+	return rv;
+}
+
+/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
+
+/* comblock -- Declare a new common block.  Input parameters name the block;
+   s   will be NULL if the block is unnamed */
+
+Extsym *comblock(s)
+ register char *s;
+{
+	Extsym *p;
+	register char *t;
+	register int c, i;
+	char cbuf[256], *s0;
+
+/* Give the unnamed common block a unique name */
+
+	if(*s == 0)
+		p = mkext(Blank,Blank);
+	else {
+		s0 = s;
+		t = cbuf;
+		for(i = 0; c = *t = *s++; t++)
+			if (c == '_')
+				i = 1;
+		if (i)
+			*t++ = '_';
+		t[0] = '_';
+		t[1] = 0;
+		p = mkext(s0,cbuf);
+		}
+	if(p->extstg == STGUNKNOWN)
+		p->extstg = STGCOMMON;
+	else if(p->extstg != STGCOMMON)
+	{
+		errstr("%.68s cannot be a common block name", s);
+		return(0);
+	}
+
+	return( p );
+}
+
+
+/* incomm -- add a new variable to a common declaration */
+
+incomm(c, v)
+Extsym *c;
+Namep v;
+{
+	if (!c)
+		return;
+	if(v->vstg != STGUNKNOWN && !v->vimplstg)
+		dclerr(v->vstg == STGARG
+			? "dummy arguments cannot be in common"
+			: "incompatible common declaration", v);
+	else
+	{
+		v->vstg = STGCOMMON;
+		c->extp = mkchain((char *)v, c->extp);
+	}
+}
+
+
+
+
+/* settype -- set the type or storage class of a Namep object.  If
+   v -> vstg == STGUNKNOWN && type < 0,   attempt to reset vstg to be
+   -type.  This function will not change any earlier definitions in   v,
+   in will only attempt to fill out more information give the other params */
+
+settype(v, type, length)
+register Namep  v;
+register int type;
+register ftnint length;
+{
+	int type1;
+
+	if(type == TYUNKNOWN)
+		return;
+
+	if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
+	{
+		v->vtype = TYSUBR;
+		frexpr(v->vleng);
+		v->vleng = 0;
+		v->vimpltype = 0;
+	}
+	else if(type < 0)	/* storage class set */
+	{
+		if(v->vstg == STGUNKNOWN)
+			v->vstg = - type;
+		else if(v->vstg != -type)
+			dclerr("incompatible storage declarations", v);
+	}
+	else if(v->vtype == TYUNKNOWN || v->vimpltype && v->vtype != type)
+	{
+		if( (v->vtype = lengtype(type, length))==TYCHAR )
+			if (length>=0)
+				v->vleng = ICON(length);
+			else if (parstate >= INDATA)
+				v->vleng = ICON(1);	/* avoid a memory fault */
+		v->vimpltype = 0;
+
+		if (v->vclass == CLPROC) {
+			if (v->vstg == STGEXT
+			 && (type1 = extsymtab[v->vardesc.varno].extype)
+			 &&  type1 != v->vtype)
+				changedtype(v);
+			else if (v->vprocclass == PTHISPROC
+					&& (parstate >= INDATA
+						|| procclass == CLMAIN)
+					&& !xretslot[type]) {
+				xretslot[type] = autovar(ONEOF(type,
+					MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
+					v->vleng, " ret_val");
+				if (procclass == CLMAIN)
+					errstr(
+				"illegal use of %.60s (main program name)",
+					v->fvarname);
+				/* not completely right, but enough to */
+				/* avoid memory faults; we won't */
+				/* emit any C as we have illegal Fortran */
+				}
+			}
+	}
+	else if(v->vtype!=type) {
+ incompat:
+		dclerr("incompatible type declarations", v);
+		}
+	else if (type==TYCHAR)
+		if (v->vleng && v->vleng->constblock.Const.ci != length)
+			goto incompat;
+		else if (parstate >= INDATA)
+			v->vleng = ICON(1);	/* avoid a memory fault */
+}
+
+
+
+
+
+/* lengtype -- returns the proper compiler type, given input of Fortran
+   type and length specifier */
+
+lengtype(type, len)
+register int type;
+ftnint len;
+{
+	register int length = (int)len;
+	switch(type)
+	{
+	case TYREAL:
+		if(length == typesize[TYDREAL])
+			return(TYDREAL);
+		if(length == typesize[TYREAL])
+			goto ret;
+		break;
+
+	case TYCOMPLEX:
+		if(length == typesize[TYDCOMPLEX])
+			return(TYDCOMPLEX);
+		if(length == typesize[TYCOMPLEX])
+			goto ret;
+		break;
+
+	case TYINT1:
+	case TYSHORT:
+	case TYDREAL:
+	case TYDCOMPLEX:
+	case TYCHAR:
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+	case TYUNKNOWN:
+	case TYSUBR:
+	case TYERROR:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+		goto ret;
+
+	case TYLOGICAL:
+		switch(length) {
+			case 0: return tylog;
+			case 1:	return TYLOGICAL1;
+			case 2: return TYLOGICAL2;
+			case 4: goto ret;
+			}
+#if 0 /*!!??!!*/
+		if(length == typesize[TYLOGICAL])
+			goto ret;
+#endif
+		break;
+
+	case TYLONG:
+		if(length == 0)
+			return(tyint);
+		if (length == 1)
+			return TYINT1;
+		if(length == typesize[TYSHORT])
+			return(TYSHORT);
+#ifdef TYQUAD
+		if(length == typesize[TYQUAD] && use_tyquad)
+			return(TYQUAD);
+#endif
+		if(length == typesize[TYLONG])
+			goto ret;
+		break;
+	default:
+		badtype("lengtype", type);
+	}
+
+	if(len != 0)
+		err("incompatible type-length combination");
+
+ret:
+	return(type);
+}
+
+
+
+
+
+/* setintr -- Set Intrinsic function */
+
+setintr(v)
+register Namep  v;
+{
+	int k;
+
+	if(v->vstg == STGUNKNOWN)
+		v->vstg = STGINTR;
+	else if(v->vstg!=STGINTR)
+		dclerr("incompatible use of intrinsic function", v);
+	if(v->vclass==CLUNKNOWN)
+		v->vclass = CLPROC;
+	if(v->vprocclass == PUNKNOWN)
+		v->vprocclass = PINTRINSIC;
+	else if(v->vprocclass != PINTRINSIC)
+		dclerr("invalid intrinsic declaration", v);
+	if(k = intrfunct(v->fvarname)) {
+		if ((*(struct Intrpacked *)&k).f4)
+			if (noextflag)
+				goto unknown;
+			else
+				dcomplex_seen++;
+		v->vardesc.varno = k;
+		}
+	else {
+ unknown:
+		dclerr("unknown intrinsic function", v);
+		}
+}
+
+
+
+/* setext -- Set External declaration -- assume that unknowns will become
+   procedures */
+
+setext(v)
+register Namep  v;
+{
+	if(v->vclass == CLUNKNOWN)
+		v->vclass = CLPROC;
+	else if(v->vclass != CLPROC)
+		dclerr("invalid external declaration", v);
+
+	if(v->vprocclass == PUNKNOWN)
+		v->vprocclass = PEXTERNAL;
+	else if(v->vprocclass != PEXTERNAL)
+		dclerr("invalid external declaration", v);
+} /* setext */
+
+
+
+
+/* create dimensions block for array variable */
+
+setbound(v, nd, dims)
+register Namep  v;
+int nd;
+struct Dims dims[ ];
+{
+	register expptr q, t;
+	register struct Dimblock *p;
+	int i;
+	extern chainp new_vars;
+	char buf[256];
+
+	if(v->vclass == CLUNKNOWN)
+		v->vclass = CLVAR;
+	else if(v->vclass != CLVAR)
+	{
+		dclerr("only variables may be arrays", v);
+		return;
+	}
+
+	v->vdim = p = (struct Dimblock *)
+	    ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
+	p->ndim = nd--;
+	p->nelt = ICON(1);
+	doin_setbound = 1;
+
+	for(i = 0; i <= nd; ++i)
+	{
+		if( (q = dims[i].ub) == NULL)
+		{
+			if(i == nd)
+			{
+				frexpr(p->nelt);
+				p->nelt = NULL;
+			}
+			else
+				err("only last bound may be asterisk");
+			p->dims[i].dimsize = ICON(1);
+			p->dims[i].dimexpr = NULL;
+		}
+		else
+		{
+
+			if(dims[i].lb)
+			{
+				q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
+				q = mkexpr(OPPLUS, q, ICON(1) );
+			}
+			if( ISCONST(q) )
+			{
+				p->dims[i].dimsize = q;
+				p->dims[i].dimexpr = (expptr) PNULL;
+			}
+			else {
+				sprintf(buf, " %s_dim%d", v->fvarname, i+1);
+				p->dims[i].dimsize = (expptr)
+					autovar(1, tyint, EXNULL, buf);
+				p->dims[i].dimexpr = q;
+				if (i == nd)
+					v->vlastdim = new_vars;
+				v->vdimfinish = 1;
+			}
+			if(p->nelt)
+				p->nelt = mkexpr(OPSTAR, p->nelt,
+				    cpexpr(p->dims[i].dimsize) );
+		}
+	}
+
+	q = dims[nd].lb;
+	if(q == NULL)
+		q = ICON(1);
+
+	for(i = nd-1 ; i>=0 ; --i)
+	{
+		t = dims[i].lb;
+		if(t == NULL)
+			t = ICON(1);
+		if(p->dims[i].dimsize)
+			q = mkexpr(OPPLUS, t,
+				mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q));
+	}
+
+	if( ISCONST(q) )
+	{
+		p->baseoffset = q;
+		p->basexpr = NULL;
+	}
+	else
+	{
+		sprintf(buf, " %s_offset", v->fvarname);
+		p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
+		p->basexpr = q;
+		v->vdimfinish = 1;
+	}
+	doin_setbound = 0;
+}
+
+
+
+wr_abbrevs (outfile, function_head, vars)
+FILE *outfile;
+int function_head;
+chainp vars;
+{
+    for (; vars; vars = vars -> nextp) {
+	Namep name = (Namep) vars -> datap;
+	if (!name->visused)
+		continue;
+
+	if (function_head)
+	    nice_printf (outfile, "#define ");
+	else
+	    nice_printf (outfile, "#undef ");
+	out_name (outfile, name);
+
+	if (function_head) {
+	    Extsym *comm = &extsymtab[name -> vardesc.varno];
+
+	    nice_printf (outfile, " (");
+	    extern_out (outfile, comm);
+	    nice_printf (outfile, "%d.", comm->curno);
+	    nice_printf (outfile, "%s)", name->cvarname);
+	} /* if function_head */
+	nice_printf (outfile, "\n");
+    } /* for */
+} /* wr_abbrevs */