[unix-history] / usr.bin / f2c / vax.c

/****************************************************************
Copyright 1990, 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 "pccdefs.h"
#include "output.h"

int regnum[] =  {
	11, 10, 9, 8, 7, 6 };

/* Put out a constant integer */

prconi(fp, n)
FILEP fp;
ftnint n;
{
	fprintf(fp, "\t%ld\n", n);
}


/* Put out a constant address */

prcona(fp, a)
FILEP fp;
ftnint a;
{
	fprintf(fp, "\tL%ld\n", a);
}


prconr(fp, x, k)
 FILEP fp;
 int k;
 Constp x;
{
	char *x0, *x1;
	char cdsbuf0[64], cdsbuf1[64];

	if (k > 1) {
		if (x->vstg) {
			x0 = x->Const.cds[0];
			x1 = x->Const.cds[1];
			}
		else {
			x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
			x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
			}
		fprintf(fp, "\t%s %s\n", x0, x1);
		}
	else
		fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
				: cds(dtos(x->Const.cd[0]), cdsbuf0));
}


char *memname(stg, mem)
 int stg;
 long mem;
{
	static char s[20];

	switch(stg)
	{
	case STGCOMMON:
	case STGEXT:
		sprintf(s, "_%s", extsymtab[mem].cextname);
		break;

	case STGBSS:
	case STGINIT:
		sprintf(s, "v.%ld", mem);
		break;

	case STGCONST:
		sprintf(s, "L%ld", mem);
		break;

	case STGEQUIV:
		sprintf(s, "q.%ld", mem+eqvstart);
		break;

	default:
		badstg("memname", stg);
	}
	return(s);
}

/* make_int_expr -- takes an arbitrary expression, and replaces all
   occurrences of arguments with indirection */

expptr make_int_expr (e)
expptr e;
{
    if (e != ENULL)
	switch (e -> tag) {
	    case TADDR:
	        if (e -> addrblock.vstg == STGARG
		 && !e->addrblock.isarray)
		    e = mkexpr (OPWHATSIN, e, ENULL);
	        break;
	    case TEXPR:
	        e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
	        e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
	        break;
	    default:
	        break;
	} /* switch */

    return e;
} /* make_int_expr */


/* prune_left_conv -- used in prolog() to strip type cast away from
   left-hand side of parameter adjustments.  This is necessary to avoid
   error messages from cktype() */

expptr prune_left_conv (e)
expptr e;
{
    struct Exprblock *leftp;

    if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
	    e -> exprblock.leftp -> tag == TEXPR) {
	leftp = &(e -> exprblock.leftp -> exprblock);
	if (leftp -> opcode == OPCONV) {
	    e -> exprblock.leftp = leftp -> leftp;
	    free ((charptr) leftp);
	}
    }

    return e;
} /* prune_left_conv */


 static int wrote_comment;
 static FILE *comment_file;

 static void
write_comment()
{
	if (!wrote_comment) {
		wrote_comment = 1;
		nice_printf (comment_file, "/* Parameter adjustments */\n");
		}
	}

 static int *
count_args()
{
	register int *ac;
	register chainp cp;
	register struct Entrypoint *ep;
	register Namep q;

	ac = (int *)ckalloc(nallargs*sizeof(int));

	for(ep = entries; ep; ep = ep->entnextp)
		for(cp = ep->arglist; cp; cp = cp->nextp)
			if (q = (Namep)cp->datap)
				ac[q->argno]++;
	return ac;
	}

 static int nu, *refs, *used;
 static void awalk();

 static void
aawalk(P)
 struct Primblock *P;
{
	chainp p;
	expptr q;

	for(p = P->argsp->listp; p; p = p->nextp) {
		q = (expptr)p->datap;
		if (q->tag != TCONST)
			awalk(q);
		}
	if (P->namep->vtype == TYCHAR) {
		if (q = P->fcharp)
			awalk(q);
		if (q = P->lcharp)
			awalk(q);
		}
	}

 static void
afwalk(P)
 struct Primblock *P;
{
	chainp p;
	expptr q;
	Namep np;

	for(p = P->argsp->listp; p; p = p->nextp) {
		q = (expptr)p->datap;
		switch(q->tag) {
		  case TPRIM:
			np = q->primblock.namep;
			if (np->vknownarg)
				if (!refs[np->argno]++)
					used[nu++] = np->argno;
			if (q->primblock.argsp == 0) {
				if (q->primblock.namep->vclass == CLPROC
				 && q->primblock.namep->vprocclass
						!= PTHISPROC
				 || q->primblock.namep->vdim != NULL)
					continue;
				}
		  default:
			awalk(q);
			/* no break */
		  case TCONST:
			continue;
		  }
		}
	}

 static void
awalk(e)
 expptr e;
{
	Namep np;
 top:
	if (!e)
		return;
	switch(e->tag) {
	  default:
		badtag("awalk", e);
	  case TCONST:
	  case TERROR:
	  case TLIST:
		return;
	  case TADDR:
		if (e->addrblock.uname_tag == UNAM_NAME) {
			np = e->addrblock.user.name;
			if (np->vknownarg && !refs[np->argno]++)
				used[nu++] = np->argno;
			}
		e = e->addrblock.memoffset;
		goto top;
	  case TPRIM:
		np = e->primblock.namep;
		if (np->vknownarg && !refs[np->argno]++)
			used[nu++] = np->argno;
		if (e->primblock.argsp && np->vclass != CLVAR)
			afwalk((struct Primblock *)e);
		else
			aawalk((struct Primblock *)e);
		return;
	  case TEXPR:
		awalk(e->exprblock.rightp);
		e = e->exprblock.leftp;
		goto top;
	  }
	}

 static chainp
argsort(p0)
 chainp p0;
{
	Namep *args, q, *stack;
	int i, nargs, nout, nst;
	chainp *d, *da, p, rv, *rvp;
	struct Dimblock *dp;

	if (!p0)
		return p0;
	for(nargs = 0, p = p0; p; p = p->nextp)
		nargs++;
	args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp)
			+ 2*sizeof(int)));
	memset((char *)args, 0, i);
	stack = args + nargs;
	d = (chainp *)(stack + nargs);
	refs = (int *)(d + nargs);
	used = refs + nargs;

	for(p = p0; p; p = p->nextp) {
		q = (Namep) p->datap;
		args[q->argno] = q;
		}
	for(p = p0; p; p = p->nextp) {
		q = (Namep) p->datap;
		if (!(dp = q->vdim))
			continue;
		i = dp->ndim;
		while(--i >= 0)
			awalk(dp->dims[i].dimexpr);
		awalk(dp->basexpr);
		while(nu > 0) {
			refs[i = used[--nu]] = 0;
			d[i] = mkchain((char *)q, d[i]);
			}
		}
	for(i = nst = 0; i < nargs; i++)
		for(p = d[i]; p; p = p->nextp)
			refs[((Namep)p->datap)->argno]++;
	while(--i >= 0)
		if (!refs[i])
			stack[nst++] = args[i];
	if (nst == nargs) {
		rv = p0;
		goto done;
		}
	nout = 0;
	rv = 0;
	rvp = &rv;
	while(nst > 0) {
		nout++;
		q = stack[--nst];
		*rvp = p = mkchain((char *)q, CHNULL);
		rvp = &p->nextp;
		da = d + q->argno;
		for(p = *da; p; p = p->nextp)
			if (!--refs[(q = (Namep)p->datap)->argno])
				stack[nst++] = q;
		frchain(*da);
		}
	if (nout < nargs)
		for(i = 0; i < nargs; i++)
			if (refs[i]) {
				q = args[i];
				errstr("Can't adjust %.38s correctly\n\
	due to dependencies among arguments.",
					q->fvarname);
				*rvp = p = mkchain((char *)q, CHNULL);
				rvp = &p->nextp;
				frchain(d[i]);
				}
 done:
	free((char *)args);
	return rv;
	}

prolog(outfile, p)
 FILE *outfile;
 register chainp p;
{
	int addif, addif0, i, nd, size;
	int *ac;
	register Namep q;
	register struct Dimblock *dp;
	chainp p0, p1;

	if(procclass == CLBLOCK)
		return;
	p0 = p;
	p1 = p = argsort(p);
	wrote_comment = 0;
	comment_file = outfile;
	ac = 0;

/* Compute the base addresses and offsets for the array parameters, and
   assign these values to local variables */

	addif = addif0 = nentry > 1;
	for(; p ; p = p->nextp)
	{
	    q = (Namep) p->datap;
	    if(dp = q->vdim)	/* if this param is an array ... */
	    {
		expptr Q, expr;

		/* See whether to protect the following with an if. */
		/* This only happens when there are multiple entries. */

		nd = dp->ndim - 1;
		if (addif0) {
			if (!ac)
				ac = count_args();
			if (ac[q->argno] == nentry)
				addif = 0;
			else if (dp->basexpr
				    || dp->baseoffset->constblock.Const.ci)
				addif = 1;
			else for(addif = i = 0; i <= nd; i++)
				if (dp->dims[i].dimexpr
				&& (i < nd || !q->vlastdim)) {
					addif = 1;
					break;
					}
			if (addif) {
				write_comment();
				nice_printf(outfile, "if (%s) {\n", /*}*/
						q->cvarname);
				next_tab(outfile);
				}
			}
		for(i = 0 ; i <= nd; ++i)

/* Store the variable length of each dimension (which is fixed upon
   runtime procedure entry) into a local variable */

		    if ((Q = dp->dims[i].dimexpr)
			&& (i < nd || !q->vlastdim)) {
			expr = (expptr)cpexpr(Q);
			write_comment();
			out_and_free_statement (outfile, mkexpr (OPASSIGN,
				fixtype(cpexpr(dp->dims[i].dimsize)), expr));
		    } /* if dp -> dims[i].dimexpr */

/* size   will equal the size of a single element, or -1 if the type is
   variable length character type */

		size = typesize[ q->vtype ];
		if(q->vtype == TYCHAR)
		    if( ISICON(q->vleng) )
			size *= q->vleng->constblock.Const.ci;
		    else
			size = -1;

		/* Fudge the argument pointers for arrays so subscripts
		 * are 0-based. Not done if array bounds are being checked.
		 */
		if(dp->basexpr) {

/* Compute the base offset for this procedure */

		    write_comment();
		    out_and_free_statement (outfile, mkexpr (OPASSIGN,
			    cpexpr(fixtype(dp->baseoffset)),
			    cpexpr(fixtype(dp->basexpr))));
		} /* if dp -> basexpr */

		if(! checksubs) {
		    if(dp->basexpr) {
			expptr tp;

/* If the base of this array has a variable adjustment ... */

			tp = (expptr) cpexpr (dp -> baseoffset);
			if(size < 0 || q -> vtype == TYCHAR)
			    tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));

			write_comment();
			tp = mkexpr (OPMINUSEQ,
				mkconv (TYADDR, (expptr)p->datap),
				mkconv(TYINT, fixtype
				(fixtype (tp))));
/* Avoid type clash by removing the type conversion */
			tp = prune_left_conv (tp);
			out_and_free_statement (outfile, tp);
		    } else if(dp->baseoffset->constblock.Const.ci != 0) {

/* if the base of this array has a nonzero constant adjustment ... */

			expptr tp;

			write_comment();
			if(size > 0 && q -> vtype != TYCHAR) {
			    tp = prune_left_conv (mkexpr (OPMINUSEQ,
				    mkconv (TYADDR, (expptr)p->datap),
				    mkconv (TYINT, fixtype
				    (cpexpr (dp->baseoffset)))));
			    out_and_free_statement (outfile, tp);
			} else {
			    tp = prune_left_conv (mkexpr (OPMINUSEQ,
				    mkconv (TYADDR, (expptr)p->datap),
				    mkconv (TYINT, fixtype
				    (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
				    cpexpr (q -> vleng))))));
			    out_and_free_statement (outfile, tp);
			} /* else */
		    } /* if dp -> baseoffset -> const */
		} /* if !checksubs */

		if (addif) {
			nice_printf(outfile, /*{*/ "}\n");
			prev_tab(outfile);
			}
	    }
	}
	if (wrote_comment)
	    nice_printf (outfile, "\n/* Function Body */\n");
	if (ac)
		free((char *)ac);
	if (p0 != p1)
		frchain(p1);
} /* prolog */
Commit	Line	Data
f1525c23 WH	1	/****************************************************************
	2	Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
	3
	4	Permission to use, copy, modify, and distribute this software
	5	and its documentation for any purpose and without fee is hereby
	6	granted, provided that the above copyright notice appear in all
	7	copies and that both that the copyright notice and this
	8	permission notice and warranty disclaimer appear in supporting
	9	documentation, and that the names of AT&T Bell Laboratories or
	10	Bellcore or any of their entities not be used in advertising or
	11	publicity pertaining to distribution of the software without
	12	specific, written prior permission.
	13
	14	AT&T and Bellcore disclaim all warranties with regard to this
	15	software, including all implied warranties of merchantability
	16	and fitness. In no event shall AT&T or Bellcore be liable for
	17	any special, indirect or consequential damages or any damages
	18	whatsoever resulting from loss of use, data or profits, whether
	19	in an action of contract, negligence or other tortious action,
	20	arising out of or in connection with the use or performance of
	21	this software.
	22	****************************************************************/
	23
	24	#include "defs.h"
	25	#include "pccdefs.h"
	26	#include "output.h"
	27
	28	int regnum[] = {
	29	11, 10, 9, 8, 7, 6 };
	30
	31	/* Put out a constant integer */
	32
	33	prconi(fp, n)
	34	FILEP fp;
	35	ftnint n;
	36	{
	37	fprintf(fp, "\t%ld\n", n);
	38	}
	39
	40
	41
	42	/* Put out a constant address */
	43
	44	prcona(fp, a)
	45	FILEP fp;
	46	ftnint a;
	47	{
	48	fprintf(fp, "\tL%ld\n", a);
	49	}
	50
	51
	52
	53	prconr(fp, x, k)
	54	FILEP fp;
	55	int k;
	56	Constp x;
	57	{
	58	char x0, x1;
	59	char cdsbuf0[64], cdsbuf1[64];
	60
	61	if (k > 1) {
	62	if (x->vstg) {
	63	x0 = x->Const.cds[0];
	64	x1 = x->Const.cds[1];
65	}
66	else {
67	x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
68	x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
69	}
70	fprintf(fp, "\t%s %s\n", x0, x1);
71	}
72	else
73	fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
74	: cds(dtos(x->Const.cd[0]), cdsbuf0));
75	}
76
77
78	char *memname(stg, mem)
79	int stg;
80	long mem;
81	{
82	static char s[20];
83
84	switch(stg)
85	{
86	case STGCOMMON:
87	case STGEXT:
88	sprintf(s, "_%s", extsymtab[mem].cextname);
89	break;
90
91	case STGBSS:
92	case STGINIT:
93	sprintf(s, "v.%ld", mem);
94	break;
95
96	case STGCONST:
97	sprintf(s, "L%ld", mem);
98	break;
99
100	case STGEQUIV:
101	sprintf(s, "q.%ld", mem+eqvstart);
102	break;
103
104	default:
105	badstg("memname", stg);
106	}
107	return(s);
108	}
109
110	/* make_int_expr -- takes an arbitrary expression, and replaces all
111	occurrences of arguments with indirection */
112
113	expptr make_int_expr (e)
114	expptr e;
115	{
116	if (e != ENULL)
117	switch (e -> tag) {
118	case TADDR:
119	if (e -> addrblock.vstg == STGARG
120	&& !e->addrblock.isarray)
121	e = mkexpr (OPWHATSIN, e, ENULL);
122	break;
123	case TEXPR:
124	e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
125	e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
126	break;
127	default:
128	break;
129	} /* switch */
130
131	return e;
132	} /* make_int_expr */
133
134
135
136	/* prune_left_conv -- used in prolog() to strip type cast away from
137	left-hand side of parameter adjustments. This is necessary to avoid
138	error messages from cktype() */
139
140	expptr prune_left_conv (e)
141	expptr e;
142	{
143	struct Exprblock *leftp;
144
145	if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
146	e -> exprblock.leftp -> tag == TEXPR) {
147	leftp = &(e -> exprblock.leftp -> exprblock);
148	if (leftp -> opcode == OPCONV) {
149	e -> exprblock.leftp = leftp -> leftp;
150	free ((charptr) leftp);
151	}
152	}
153
154	return e;
155	} /* prune_left_conv */
156
157
158	static int wrote_comment;
159	static FILE *comment_file;
160
161	static void
162	write_comment()
163	{
164	if (!wrote_comment) {
165	wrote_comment = 1;
166	nice_printf (comment_file, "/* Parameter adjustments */\n");
167	}
168	}
169
170	static int *
171	count_args()
172	{
173	register int *ac;
174	register chainp cp;
175	register struct Entrypoint *ep;
176	register Namep q;
177
178	ac = (int )ckalloc(nallargssizeof(int));
179
180	for(ep = entries; ep; ep = ep->entnextp)
181	for(cp = ep->arglist; cp; cp = cp->nextp)
182	if (q = (Namep)cp->datap)
183	ac[q->argno]++;
184	return ac;
185	}
186
187	static int nu, refs, used;
188	static void awalk();
189
190	static void
191	aawalk(P)
192	struct Primblock *P;
193	{
194	chainp p;
195	expptr q;
196
197	for(p = P->argsp->listp; p; p = p->nextp) {
198	q = (expptr)p->datap;
199	if (q->tag != TCONST)
200	awalk(q);
201	}
202	if (P->namep->vtype == TYCHAR) {
203	if (q = P->fcharp)
204	awalk(q);
205	if (q = P->lcharp)
206	awalk(q);
207	}
208	}
209
210	static void
211	afwalk(P)
212	struct Primblock *P;
213	{
214	chainp p;
215	expptr q;
216	Namep np;
217
218	for(p = P->argsp->listp; p; p = p->nextp) {
219	q = (expptr)p->datap;
220	switch(q->tag) {
221	case TPRIM:
222	np = q->primblock.namep;
223	if (np->vknownarg)
224	if (!refs[np->argno]++)
225	used[nu++] = np->argno;
226	if (q->primblock.argsp == 0) {
227	if (q->primblock.namep->vclass == CLPROC
228	&& q->primblock.namep->vprocclass
229	!= PTHISPROC
230	\|\| q->primblock.namep->vdim != NULL)
231	continue;
232	}
233	default:
234	awalk(q);
235	/* no break */
236	case TCONST:
237	continue;
238	}
239	}
240	}
241
242	static void
243	awalk(e)
244	expptr e;
245	{
246	Namep np;
247	top:
248	if (!e)
249	return;
250	switch(e->tag) {
251	default:
252	badtag("awalk", e);
253	case TCONST:
254	case TERROR:
255	case TLIST:
256	return;
257	case TADDR:
258	if (e->addrblock.uname_tag == UNAM_NAME) {
259	np = e->addrblock.user.name;
260	if (np->vknownarg && !refs[np->argno]++)
261	used[nu++] = np->argno;
262	}
263	e = e->addrblock.memoffset;
264	goto top;
265	case TPRIM:
266	np = e->primblock.namep;
267	if (np->vknownarg && !refs[np->argno]++)
268	used[nu++] = np->argno;
269	if (e->primblock.argsp && np->vclass != CLVAR)
270	afwalk((struct Primblock *)e);
271	else
272	aawalk((struct Primblock *)e);
273	return;
274	case TEXPR:
275	awalk(e->exprblock.rightp);
276	e = e->exprblock.leftp;
277	goto top;
278	}
279	}
280
281	static chainp
282	argsort(p0)
283	chainp p0;
284	{
285	Namep args, q, stack;
286	int i, nargs, nout, nst;
287	chainp d, da, p, rv, *rvp;
288	struct Dimblock *dp;
289
290	if (!p0)
291	return p0;
292	for(nargs = 0, p = p0; p; p = p->nextp)
293	nargs++;
294	args = (Namep )ckalloc(i = nargs(sizeof(Namep) + 2*sizeof(chainp)
295	+ 2*sizeof(int)));
296	memset((char *)args, 0, i);
297	stack = args + nargs;
298	d = (chainp *)(stack + nargs);
299	refs = (int *)(d + nargs);
300	used = refs + nargs;
301
302	for(p = p0; p; p = p->nextp) {
303	q = (Namep) p->datap;
304	args[q->argno] = q;
305	}
306	for(p = p0; p; p = p->nextp) {
307	q = (Namep) p->datap;
308	if (!(dp = q->vdim))
309	continue;
310	i = dp->ndim;
311	while(--i >= 0)
312	awalk(dp->dims[i].dimexpr);
313	awalk(dp->basexpr);
314	while(nu > 0) {
315	refs[i = used[--nu]] = 0;
316	d[i] = mkchain((char *)q, d[i]);
317	}
318	}
319	for(i = nst = 0; i < nargs; i++)
320	for(p = d[i]; p; p = p->nextp)
321	refs[((Namep)p->datap)->argno]++;
322	while(--i >= 0)
323	if (!refs[i])
324	stack[nst++] = args[i];
325	if (nst == nargs) {
326	rv = p0;
327	goto done;
328	}
329	nout = 0;
330	rv = 0;
331	rvp = &rv;
332	while(nst > 0) {
333	nout++;
334	q = stack[--nst];
335	rvp = p = mkchain((char )q, CHNULL);
336	rvp = &p->nextp;
337	da = d + q->argno;
338	for(p = *da; p; p = p->nextp)
339	if (!--refs[(q = (Namep)p->datap)->argno])
340	stack[nst++] = q;
341	frchain(*da);
342	}
343	if (nout < nargs)
344	for(i = 0; i < nargs; i++)
345	if (refs[i]) {
346	q = args[i];
347	errstr("Can't adjust %.38s correctly\n\
348	due to dependencies among arguments.",
349	q->fvarname);
350	rvp = p = mkchain((char )q, CHNULL);
351	rvp = &p->nextp;
352	frchain(d[i]);
353	}
354	done:
355	free((char *)args);
356	return rv;
357	}
358
359	prolog(outfile, p)
360	FILE *outfile;
361	register chainp p;
362	{
363	int addif, addif0, i, nd, size;
364	int *ac;
365	register Namep q;
366	register struct Dimblock *dp;
367	chainp p0, p1;
368
369	if(procclass == CLBLOCK)
370	return;
371	p0 = p;
372	p1 = p = argsort(p);
373	wrote_comment = 0;
374	comment_file = outfile;
375	ac = 0;
376
377	/* Compute the base addresses and offsets for the array parameters, and
378	assign these values to local variables */
379
380	addif = addif0 = nentry > 1;
381	for(; p ; p = p->nextp)
382	{
383	q = (Namep) p->datap;
384	if(dp = q->vdim) /* if this param is an array ... */
385	{
386	expptr Q, expr;
387
388	/* See whether to protect the following with an if. */
389	/* This only happens when there are multiple entries. */
390
391	nd = dp->ndim - 1;
392	if (addif0) {
393	if (!ac)
394	ac = count_args();
395	if (ac[q->argno] == nentry)
396	addif = 0;
397	else if (dp->basexpr
398	\|\| dp->baseoffset->constblock.Const.ci)
399	addif = 1;
400	else for(addif = i = 0; i <= nd; i++)
401	if (dp->dims[i].dimexpr
402	&& (i < nd \|\| !q->vlastdim)) {
403	addif = 1;
404	break;
405	}
406	if (addif) {
407	write_comment();
408	nice_printf(outfile, "if (%s) {\n", /}/
409	q->cvarname);
410	next_tab(outfile);
411	}
412	}
413	for(i = 0 ; i <= nd; ++i)
414
415	/* Store the variable length of each dimension (which is fixed upon
416	runtime procedure entry) into a local variable */
417
418	if ((Q = dp->dims[i].dimexpr)
419	&& (i < nd \|\| !q->vlastdim)) {
420	expr = (expptr)cpexpr(Q);
421	write_comment();
422	out_and_free_statement (outfile, mkexpr (OPASSIGN,
423	fixtype(cpexpr(dp->dims[i].dimsize)), expr));
424	} /* if dp -> dims[i].dimexpr */
425
426	/* size will equal the size of a single element, or -1 if the type is
427	variable length character type */
428
429	size = typesize[ q->vtype ];
430	if(q->vtype == TYCHAR)
431	if( ISICON(q->vleng) )
432	size *= q->vleng->constblock.Const.ci;
433	else
434	size = -1;
435
436	/* Fudge the argument pointers for arrays so subscripts
437	* are 0-based. Not done if array bounds are being checked.
438	*/
439	if(dp->basexpr) {
440
441	/* Compute the base offset for this procedure */
442
443	write_comment();
444	out_and_free_statement (outfile, mkexpr (OPASSIGN,
445	cpexpr(fixtype(dp->baseoffset)),
446	cpexpr(fixtype(dp->basexpr))));
447	} /* if dp -> basexpr */
448
449	if(! checksubs) {
450	if(dp->basexpr) {
451	expptr tp;
452
453	/* If the base of this array has a variable adjustment ... */
454
455	tp = (expptr) cpexpr (dp -> baseoffset);
456	if(size < 0 \|\| q -> vtype == TYCHAR)
457	tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
458
459	write_comment();
460	tp = mkexpr (OPMINUSEQ,
461	mkconv (TYADDR, (expptr)p->datap),
462	mkconv(TYINT, fixtype
463	(fixtype (tp))));
464	/* Avoid type clash by removing the type conversion */
465	tp = prune_left_conv (tp);
466	out_and_free_statement (outfile, tp);
467	} else if(dp->baseoffset->constblock.Const.ci != 0) {
468
469	/* if the base of this array has a nonzero constant adjustment ... */
470
471	expptr tp;
472
473	write_comment();
474	if(size > 0 && q -> vtype != TYCHAR) {
475	tp = prune_left_conv (mkexpr (OPMINUSEQ,
476	mkconv (TYADDR, (expptr)p->datap),
477	mkconv (TYINT, fixtype
478	(cpexpr (dp->baseoffset)))));
479	out_and_free_statement (outfile, tp);
480	} else {
481	tp = prune_left_conv (mkexpr (OPMINUSEQ,
482	mkconv (TYADDR, (expptr)p->datap),
483	mkconv (TYINT, fixtype
484	(mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
485	cpexpr (q -> vleng))))));
486	out_and_free_statement (outfile, tp);
487	} /* else */
488	} /* if dp -> baseoffset -> const */
489	} /* if !checksubs */
490
491	if (addif) {
492	nice_printf(outfile, /{/ "}\n");
493	prev_tab(outfile);
494	}
495	}
496	}
497	if (wrote_comment)
498	nice_printf (outfile, "\n/* Function Body */\n");
499	if (ac)
500	free((char *)ac);
501	if (p0 != p1)
502	frchain(p1);
503	} /* prolog */