1/*	Id: proc.c,v 1.14 2008/12/24 17:40:41 sgk Exp 	*/
2/*	$NetBSD$	*/
3/*
4 * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * Redistributions of source code and documentation must retain the above
11 * copyright notice, this list of conditions and the following disclaimer.
12 * Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditionsand the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 * All advertising materials mentioning features or use of this software
16 * must display the following acknowledgement:
17 * 	This product includes software developed or owned by Caldera
18 *	International, Inc.
19 * Neither the name of Caldera International, Inc. nor the names of other
20 * contributors may be used to endorse or promote products derived from
21 * this software without specific prior written permission.
22 *
23 * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
24 * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
25 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
26 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
27 * DISCLAIMED.  IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
28 * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
29 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
30 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
31 * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
32 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
33 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 * POSSIBILITY OF SUCH DAMAGE.
35 */
36#include <string.h>
37
38#include "defines.h"
39#include "defs.h"
40
41LOCAL void doentry(struct entrypoint *ep);
42LOCAL void retval(int t);
43LOCAL void epicode(void);
44LOCAL void procode(void);
45LOCAL int nextarg(int);
46LOCAL int nextarg(int);
47LOCAL void dobss(void);
48LOCAL void docommon(void);
49LOCAL void docomleng(void);
50
51
52/* start a new procedure */
53
54void
55newproc()
56{
57	if(parstate != OUTSIDE) {
58		execerr("missing end statement");
59		endproc();
60	}
61
62	parstate = INSIDE;
63	procclass = CLMAIN;	/* default */
64}
65
66
67
68/* end of procedure. generate variables, epilogs, and prologs */
69
70void
71endproc()
72{
73	struct labelblock *lp;
74
75	if(parstate < INDATA)
76		enddcl();
77	if(ctlstack >= ctls)
78		err("DO loop or BLOCK IF not closed");
79	for(lp = labeltab ; lp < labtabend ; ++lp)
80		if(lp->stateno!=0 && lp->labdefined==NO)
81			err1("missing statement number %s",
82			    convic(lp->stateno) );
83
84	epicode();
85	procode();
86	dobss();
87	prdbginfo();
88
89	putbracket();
90
91	procinit();	/* clean up for next procedure */
92}
93
94
95
96/*
97 * End of declaration section of procedure.  Allocate storage.
98 */
99void
100enddcl()
101{
102	chainp p;
103
104	parstate = INEXEC;
105	docommon();
106	doequiv();
107	docomleng();
108	for(p = entries ; p ; p = p->entrypoint.nextp)
109		doentry(&p->entrypoint);
110}
111
112/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
113
114/*
115 * Called when a PROGRAM or BLOCK DATA statement is found, or if a statement
116 * is encountered outside of any block.
117 */
118void
119startproc(struct extsym *progname, int class)
120{
121	chainp p;
122
123	p = ALLOC(entrypoint);
124	if(class == CLMAIN) {
125		puthead("MAIN__");
126		newentry( mkname(5, "MAIN_") );
127	}
128	p->entrypoint.entryname = progname;
129	p->entrypoint.entrylabel = newlabel();
130	entries = p;
131
132	procclass = class;
133	retlabel = newlabel();
134	if (!quietflag) {
135		fprintf(diagfile, "   %s",
136		    (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
137		if (progname)
138			fprintf(diagfile, " %s",
139			    nounder(XL, procname = progname->extname));
140		fprintf(diagfile, ":\n");
141	}
142}
143
144/* subroutine or function statement */
145
146struct extsym *
147newentry(struct bigblock *v)
148{
149	struct extsym *p;
150
151	p = mkext( varunder(VL, v->b_name.varname) );
152
153	if (p==NULL || p->extinit ||
154	    !ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT))) {
155		if(p == 0)
156			dclerr("invalid entry name", v);
157		else
158			dclerr("external name already used", v);
159		return(0);
160	}
161	v->vstg = STGAUTO;
162	v->b_name.vprocclass = PTHISPROC;
163	v->vclass = CLPROC;
164	p->extstg = STGEXT;
165	p->extinit = YES;
166	return(p);
167}
168
169/*
170 * Called if a SUBROUTINE, FUNCTION or ENTRY statement is found.
171 */
172void
173entrypt(int class, int type, ftnint length, struct extsym *entry, chainp args)
174{
175	struct bigblock *q;
176	chainp p;
177
178	if(class != CLENTRY)
179		puthead( varstr(XL, procname = entry->extname) );
180	if (!quietflag) {
181		if (class == CLENTRY)
182			fprintf(diagfile, "       entry ");
183		fprintf(diagfile, "   %s:\n", nounder(XL, entry->extname));
184	}
185	q = mkname(VL, nounder(XL,entry->extname) );
186
187	if( (type = lengtype(type, (int) length)) != TYCHAR)
188		length = 0;
189
190	if(class == CLPROC) {
191		procclass = CLPROC;
192		proctype = type;
193		procleng = length;
194
195		retlabel = newlabel();
196		if(type == TYSUBR)
197			ret0label = newlabel();
198	}
199
200	p = ALLOC(entrypoint);
201	entries = hookup(entries, p);
202	p->entrypoint.entryname = entry;
203	p->entrypoint.arglist = args;
204	p->entrypoint.entrylabel = newlabel();
205	p->entrypoint.enamep = q;
206
207	if(class == CLENTRY) {
208		class = CLPROC;
209		if(proctype == TYSUBR)
210			type = TYSUBR;
211	}
212
213	q->vclass = class;
214	q->b_name.vprocclass = PTHISPROC;
215	settype(q, type, (int) length);
216	/* hold all initial entry points till end of declarations */
217	if(parstate >= INDATA)
218		doentry(&p->entrypoint);
219}
220
221/* generate epilogs */
222
223int multitypes = 0; /* XXX */
224
225LOCAL void
226epicode()
227{
228	int i;
229
230	if(procclass==CLPROC) {
231		if(proctype==TYSUBR) {
232			putlabel(ret0label);
233			if(substars)
234				putforce(TYINT, MKICON(0) );
235			putlabel(retlabel);
236			goret(TYSUBR);
237		} else	{
238			putlabel(retlabel);
239			if(multitypes) {
240				typeaddr = autovar(1, TYADDR, NULL);
241				putbranch( cpexpr(typeaddr) );
242				for(i = 0; i < NTYPES ; ++i) {
243					if(rtvlabel[i] != 0) {
244						putlabel(rtvlabel[i]);
245						retval(i);
246					}
247				}
248			} else
249				retval(proctype);
250		}
251	} else if(procclass != CLBLOCK) {
252		putlabel(retlabel);
253		goret(TYSUBR);
254	}
255}
256
257
258/* generate code to return value of type  t */
259
260LOCAL void
261retval(t)
262register int t;
263{
264register struct bigblock *p;
265
266switch(t)
267	{
268	case TYCHAR:
269	case TYCOMPLEX:
270	case TYDCOMPLEX:
271		break;
272
273	case TYLOGICAL:
274		t = tylogical;
275	case TYADDR:
276	case TYSHORT:
277	case TYLONG:
278		p = cpexpr(retslot);
279		p->vtype = t;
280		putforce(t, p);
281		break;
282
283	case TYREAL:
284	case TYDREAL:
285		p = cpexpr(retslot);
286		p->vtype = t;
287		putforce(t, p);
288		break;
289
290	default:
291		fatal1("retval: impossible type %d", t);
292	}
293goret(t);
294}
295
296
297/* Allocate extra argument array if needed. Generate prologs. */
298
299LOCAL void
300procode()
301{
302register chainp p;
303struct bigblock *argvec;
304
305	if(lastargslot>0 && nentry>1)
306		argvec = autovar(lastargslot/FSZADDR, TYADDR, NULL);
307	else
308		argvec = NULL;
309
310	for(p = entries ; p ; p = p->entrypoint.nextp)
311		prolog(&p->entrypoint, argvec);
312
313	putrbrack(procno);
314
315	prendproc();
316}
317
318/*
319   manipulate argument lists (allocate argument slot positions)
320 * keep track of return types and labels
321 */
322LOCAL void
323doentry(struct entrypoint *ep)
324{
325	int type;
326	struct bigblock *np, *q;
327	chainp p;
328
329	++nentry;
330	if(procclass == CLMAIN) {
331		putlabel(ep->entrylabel);
332		return;
333	} else if(procclass == CLBLOCK)
334		return;
335
336	impldcl(np = mkname(VL, nounder(XL, ep->entryname->extname)));
337	type = np->vtype;
338	if(proctype == TYUNKNOWN)
339		if( (proctype = type) == TYCHAR)
340			procleng = (np->vleng ? np->vleng->b_const.fconst.ci : (ftnint) 0);
341
342	if(proctype == TYCHAR) {
343		if(type != TYCHAR)
344			err("noncharacter entry of character function");
345		else if( (np->vleng ? np->vleng->b_const.fconst.ci : (ftnint) 0) != procleng)
346			err("mismatched character entry lengths");
347	} else if(type == TYCHAR)
348		err("character entry of noncharacter function");
349	else if(type != proctype)
350		multitype = YES;
351	if(rtvlabel[type] == 0)
352		rtvlabel[type] = newlabel();
353	ep->typelabel = rtvlabel[type];
354
355	if(type == TYCHAR) {
356		if(chslot < 0) {
357			chslot = nextarg(TYADDR);
358			chlgslot = nextarg(TYLENG);
359		}
360		np->vstg = STGARG;
361		np->b_name.vardesc.varno = chslot;
362		if(procleng == 0)
363			np->vleng = mkarg(TYLENG, chlgslot);
364	} else if( ISCOMPLEX(type) ) {
365		np->vstg = STGARG;
366		if(cxslot < 0)
367			cxslot = nextarg(TYADDR);
368		np->b_name.vardesc.varno = cxslot;
369	} else if(type != TYSUBR) {
370		if(nentry == 1)
371			retslot = autovar(1, TYDREAL, NULL);
372		np->vstg = STGAUTO;
373		np->b_name.voffset = retslot->b_addr.memoffset->b_const.fconst.ci;
374	}
375
376	for(p = ep->arglist ; p ; p = p->chain.nextp)
377		if(! ((q = p->chain.datap)->b_name.vdcldone) )
378			q->b_name.vardesc.varno = nextarg(TYADDR);
379
380	for(p = ep->arglist ; p ; p = p->chain.nextp)
381		if(! ((q = p->chain.datap)->b_name.vdcldone) ) {
382			impldcl(q);
383			q->b_name.vdcldone = YES;
384			if(q->vtype == TYCHAR) {
385				if(q->vleng == NULL)	/* character*(*) */
386					q->vleng = mkarg(TYLENG, nextarg(TYLENG) );
387				else if(nentry == 1)
388					nextarg(TYLENG);
389			} else if(q->vclass==CLPROC && nentry==1)
390				nextarg(TYLENG) ;
391		}
392	putlabel(ep->entrylabel);
393}
394
395
396
397LOCAL int
398nextarg(type)
399int type;
400{
401int k;
402k = lastargslot;
403lastargslot += typesize[type];
404return(k);
405}
406
407/* generate variable references */
408
409LOCAL void
410dobss()
411{
412register struct hashentry *p;
413register struct bigblock *q;
414register int i;
415int align;
416ftnint leng, iarrl;
417
418	setloc(UDATA);
419
420for(p = hashtab ; p<lasthash ; ++p)
421    if((q = p->varp))
422	{
423	if( (q->vclass==CLUNKNOWN && q->vstg!=STGARG) ||
424	    (q->vclass==CLVAR && q->vstg==STGUNKNOWN) )
425		warn1("local variable %s never used", varstr(VL,q->b_name.varname) );
426	else if(q->vclass==CLVAR && q->vstg==STGBSS)
427		{
428		align = (q->vtype==TYCHAR ? ALILONG : typealign[q->vtype]);
429		if(bssleng % align != 0)
430			{
431			bssleng = roundup(bssleng, align);
432			preven(align);
433			}
434		prlocvar( memname(STGBSS, q->b_name.vardesc.varno), iarrl = iarrlen(q) );
435		bssleng += iarrl;
436		}
437	else if(q->vclass==CLPROC && q->b_name.vprocclass==PEXTERNAL && q->vstg!=STGARG)
438		mkext(varunder(VL, q->b_name.varname)) ->extstg = STGEXT;
439
440	if(q->vclass==CLVAR && q->vstg!=STGARG)
441		{
442		if(q->b_name.vdim && !ISICON(q->b_name.vdim->nelt) )
443			dclerr("adjustable dimension on non-argument", q);
444		if(q->vtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
445			dclerr("adjustable leng on nonargument", q);
446		}
447	}
448
449for(i = 0 ; i < nequiv ; ++i)
450	if(eqvclass[i].eqvinit==NO && (leng = eqvclass[i].eqvleng)!=0 )
451		{
452		bssleng = roundup(bssleng, ALIDOUBLE);
453		preven(ALIDOUBLE);
454		prlocvar( memname(STGEQUIV, i), leng);
455		bssleng += leng;
456		}
457}
458
459
460
461void
462doext()
463{
464struct extsym *p;
465
466for(p = extsymtab ; p<nextext ; ++p)
467	prext( varstr(XL, p->extname), p->maxleng, p->extinit);
468}
469
470
471
472
473ftnint iarrlen(q)
474register struct bigblock *q;
475{
476ftnint leng;
477
478leng = typesize[q->vtype];
479if(leng <= 0)
480	return(-1);
481if(q->b_name.vdim) {
482	if( ISICON(q->b_name.vdim->nelt) )
483		leng *= q->b_name.vdim->nelt->b_const.fconst.ci;
484	else	return(-1);
485}
486if(q->vleng) {
487	if( ISICON(q->vleng) )
488		leng *= q->vleng->b_const.fconst.ci;
489	else 	return(-1);
490}
491return(leng);
492}
493
494LOCAL void
495docommon()
496{
497register struct extsym *p;
498register chainp q;
499struct dimblock *t;
500bigptr neltp;
501register struct bigblock *v;
502ftnint size;
503int type;
504
505for(p = extsymtab ; p<nextext ; ++p)
506	if(p->extstg==STGCOMMON)
507		{
508		for(q = p->extp ; q ; q = q->chain.nextp)
509			{
510			v = q->chain.datap;
511			if(v->b_name.vdcldone == NO)
512				vardcl(v);
513			type = v->vtype;
514			if(p->extleng % typealign[type] != 0)
515				{
516				dclerr("common alignment", v);
517				p->extleng = roundup(p->extleng, typealign[type]);
518				}
519			v->b_name.voffset = p->extleng;
520			v->b_name.vardesc.varno = p - extsymtab;
521			if(type == TYCHAR)
522				size = v->vleng->b_const.fconst.ci;
523			else	size = typesize[type];
524			if((t = v->b_name.vdim)) {
525				if( (neltp = t->nelt) && ISCONST(neltp) )
526					size *= neltp->b_const.fconst.ci;
527				else
528					dclerr("adjustable array in common", v);
529			}
530			p->extleng += size;
531			}
532
533		frchain( &(p->extp) );
534		}
535}
536
537
538
539
540
541LOCAL void
542docomleng()
543{
544register struct extsym *p;
545
546for(p = extsymtab ; p < nextext ; ++p)
547	if(p->extstg == STGCOMMON)
548		{
549		if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng &&
550		    !eqn(XL,"_BLNK__ ",p->extname) )
551			warn1("incompatible lengths for common block %s",
552				nounder(XL, p->extname) );
553		if(p->maxleng < p->extleng)
554			p->maxleng = p->extleng;
555		p->extleng = 0;
556	}
557}
558
559
560
561
562/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
563void
564frtemp(p)
565struct bigblock *p;
566{
567holdtemps = mkchain(p, holdtemps);
568}
569
570
571
572
573/* allocate an automatic variable slot */
574
575struct bigblock *
576autovar(int nelt, int t, bigptr lengp)
577{
578	ftnint leng = 0;
579	register struct bigblock *q;
580
581	if(t == TYCHAR) {
582		if( ISICON(lengp) )
583			leng = lengp->b_const.fconst.ci;
584		else
585			fatal("automatic variable of nonconstant length");
586	} else
587		leng = typesize[t];
588	autoleng = roundup( autoleng, typealign[t]);
589
590	q = BALLO();
591	q->tag = TADDR;
592	q->vtype = t;
593	if(t == TYCHAR)
594		q->vleng = MKICON(leng);
595	q->vstg = STGAUTO;
596	q->b_addr.ntempelt = nelt;
597#ifdef BACKAUTO
598	/* stack grows downward */
599	autoleng += nelt*leng;
600	q->b_addr.memoffset = MKICON( - autoleng );
601#else
602	q->b_addr.memoffset = MKICON( autoleng );
603	autoleng += nelt*leng;
604#endif
605
606	return(q);
607}
608
609
610struct bigblock *mktmpn(nelt, type, lengp)
611int nelt;
612register int type;
613bigptr lengp;
614{
615ftnint leng = 0; /* XXX gcc */
616chainp p, oldp;
617register struct bigblock *q;
618
619if(type==TYUNKNOWN || type==TYERROR)
620	fatal1("mktmpn: invalid type %d", type);
621
622if(type==TYCHAR) {
623	if( ISICON(lengp) )
624		leng = lengp->b_const.fconst.ci;
625	else	{
626		err("adjustable length");
627		return( errnode() );
628		}
629}
630for(oldp = (chainp)&templist ; (p = oldp->chain.nextp) ; oldp = p)
631	{
632	q = p->chain.datap;
633	if(q->vtype==type && q->b_addr.ntempelt==nelt &&
634	    (type!=TYCHAR || q->vleng->b_const.fconst.ci==leng) )
635		{
636		oldp->chain.nextp = p->chain.nextp;
637		ckfree(p);
638		return(q);
639		}
640	}
641q = autovar(nelt, type, lengp);
642q->b_addr.istemp = YES;
643return(q);
644}
645
646
647
648
649struct bigblock *fmktemp(type, lengp)
650int type;
651bigptr lengp;
652{
653return( mktmpn(1,type,lengp) );
654}
655
656/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
657
658struct extsym *comblock(len, s)
659register int len;
660register char *s;
661{
662struct extsym *p;
663
664if(len == 0)
665	{
666	s = BLANKCOMMON;
667	len = strlen(s);
668	}
669p = mkext( varunder(len, s) );
670if(p->extstg == STGUNKNOWN)
671	p->extstg = STGCOMMON;
672else if(p->extstg != STGCOMMON)
673	{
674	err1("%s cannot be a common block name", s);
675	return(0);
676	}
677
678return( p );
679}
680
681void
682incomm(c, v)
683struct extsym *c;
684struct bigblock *v;
685{
686if(v->vstg != STGUNKNOWN)
687	dclerr("incompatible common declaration", v);
688else
689	{
690	v->vstg = STGCOMMON;
691	c->extp = hookup(c->extp, mkchain(v,NULL) );
692	}
693}
694
695
696
697void
698settype(v, type, length)
699register struct bigblock * v;
700register int type;
701register int length;
702{
703if(type == TYUNKNOWN)
704	return;
705
706if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
707	{
708	v->vtype = TYSUBR;
709	frexpr(v->vleng);
710	}
711else if(type < 0)	/* storage class set */
712	{
713	if(v->vstg == STGUNKNOWN)
714		v->vstg = - type;
715	else if(v->vstg != -type)
716		dclerr("incompatible storage declarations", v);
717	}
718else if(v->vtype == TYUNKNOWN)
719	{
720	if( (v->vtype = lengtype(type, length))==TYCHAR && length!=0)
721		v->vleng = MKICON(length);
722	}
723else if(v->vtype!=type || (type==TYCHAR && v->vleng->b_const.fconst.ci!=length) )
724	dclerr("incompatible type declarations", v);
725}
726
727
728
729
730int
731lengtype(type, length)
732register int type;
733register int length;
734{
735switch(type)
736	{
737	case TYREAL:
738		if(length == 8)
739			return(TYDREAL);
740		if(length == 4)
741			goto ret;
742		break;
743
744	case TYCOMPLEX:
745		if(length == 16)
746			return(TYDCOMPLEX);
747		if(length == 8)
748			goto ret;
749		break;
750
751	case TYSHORT:
752	case TYDREAL:
753	case TYDCOMPLEX:
754	case TYCHAR:
755	case TYUNKNOWN:
756	case TYSUBR:
757	case TYERROR:
758		goto ret;
759
760	case TYLOGICAL:
761		if(length == 4)
762			goto ret;
763		break;
764
765	case TYLONG:
766		if(length == 0)
767			return(tyint);
768		if(length == 2)
769			return(TYSHORT);
770		if(length == 4)
771			goto ret;
772		break;
773	default:
774		fatal1("lengtype: invalid type %d", type);
775	}
776
777if(length != 0)
778	err("incompatible type-length combination");
779
780ret:
781	return(type);
782}
783
784
785
786
787void
788setintr(v)
789register struct bigblock * v;
790{
791register int k;
792
793if(v->vstg == STGUNKNOWN)
794	v->vstg = STGINTR;
795else if(v->vstg!=STGINTR)
796	dclerr("incompatible use of intrinsic function", v);
797if(v->vclass==CLUNKNOWN)
798	v->vclass = CLPROC;
799if(v->b_name.vprocclass == PUNKNOWN)
800	v->b_name.vprocclass = PINTRINSIC;
801else if(v->b_name.vprocclass != PINTRINSIC)
802	dclerr("invalid intrinsic declaration", v);
803if((k = intrfunct(v->b_name.varname)))
804	v->b_name.vardesc.varno = k;
805else
806	dclerr("unknown intrinsic function", v);
807}
808
809
810void
811setext(v)
812register struct bigblock * v;
813{
814if(v->vclass == CLUNKNOWN)
815	v->vclass = CLPROC;
816else if(v->vclass != CLPROC)
817	dclerr("invalid external declaration", v);
818
819if(v->b_name.vprocclass == PUNKNOWN)
820	v->b_name.vprocclass = PEXTERNAL;
821else if(v->b_name.vprocclass != PEXTERNAL)
822	dclerr("invalid external declaration", v);
823}
824
825
826
827
828/* create dimensions block for array variable */
829void
830setbound(v, nd, dims)
831register struct bigblock * v;
832int nd;
833struct uux dims[ ];
834{
835register bigptr q, t;
836register struct dimblock *p;
837int i;
838
839if(v->vclass == CLUNKNOWN)
840	v->vclass = CLVAR;
841else if(v->vclass != CLVAR)
842	{
843	dclerr("only variables may be arrays", v);
844	return;
845	}
846
847v->b_name.vdim = p = (struct dimblock *) ckalloc( sizeof(int) + (3+2*nd)*sizeof(bigptr) );
848p->ndim = nd;
849p->nelt = MKICON(1);
850
851for(i=0 ; i<nd ; ++i)
852	{
853	if( (q = dims[i].ub) == NULL)
854		{
855		if(i == nd-1)
856			{
857			frexpr(p->nelt);
858			p->nelt = NULL;
859			}
860		else
861			err("only last bound may be asterisk");
862		p->dims[i].dimsize = MKICON(1);;
863		p->dims[i].dimexpr = NULL;
864		}
865	else
866		{
867		if(dims[i].lb)
868			{
869			q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
870			q = mkexpr(OPPLUS, q, MKICON(1) );
871			}
872		if( ISCONST(q) )
873			{
874			p->dims[i].dimsize = q;
875			p->dims[i].dimexpr = NULL;
876			}
877		else	{
878			p->dims[i].dimsize = autovar(1, tyint, NULL);
879			p->dims[i].dimexpr = q;
880			}
881		if(p->nelt)
882			p->nelt = mkexpr(OPSTAR, p->nelt, cpexpr(p->dims[i].dimsize));
883		}
884	}
885
886q = dims[nd-1].lb;
887if(q == NULL)
888	q = MKICON(1);
889
890for(i = nd-2 ; i>=0 ; --i)
891	{
892	t = dims[i].lb;
893	if(t == NULL)
894		t = MKICON(1);
895	if(p->dims[i].dimsize)
896		q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
897	}
898
899if( ISCONST(q) )
900	{
901	p->baseoffset = q;
902	p->basexpr = NULL;
903	}
904else
905	{
906	p->baseoffset = autovar(1, tyint, NULL);
907	p->basexpr = q;
908	}
909}
910