1 /* Id: proc.c,v 1.14 2008/12/24 17:40:41 sgk Exp */
2 /* $NetBSD: proc.c,v 1.1.1.3 2010/06/03 18:57:51 plunky Exp $ */
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
41 LOCAL void doentry(struct entrypoint *ep);
42 LOCAL void retval(int t);
43 LOCAL void epicode(void);
44 LOCAL void procode(void);
45 LOCAL int nextarg(int);
46 LOCAL int nextarg(int);
47 LOCAL void dobss(void);
48 LOCAL void docommon(void);
49 LOCAL void docomleng(void);
50
51
52 /* start a new procedure */
53
54 void
newproc()55 newproc()
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
70 void
endproc()71 endproc()
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 */
99 void
enddcl()100 enddcl()
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 */
118 void
startproc(struct extsym * progname,int class)119 startproc(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
146 struct extsym *
newentry(struct bigblock * v)147 newentry(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 */
172 void
entrypt(int class,int type,ftnint length,struct extsym * entry,chainp args)173 entrypt(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
223 int multitypes = 0; /* XXX */
224
225 LOCAL void
epicode()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
retval(t)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
procode()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
doentry(struct entrypoint * ep)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
nextarg(type)398 nextarg(type)
399 int type;
400 {
401 int k;
402 k = lastargslot;
403 lastargslot += typesize[type];
404 return(k);
405 }
406
407 /* generate variable references */
408
409 LOCAL void
dobss()410 dobss()
411 {
412 register struct hashentry *p;
413 register struct bigblock *q;
414 register int i;
415 int align;
416 ftnint leng, iarrl;
417
418 setloc(UDATA);
419
420 for(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
449 for(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
461 void
doext()462 doext()
463 {
464 struct extsym *p;
465
466 for(p = extsymtab ; p<nextext ; ++p)
467 prext( varstr(XL, p->extname), p->maxleng, p->extinit);
468 }
469
470
471
472
iarrlen(q)473 ftnint iarrlen(q)
474 register struct bigblock *q;
475 {
476 ftnint leng;
477
478 leng = typesize[q->vtype];
479 if(leng <= 0)
480 return(-1);
481 if(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 }
486 if(q->vleng) {
487 if( ISICON(q->vleng) )
488 leng *= q->vleng->b_const.fconst.ci;
489 else return(-1);
490 }
491 return(leng);
492 }
493
494 LOCAL void
docommon()495 docommon()
496 {
497 register struct extsym *p;
498 register chainp q;
499 struct dimblock *t;
500 bigptr neltp;
501 register struct bigblock *v;
502 ftnint size;
503 int type;
504
505 for(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
541 LOCAL void
docomleng()542 docomleng()
543 {
544 register struct extsym *p;
545
546 for(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 */
563 void
frtemp(p)564 frtemp(p)
565 struct bigblock *p;
566 {
567 holdtemps = mkchain(p, holdtemps);
568 }
569
570
571
572
573 /* allocate an automatic variable slot */
574
575 struct bigblock *
autovar(int nelt,int t,bigptr lengp)576 autovar(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
mktmpn(nelt,type,lengp)610 struct bigblock *mktmpn(nelt, type, lengp)
611 int nelt;
612 register int type;
613 bigptr lengp;
614 {
615 ftnint leng = 0; /* XXX gcc */
616 chainp p, oldp;
617 register struct bigblock *q;
618
619 if(type==TYUNKNOWN || type==TYERROR)
620 fatal1("mktmpn: invalid type %d", type);
621
622 if(type==TYCHAR) {
623 if( ISICON(lengp) )
624 leng = lengp->b_const.fconst.ci;
625 else {
626 err("adjustable length");
627 return( errnode() );
628 }
629 }
630 for(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 }
641 q = autovar(nelt, type, lengp);
642 q->b_addr.istemp = YES;
643 return(q);
644 }
645
646
647
648
fmktemp(type,lengp)649 struct bigblock *fmktemp(type, lengp)
650 int type;
651 bigptr lengp;
652 {
653 return( mktmpn(1,type,lengp) );
654 }
655
656 /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
657
comblock(len,s)658 struct extsym *comblock(len, s)
659 register int len;
660 register char *s;
661 {
662 struct extsym *p;
663
664 if(len == 0)
665 {
666 s = BLANKCOMMON;
667 len = strlen(s);
668 }
669 p = mkext( varunder(len, s) );
670 if(p->extstg == STGUNKNOWN)
671 p->extstg = STGCOMMON;
672 else if(p->extstg != STGCOMMON)
673 {
674 err1("%s cannot be a common block name", s);
675 return(0);
676 }
677
678 return( p );
679 }
680
681 void
incomm(c,v)682 incomm(c, v)
683 struct extsym *c;
684 struct bigblock *v;
685 {
686 if(v->vstg != STGUNKNOWN)
687 dclerr("incompatible common declaration", v);
688 else
689 {
690 v->vstg = STGCOMMON;
691 c->extp = hookup(c->extp, mkchain(v,NULL) );
692 }
693 }
694
695
696
697 void
settype(v,type,length)698 settype(v, type, length)
699 register struct bigblock * v;
700 register int type;
701 register int length;
702 {
703 if(type == TYUNKNOWN)
704 return;
705
706 if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
707 {
708 v->vtype = TYSUBR;
709 frexpr(v->vleng);
710 }
711 else 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 }
718 else if(v->vtype == TYUNKNOWN)
719 {
720 if( (v->vtype = lengtype(type, length))==TYCHAR && length!=0)
721 v->vleng = MKICON(length);
722 }
723 else if(v->vtype!=type || (type==TYCHAR && v->vleng->b_const.fconst.ci!=length) )
724 dclerr("incompatible type declarations", v);
725 }
726
727
728
729
730 int
lengtype(type,length)731 lengtype(type, length)
732 register int type;
733 register int length;
734 {
735 switch(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
777 if(length != 0)
778 err("incompatible type-length combination");
779
780 ret:
781 return(type);
782 }
783
784
785
786
787 void
setintr(v)788 setintr(v)
789 register struct bigblock * v;
790 {
791 register int k;
792
793 if(v->vstg == STGUNKNOWN)
794 v->vstg = STGINTR;
795 else if(v->vstg!=STGINTR)
796 dclerr("incompatible use of intrinsic function", v);
797 if(v->vclass==CLUNKNOWN)
798 v->vclass = CLPROC;
799 if(v->b_name.vprocclass == PUNKNOWN)
800 v->b_name.vprocclass = PINTRINSIC;
801 else if(v->b_name.vprocclass != PINTRINSIC)
802 dclerr("invalid intrinsic declaration", v);
803 if((k = intrfunct(v->b_name.varname)))
804 v->b_name.vardesc.varno = k;
805 else
806 dclerr("unknown intrinsic function", v);
807 }
808
809
810 void
setext(v)811 setext(v)
812 register struct bigblock * v;
813 {
814 if(v->vclass == CLUNKNOWN)
815 v->vclass = CLPROC;
816 else if(v->vclass != CLPROC)
817 dclerr("invalid external declaration", v);
818
819 if(v->b_name.vprocclass == PUNKNOWN)
820 v->b_name.vprocclass = PEXTERNAL;
821 else if(v->b_name.vprocclass != PEXTERNAL)
822 dclerr("invalid external declaration", v);
823 }
824
825
826
827
828 /* create dimensions block for array variable */
829 void
setbound(v,nd,dims)830 setbound(v, nd, dims)
831 register struct bigblock * v;
832 int nd;
833 struct uux dims[ ];
834 {
835 register bigptr q, t;
836 register struct dimblock *p;
837 int i;
838
839 if(v->vclass == CLUNKNOWN)
840 v->vclass = CLVAR;
841 else if(v->vclass != CLVAR)
842 {
843 dclerr("only variables may be arrays", v);
844 return;
845 }
846
847 v->b_name.vdim = p = (struct dimblock *) ckalloc( sizeof(int) + (3+2*nd)*sizeof(bigptr) );
848 p->ndim = nd;
849 p->nelt = MKICON(1);
850
851 for(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
886 q = dims[nd-1].lb;
887 if(q == NULL)
888 q = MKICON(1);
889
890 for(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
899 if( ISCONST(q) )
900 {
901 p->baseoffset = q;
902 p->basexpr = NULL;
903 }
904 else
905 {
906 p->baseoffset = autovar(1, tyint, NULL);
907 p->basexpr = q;
908 }
909 }
910