Context Navigation

source: mainline/uspace/app/pcc/f77/fcom/proc.c@ 5974661

Visit:

lfn serial ticket/834-toolchain-update topic/msim-upgrade topic/simplify-dev-export

Last change on this file since 5974661 was a7de7182, checked in by Jiří Zárevúcky <zarevucky.jiri@…>, 14 years ago
Added pcc source tree (contents of pcc-1.0.0.tgz)
Property mode set to `100644`
File size: 17.9 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: