1 /****************************************************************
2 Copyright 1990, 1994-6, 2000-2001 by AT&T, Lucent Technologies 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,
10 Lucent or Bellcore or any of their entities not be used in
11 advertising or publicity pertaining to distribution of the
12 software without specific, written prior permission.
13
14 AT&T, Lucent and Bellcore disclaim all warranties with regard to
15 this software, including all implied warranties of
16 merchantability and fitness. In no event shall AT&T, Lucent or
17 Bellcore be liable for any special, indirect or consequential
18 damages or any damages whatsoever resulting from loss of use,
19 data or profits, whether in an action of contract, negligence or
20 other tortious action, arising out of or in connection with the
21 use or performance of this software.
22 ****************************************************************/
23
24 #include "defs.h"
25 #include "names.h"
26 #include "output.h"
27 #include "p1defs.h"
28
29 /* round a up to the nearest multiple of b:
30
31 a = b * floor ( (a + (b - 1)) / b )*/
32
33 #undef roundup
34 #define roundup(a,b) ( b * ( (a+b-1)/b) )
35
36 #define EXNULL (union Expression *)0
37
38 static void dobss Argdcl((void));
39 static void docomleng Argdcl((void));
40 static void docommon Argdcl((void));
41 static void doentry Argdcl((struct Entrypoint*));
42 static void epicode Argdcl((void));
43 static int nextarg Argdcl((int));
44 static void retval Argdcl((int));
45
46 static char Blank[] = BLANKCOMMON;
47
48 static char *postfix[] = { "g", "h", "i",
49 #ifdef TYQUAD
50 "j",
51 #endif
52 "r", "d", "c", "z", "g", "h", "i" };
53
54 chainp new_procs;
55 int prev_proc, proc_argchanges, proc_protochanges;
56
57 void
58 #ifdef KR_headers
changedtype(q)59 changedtype(q)
60 Namep q;
61 #else
62 changedtype(Namep q)
63 #endif
64 {
65 char buf[200];
66 int qtype, type1;
67 register Extsym *e;
68 Argtypes *at;
69
70 if (q->vtypewarned)
71 return;
72 q->vtypewarned = 1;
73 qtype = q->vtype;
74 e = &extsymtab[q->vardesc.varno];
75 if (!(at = e->arginfo)) {
76 if (!e->exused)
77 return;
78 }
79 else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
80 proc_protochanges++;
81 type1 = e->extype;
82 if (type1 == TYUNKNOWN)
83 return;
84 if (qtype == TYUNKNOWN)
85 /* e.g.,
86 subroutine foo
87 end
88 external foo
89 call goo(foo)
90 end
91 */
92 return;
93 sprintf(buf, "%.90s: inconsistent declarations:\n\
94 here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
95 qtype == TYSUBR ? "" : " function",
96 ftn_types[type1], type1 == TYSUBR ? "" : " function");
97 warn(buf);
98 }
99
100 void
101 #ifdef KR_headers
unamstring(q,s)102 unamstring(q, s)
103 register Addrp q;
104 register char *s;
105 #else
106 unamstring(register Addrp q, register char *s)
107 #endif
108 {
109 register int k;
110 register char *t;
111
112 k = strlen(s);
113 if (k < IDENT_LEN) {
114 q->uname_tag = UNAM_IDENT;
115 t = q->user.ident;
116 }
117 else {
118 q->uname_tag = UNAM_CHARP;
119 q->user.Charp = t = mem(k+1, 0);
120 }
121 strcpy(t, s);
122 }
123
124 static void
fix_entry_returns(Void)125 fix_entry_returns(Void) /* for multiple entry points */
126 {
127 Addrp a;
128 int i;
129 struct Entrypoint *e;
130 Namep np;
131
132 e = entries = (struct Entrypoint *)revchain((chainp)entries);
133 allargs = revchain(allargs);
134 if (!multitype)
135 return;
136
137 /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
138
139 for(i = TYINT1; i <= TYLOGICAL; i++)
140 if (a = xretslot[i])
141 sprintf(a->user.ident, "(*ret_val).%s",
142 postfix[i-TYINT1]);
143
144 do {
145 np = e->enamep;
146 switch(np->vtype) {
147 case TYINT1:
148 case TYSHORT:
149 case TYLONG:
150 #ifdef TYQUAD
151 case TYQUAD:
152 #endif
153 case TYREAL:
154 case TYDREAL:
155 case TYCOMPLEX:
156 case TYDCOMPLEX:
157 case TYLOGICAL1:
158 case TYLOGICAL2:
159 case TYLOGICAL:
160 np->vstg = STGARG;
161 }
162 }
163 while(e = e->entnextp);
164 }
165
166 static void
167 #ifdef KR_headers
putentries(outfile)168 putentries(outfile)
169 FILE *outfile;
170 #else
171 putentries(FILE *outfile)
172 #endif
173 /* put out wrappers for multiple entries */
174 {
175 char base[MAXNAMELEN+4];
176 struct Entrypoint *e;
177 Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
178 chainp args, lengths;
179 int i, k, mt, nL, t, type;
180 extern char *dfltarg[], **dfltproc;
181
182 e = entries;
183 if (!e->enamep) /* only possible with erroneous input */
184 return;
185 nL = (nallargs + nallchargs) * sizeof(Namep *);
186 if (!nL)
187 nL = 8;
188 A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
189 Ae = A + nallargs;
190 Alp = (Namep **)(Ae1 = Ae + nallchargs);
191 i = k = 0;
192 for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
193 np = (Namep)args->datap;
194 if (np->vtype == TYCHAR && np->vclass != CLPROC)
195 *a1 = &Ae[i++];
196 }
197
198 mt = multitype;
199 multitype = 0;
200 sprintf(base, "%s0_", e->enamep->cvarname);
201 do {
202 np = e->enamep;
203 lengths = length_comp(e, 0);
204 proctype = type = np->vtype;
205 if (protofile)
206 protowrite(protofile, type, np->cvarname, e, lengths);
207 nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
208 nice_printf(outfile, "%s", np->cvarname);
209 if (!Ansi) {
210 listargs(outfile, e, 0, lengths);
211 nice_printf(outfile, "\n");
212 }
213 list_arg_types(outfile, e, lengths, 0, "\n");
214 nice_printf(outfile, "{\n");
215 frchain(&lengths);
216 next_tab(outfile);
217 if (mt)
218 nice_printf(outfile,
219 "Multitype ret_val;\n%s(%d, &ret_val",
220 base, k); /*)*/
221 else if (ISCOMPLEX(type))
222 nice_printf(outfile, "%s(%d,%s", base, k,
223 xretslot[type]->user.ident); /*)*/
224 else if (type == TYCHAR)
225 nice_printf(outfile,
226 "%s(%d, ret_val, ret_val_len", base, k); /*)*/
227 else
228 nice_printf(outfile, "return %s(%d", base, k); /*)*/
229 k++;
230 memset((char *)A, 0, nL);
231 for(args = e->arglist; args; args = args->nextp) {
232 np = (Namep)args->datap;
233 A[np->argno] = np;
234 if (np->vtype == TYCHAR && np->vclass != CLPROC)
235 *Alp[np->argno] = np;
236 }
237 args = allargs;
238 for(a = A; a < Ae; a++, args = args->nextp) {
239 t = ((Namep)args->datap)->vtype;
240 nice_printf(outfile, ", %s", (np = *a)
241 ? np->cvarname
242 : ((Namep)args->datap)->vclass == CLPROC
243 ? dfltproc[((Namep)args->datap)->vimpltype
244 ? (Castargs ? TYUNKNOWN : TYSUBR)
245 : t == TYREAL && forcedouble && !Castargs
246 ? TYDREAL : t]
247 : dfltarg[((Namep)args->datap)->vtype]);
248 }
249 for(; a < Ae1; a++)
250 if (np = *a)
251 nice_printf(outfile, ", %s",
252 new_arg_length(np));
253 else
254 nice_printf(outfile, ", (ftnint)0");
255 nice_printf(outfile, /*(*/ ");\n");
256 if (mt) {
257 if (type == TYCOMPLEX)
258 nice_printf(outfile,
259 "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
260 else if (type == TYDCOMPLEX)
261 nice_printf(outfile,
262 "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
263 else if (type <= TYLOGICAL)
264 nice_printf(outfile, "return ret_val.%s;\n",
265 postfix[type-TYINT1]);
266 }
267 nice_printf(outfile, "}\n");
268 prev_tab(outfile);
269 }
270 while(e = e->entnextp);
271 free((char *)A);
272 }
273
274 static void
275 #ifdef KR_headers
entry_goto(outfile)276 entry_goto(outfile)
277 FILE *outfile;
278 #else
279 entry_goto(FILE *outfile)
280 #endif
281 {
282 struct Entrypoint *e = entries;
283 int k = 0;
284
285 nice_printf(outfile, "switch(n__) {\n");
286 next_tab(outfile);
287 while(e = e->entnextp)
288 nice_printf(outfile, "case %d: goto %s;\n", ++k,
289 user_label((long)(extsymtab - e->entryname - 1)));
290 nice_printf(outfile, "}\n\n");
291 prev_tab(outfile);
292 }
293
294 /* start a new procedure */
295
296 void
newproc(Void)297 newproc(Void)
298 {
299 if(parstate != OUTSIDE)
300 {
301 execerr("missing end statement", CNULL);
302 endproc();
303 }
304
305 parstate = INSIDE;
306 procclass = CLMAIN; /* default */
307 }
308
309 static void
zap_changes(Void)310 zap_changes(Void)
311 {
312 register chainp cp;
313 register Argtypes *at;
314
315 /* arrange to get correct count of prototypes that would
316 change by running f2c again */
317
318 if (prev_proc && proc_argchanges)
319 proc_protochanges++;
320 prev_proc = proc_argchanges = 0;
321 for(cp = new_procs; cp; cp = cp->nextp)
322 if (at = ((Namep)cp->datap)->arginfo)
323 at->changes &= ~1;
324 frchain(&new_procs);
325 }
326
327 /* end of procedure. generate variables, epilogs, and prologs */
328
329 void
endproc(Void)330 endproc(Void)
331 {
332 struct Labelblock *lp;
333 Extsym *ext;
334
335 if(parstate < INDATA)
336 enddcl();
337 if(ctlstack >= ctls)
338 err("DO loop or BLOCK IF not closed");
339 for(lp = labeltab ; lp < labtabend ; ++lp)
340 if(lp->stateno!=0 && lp->labdefined==NO)
341 errstr("missing statement label %s",
342 convic(lp->stateno) );
343
344 /* Save copies of the common variables in extptr -> allextp */
345
346 for (ext = extsymtab; ext < nextext; ext++)
347 if (ext -> extstg == STGCOMMON && ext -> extp) {
348 extern int usedefsforcommon;
349
350 /* Write out the abbreviations for common block reference */
351
352 copy_data (ext -> extp);
353 if (usedefsforcommon) {
354 wr_abbrevs (c_file, 1, ext -> extp);
355 ext -> used_here = 1;
356 }
357 else
358 ext -> extp = CHNULL;
359
360 }
361
362 if (nentry > 1)
363 fix_entry_returns();
364 epicode();
365 donmlist();
366 dobss();
367 start_formatting ();
368 if (nentry > 1)
369 putentries(c_file);
370
371 zap_changes();
372 procinit(); /* clean up for next procedure */
373 }
374
375
376
377 /* End of declaration section of procedure. Allocate storage. */
378
379 void
enddcl(Void)380 enddcl(Void)
381 {
382 register struct Entrypoint *ep;
383 struct Entrypoint *ep0;
384 chainp cp;
385 extern char *err_proc;
386 static char comblks[] = "common blocks";
387
388 err_proc = comblks;
389 docommon();
390
391 /* Now the hash table entries for fields of common blocks have STGCOMMON,
392 vdcldone, voffset, and varno. And the common blocks themselves have
393 their full sizes in extleng. */
394
395 err_proc = "equivalences";
396 doequiv();
397
398 err_proc = comblks;
399 docomleng();
400
401 /* This implies that entry points in the declarations are buffered in
402 entries but not written out */
403
404 err_proc = "entries";
405 if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
406 /* entries could be 0 in case of an error */
407 do doentry(ep);
408 while(ep = ep->entnextp);
409 entries = (struct Entrypoint *)revchain((chainp)ep0);
410 }
411
412 err_proc = 0;
413 parstate = INEXEC;
414 p1put(P1_PROCODE);
415 freetemps();
416 if (earlylabs) {
417 for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
418 p1_label((Addr)cp->datap);
419 frchain(&earlylabs);
420 }
421 p1_line_number(lineno); /* for files that start with a MAIN program */
422 /* that starts with an executable statement */
423 }
424
425 /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
426
427 /* Main program or Block data */
428
429 void
430 #ifdef KR_headers
startproc(progname,Class)431 startproc(progname, Class)
432 Extsym *progname;
433 int Class;
434 #else
435 startproc(Extsym *progname, int Class)
436 #endif
437 {
438 register struct Entrypoint *p;
439
440 p = ALLOC(Entrypoint);
441 if(Class == CLMAIN) {
442 puthead(CNULL, CLMAIN);
443 if (progname)
444 strcpy (main_alias, progname->cextname);
445 } else {
446 if (progname) {
447 /* Construct an empty subroutine with this name */
448 /* in case the name is needed to force loading */
449 /* of this block-data subprogram: the name can */
450 /* appear elsewhere in an external statement. */
451 entrypt(CLPROC, TYSUBR, (ftnint)0, progname, (chainp)0);
452 endproc();
453 newproc();
454 }
455 puthead(CNULL, CLBLOCK);
456 }
457 if(Class == CLMAIN)
458 newentry( mkname(" MAIN"), 0 )->extinit = 1;
459 p->entryname = progname;
460 entries = p;
461
462 procclass = Class;
463 fprintf(diagfile, " %s", (Class==CLMAIN ? "MAIN" : "BLOCK DATA") );
464 if(progname) {
465 fprintf(diagfile, " %s", progname->fextname);
466 procname = progname->cextname;
467 }
468 fprintf(diagfile, ":\n");
469 fflush(diagfile);
470 }
471
472 /* subroutine or function statement */
473
474 Extsym *
475 #ifdef KR_headers
newentry(v,substmsg)476 newentry(v, substmsg)
477 register Namep v;
478 int substmsg;
479 #else
480 newentry(register Namep v, int substmsg)
481 #endif
482 {
483 register Extsym *p;
484 char buf[128], badname[64];
485 static int nbad = 0;
486 static char already[] = "external name already used";
487
488 p = mkext(v->fvarname, addunder(v->cvarname));
489
490 if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
491 {
492 sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
493 if (substmsg) {
494 sprintf(buf,"%s\n\tsubstituting \"%s\"",
495 already, badname);
496 dclerr(buf, v);
497 }
498 else
499 dclerr(already, v);
500 p = mkext(v->fvarname, badname);
501 }
502 v->vstg = STGAUTO;
503 v->vprocclass = PTHISPROC;
504 v->vclass = CLPROC;
505 if (p->extstg == STGEXT)
506 prev_proc = 1;
507 else
508 p->extstg = STGEXT;
509 p->extinit = YES;
510 v->vardesc.varno = p - extsymtab;
511 return(p);
512 }
513
514 void
515 #ifdef KR_headers
entrypt(Class,type,length,entry,args)516 entrypt(Class, type, length, entry, args)
517 int Class;
518 int type;
519 ftnint length;
520 Extsym *entry;
521 chainp args;
522 #else
523 entrypt(int Class, int type, ftnint length, Extsym *entry, chainp args)
524 #endif
525 {
526 register Namep q;
527 register struct Entrypoint *p;
528
529 if(Class != CLENTRY)
530 puthead( procname = entry->cextname, Class);
531 else
532 fprintf(diagfile, " entry ");
533 fprintf(diagfile, " %s:\n", entry->fextname);
534 fflush(diagfile);
535 q = mkname(entry->fextname);
536 if (type == TYSUBR)
537 q->vstg = STGEXT;
538
539 type = lengtype(type, length);
540 if(Class == CLPROC)
541 {
542 procclass = CLPROC;
543 proctype = type;
544 procleng = type == TYCHAR ? length : 0;
545 }
546
547 p = ALLOC(Entrypoint);
548
549 p->entnextp = entries;
550 entries = p;
551
552 p->entryname = entry;
553 p->arglist = revchain(args);
554 p->enamep = q;
555
556 if(Class == CLENTRY)
557 {
558 Class = CLPROC;
559 if(proctype == TYSUBR)
560 type = TYSUBR;
561 }
562
563 q->vclass = Class;
564 q->vprocclass = 0;
565 settype(q, type, length);
566 q->vprocclass = PTHISPROC;
567 /* hold all initial entry points till end of declarations */
568 if(parstate >= INDATA)
569 doentry(p);
570 }
571
572 /* generate epilogs */
573
574 /* epicode -- write out the proper function return mechanism at the end of
575 the procedure declaration. Handles multiple return value types, as
576 well as cooercion into the proper value */
577
578 LOCAL void
epicode(Void)579 epicode(Void)
580 {
581 extern int lastwasbranch;
582
583 if(procclass==CLPROC)
584 {
585 if(proctype==TYSUBR)
586 {
587
588 /* Return a zero only when the alternate return mechanism has been
589 specified in the function header */
590
591 if ((substars || Ansi) && lastwasbranch != YES)
592 p1_subr_ret (ICON(0));
593 }
594 else if (!multitype && lastwasbranch != YES)
595 retval(proctype);
596 }
597 else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
598 p1_subr_ret (ICON(0));
599 lastwasbranch = NO;
600 }
601
602
603 /* generate code to return value of type t */
604
605 LOCAL void
606 #ifdef KR_headers
retval(t)607 retval(t)
608 register int t;
609 #else
610 retval(register int t)
611 #endif
612 {
613 register Addrp p;
614
615 switch(t)
616 {
617 case TYCHAR:
618 case TYCOMPLEX:
619 case TYDCOMPLEX:
620 break;
621
622 case TYLOGICAL:
623 t = tylogical;
624 case TYINT1:
625 case TYADDR:
626 case TYSHORT:
627 case TYLONG:
628 #ifdef TYQUAD
629 case TYQUAD:
630 #endif
631 case TYREAL:
632 case TYDREAL:
633 case TYLOGICAL1:
634 case TYLOGICAL2:
635 p = (Addrp) cpexpr((expptr)retslot);
636 p->vtype = t;
637 p1_subr_ret (mkconv (t, fixtype((expptr)p)));
638 break;
639
640 default:
641 badtype("retval", t);
642 }
643 }
644
645
646 /* Do parameter adjustments */
647
648 void
649 #ifdef KR_headers
procode(outfile)650 procode(outfile)
651 FILE *outfile;
652 #else
653 procode(FILE *outfile)
654 #endif
655 {
656 prolog(outfile, allargs);
657
658 if (nentry > 1)
659 entry_goto(outfile);
660 }
661
662 static void
663 #ifdef KR_headers
bad_dimtype(q)664 bad_dimtype(q) Namep q;
665 #else
666 bad_dimtype(Namep q)
667 #endif
668 {
669 errstr("bad dimension type for %.70s", q->fvarname);
670 }
671
672 /* Finish bound computations now that all variables are declared.
673 * This used to be in setbound(), but under -u the following incurred
674 * an erroneous error message:
675 * subroutine foo(x,n)
676 * real x(n)
677 * integer n
678 */
679
680 static void
681 #ifdef KR_headers
dim_finish(v)682 dim_finish(v)
683 Namep v;
684 #else
685 dim_finish(Namep v)
686 #endif
687 {
688 register struct Dimblock *p;
689 register expptr q;
690 register int i, nd;
691
692 p = v->vdim;
693 v->vdimfinish = 0;
694 nd = p->ndim;
695 doin_setbound = 1;
696 for(i = 0; i < nd; i++)
697 if (q = p->dims[i].dimexpr) {
698 q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
699 if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
700 bad_dimtype(v);
701 }
702 if (q = p->basexpr)
703 p->basexpr = make_int_expr(putx(fixtype(q)));
704 doin_setbound = 0;
705 }
706
707 static void
708 #ifdef KR_headers
duparg(q)709 duparg(q)
710 Namep q;
711 #else
712 duparg(Namep q)
713 #endif
714 { errstr("duplicate argument %.80s", q->fvarname); }
715
716 /*
717 manipulate argument lists (allocate argument slot positions)
718 * keep track of return types and labels
719 */
720
721 LOCAL void
722 #ifdef KR_headers
doentry(ep)723 doentry(ep)
724 struct Entrypoint *ep;
725 #else
726 doentry(struct Entrypoint *ep)
727 #endif
728 {
729 register int type;
730 register Namep np;
731 chainp p, p1;
732 register Namep q;
733 Addrp rs;
734 int it, k;
735 extern char dflttype[26];
736 Extsym *entryname = ep->entryname;
737
738 if (++nentry > 1)
739 p1_label((long)(extsymtab - entryname - 1));
740
741 /* The main program isn't allowed to have parameters, so any given
742 parameters are ignored */
743
744 if(procclass == CLMAIN && !ep->arglist || procclass == CLBLOCK)
745 return;
746
747 /* Entry points in MAIN are an error, but we process them here */
748 /* to prevent faults elsewhere. */
749
750 /* So now we're working with something other than CLMAIN or CLBLOCK.
751 Determine the type of its return value. */
752
753 impldcl( np = mkname(entryname->fextname) );
754 type = np->vtype;
755 proc_argchanges = prev_proc && type != entryname->extype;
756 entryname->extseen = 1;
757 if(proctype == TYUNKNOWN)
758 if( (proctype = type) == TYCHAR)
759 procleng = np->vleng ? np->vleng->constblock.Const.ci
760 : (ftnint) (-1);
761
762 if(proctype == TYCHAR)
763 {
764 if(type != TYCHAR)
765 err("noncharacter entry of character function");
766
767 /* Functions returning type char can only have multiple entries if all
768 entries return the same length */
769
770 else if( (np->vleng ? np->vleng->constblock.Const.ci :
771 (ftnint) (-1)) != procleng)
772 err("mismatched character entry lengths");
773 }
774 else if(type == TYCHAR)
775 err("character entry of noncharacter function");
776 else if(type != proctype)
777 multitype = YES;
778 if(rtvlabel[type] == 0)
779 rtvlabel[type] = (int)newlabel();
780 ep->typelabel = rtvlabel[type];
781
782 if(type == TYCHAR)
783 {
784 if(chslot < 0)
785 {
786 chslot = nextarg(TYADDR);
787 chlgslot = nextarg(TYLENG);
788 }
789 np->vstg = STGARG;
790
791 /* Put a new argument in the function, one which will hold the result of
792 a character function. This will have to be named sometime, probably in
793 mkarg(). */
794
795 if(procleng < 0) {
796 np->vleng = (expptr) mkarg(TYLENG, chlgslot);
797 np->vleng->addrblock.uname_tag = UNAM_IDENT;
798 strcpy (np -> vleng -> addrblock.user.ident,
799 new_func_length());
800 }
801 if (!xretslot[TYCHAR]) {
802 xretslot[TYCHAR] = rs =
803 autovar(0, type, ISCONST(np->vleng)
804 ? np->vleng : ICON(0), "");
805 strcpy(rs->user.ident, "ret_val");
806 }
807 }
808
809 /* Handle a complex return type -- declare a new parameter (pointer to
810 a complex value) */
811
812 else if( ISCOMPLEX(type) ) {
813 if (!xretslot[type])
814 xretslot[type] =
815 autovar(0, type, EXNULL, " ret_val");
816 /* the blank is for use in out_addr */
817 np->vstg = STGARG;
818 if(cxslot < 0)
819 cxslot = nextarg(TYADDR);
820 }
821 else if (type != TYSUBR) {
822 if (type == TYUNKNOWN) {
823 dclerr("untyped function", np);
824 proctype = type = np->vtype =
825 dflttype[letter(np->fvarname[0])];
826 }
827 if (!xretslot[type])
828 xretslot[type] = retslot =
829 autovar(1, type, EXNULL, " ret_val");
830 /* the blank is for use in out_addr */
831 np->vstg = STGAUTO;
832 }
833
834 for(p = ep->arglist ; p ; p = p->nextp)
835 if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
836 q->vknownarg = 1;
837 q->vardesc.varno = nextarg(TYADDR);
838 allargs = mkchain((char *)q, allargs);
839 q->argno = nallargs++;
840 }
841 else if (nentry == 1)
842 duparg(q);
843 else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
844 if ((Namep)p1->datap == q)
845 duparg(q);
846
847 k = 0;
848 for(p = ep->arglist ; p ; p = p->nextp) {
849 if(! (( q = (Namep) (p->datap) )->vdcldone) )
850 {
851 impldcl(q);
852 q->vdcldone = YES;
853 if(q->vtype == TYCHAR)
854 {
855
856 /* If we don't know the length of a char*(*) (i.e. a string), we must add
857 in this additional length argument. */
858
859 ++nallchargs;
860 if (q->vclass == CLPROC)
861 nallchargs--;
862 else if (q->vleng == NULL) {
863 /* character*(*) */
864 q->vleng = (expptr)
865 mkarg(TYLENG, nextarg(TYLENG) );
866 unamstring((Addrp)q->vleng,
867 new_arg_length(q));
868 }
869 }
870 }
871 if (q->vdimfinish)
872 dim_finish(q);
873 if (q->vtype == TYCHAR && q->vclass != CLPROC)
874 k++;
875 }
876
877 if (entryname->extype != type)
878 changedtype(np);
879
880 /* save information for checking consistency of arg lists */
881
882 it = infertypes;
883 if (entryname->exproto)
884 infertypes = 1;
885 save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
886 0, np->fvarname, STGEXT, k, np->vtype, 2);
887 infertypes = it;
888 }
889
890
891
892 LOCAL int
893 #ifdef KR_headers
nextarg(type)894 nextarg(type)
895 int type;
896 #else
897 nextarg(int type)
898 #endif
899 {
900 type = type; /* shut up warning */
901 return(lastargslot++);
902 }
903
904 LOCAL void
905 #ifdef KR_headers
dim_check(q)906 dim_check(q)
907 Namep q;
908 #else
909 dim_check(Namep q)
910 #endif
911 {
912 register struct Dimblock *vdim = q->vdim;
913 register expptr nelt;
914
915 if(!(nelt = vdim->nelt) || !ISCONST(nelt))
916 dclerr("adjustable dimension on non-argument", q);
917 else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL))
918 bad_dimtype(q);
919 else if (ISINT(nelt->headblock.vtype)
920 ? nelt->constblock.Const.ci <= 0
921 : nelt->constblock.Const.cd[0] <= 0.)
922 dclerr("nonpositive dimension", q);
923 }
924
925 LOCAL void
dobss(Void)926 dobss(Void)
927 {
928 register struct Hashentry *p;
929 register Namep q;
930 int qstg, qclass, qtype;
931 Extsym *e;
932
933 for(p = hashtab ; p<lasthash ; ++p)
934 if(q = p->varp)
935 {
936 qstg = q->vstg;
937 qtype = q->vtype;
938 qclass = q->vclass;
939
940 if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
941 (qclass==CLVAR && qstg==STGUNKNOWN) ) {
942 if (!(q->vis_assigned | q->vimpldovar))
943 warn1("local variable %s never used",
944 q->fvarname);
945 }
946 else if(qclass==CLVAR && qstg==STGBSS)
947 { ; }
948
949 /* Give external procedures the proper storage class */
950
951 else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
952 && qstg!=STGARG) {
953 e = mkext(q->fvarname,addunder(q->cvarname));
954 e->extstg = STGEXT;
955 q->vardesc.varno = e - extsymtab;
956 if (e->extype != qtype)
957 changedtype(q);
958 }
959 if(qclass==CLVAR) {
960 if (qstg != STGARG && q->vdim)
961 dim_check(q);
962 } /* if qclass == CLVAR */
963 }
964
965 }
966
967
968 void
donmlist(Void)969 donmlist(Void)
970 {
971 register struct Hashentry *p;
972 register Namep q;
973
974 for(p=hashtab; p<lasthash; ++p)
975 if( (q = p->varp) && q->vclass==CLNAMELIST)
976 namelist(q);
977 }
978
979
980 /* iarrlen -- Returns the size of the array in bytes, or -1 */
981
982 ftnint
983 #ifdef KR_headers
iarrlen(q)984 iarrlen(q)
985 register Namep q;
986 #else
987 iarrlen(register Namep q)
988 #endif
989 {
990 ftnint leng;
991
992 leng = typesize[q->vtype];
993 if(leng <= 0)
994 return(-1);
995 if(q->vdim)
996 if( ISICON(q->vdim->nelt) )
997 leng *= q->vdim->nelt->constblock.Const.ci;
998 else return(-1);
999 if(q->vleng)
1000 if( ISICON(q->vleng) )
1001 leng *= q->vleng->constblock.Const.ci;
1002 else return(-1);
1003 return(leng);
1004 }
1005
1006 void
1007 #ifdef KR_headers
namelist(np)1008 namelist(np)
1009 Namep np;
1010 #else
1011 namelist(Namep np)
1012 #endif
1013 {
1014 register chainp q;
1015 register Namep v;
1016 int y;
1017
1018 if (!np->visused)
1019 return;
1020 y = 0;
1021
1022 for(q = np->varxptr.namelist ; q ; q = q->nextp)
1023 {
1024 vardcl( v = (Namep) (q->datap) );
1025 if( !ONEOF(v->vstg, MSKSTATIC) )
1026 dclerr("may not appear in namelist", v);
1027 else {
1028 v->vnamelist = 1;
1029 v->visused = 1;
1030 v->vsave = 1;
1031 y = 1;
1032 }
1033 np->visused = y;
1034 }
1035 }
1036
1037 /* docommon -- called at the end of procedure declarations, before
1038 equivalences and the procedure body */
1039
1040 LOCAL void
docommon(Void)1041 docommon(Void)
1042 {
1043 register Extsym *extptr;
1044 register chainp q, q1;
1045 struct Dimblock *t;
1046 expptr neltp;
1047 register Namep comvar;
1048 ftnint size;
1049 int i, k, pref, type;
1050 extern int type_pref[];
1051
1052 for(extptr = extsymtab ; extptr<nextext ; ++extptr)
1053 if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
1054
1055 /* If a common declaration also had a list of variables ... */
1056
1057 q = extptr->extp = revchain(q);
1058 pref = 1;
1059 for(k = TYCHAR; q ; q = q->nextp)
1060 {
1061 comvar = (Namep) (q->datap);
1062
1063 if(comvar->vdcldone == NO)
1064 vardcl(comvar);
1065 type = comvar->vtype;
1066 if (pref < type_pref[type])
1067 pref = type_pref[k = type];
1068 if(extptr->extleng % typealign[type] != 0) {
1069 dclerr("common alignment", comvar);
1070 --nerr; /* don't give bad return code for this */
1071 #if 0
1072 extptr->extleng = roundup(extptr->extleng, typealign[type]);
1073 #endif
1074 } /* if extptr -> extleng % */
1075
1076 /* Set the offset into the common block */
1077
1078 comvar->voffset = extptr->extleng;
1079 comvar->vardesc.varno = extptr - extsymtab;
1080 if(type == TYCHAR)
1081 if (comvar->vleng)
1082 size = comvar->vleng->constblock.Const.ci;
1083 else {
1084 dclerr("character*(*) in common", comvar);
1085 size = 1;
1086 }
1087 else
1088 size = typesize[type];
1089 if(t = comvar->vdim)
1090 if( (neltp = t->nelt) && ISCONST(neltp) )
1091 size *= neltp->constblock.Const.ci;
1092 else
1093 dclerr("adjustable array in common", comvar);
1094
1095 /* Adjust the length of the common block so far */
1096
1097 extptr->extleng += size;
1098 } /* for */
1099
1100 extptr->extype = k;
1101
1102 /* Determine curno and, if new, save this identifier chain */
1103
1104 q1 = extptr->extp;
1105 for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
1106 if (struct_eq((chainp)q->datap, q1))
1107 break;
1108 if (q)
1109 extptr->curno = extptr->maxno - i;
1110 else {
1111 extptr->curno = ++extptr->maxno;
1112 extptr->allextp = mkchain((char *)extptr->extp,
1113 extptr->allextp);
1114 }
1115 } /* if extptr -> extstg == STGCOMMON */
1116
1117 /* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
1118 varno. And the common block itself has its full size in extleng. */
1119
1120 } /* docommon */
1121
1122
1123 /* copy_data -- copy the Namep entries so they are available even after
1124 the hash table is empty */
1125
1126 void
1127 #ifdef KR_headers
copy_data(list)1128 copy_data(list)
1129 chainp list;
1130 #else
1131 copy_data(chainp list)
1132 #endif
1133 {
1134 for (; list; list = list -> nextp) {
1135 Namep namep = ALLOC (Nameblock);
1136 int size, nd, i;
1137 struct Dimblock *dp;
1138
1139 cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
1140 namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
1141 namep->fvarname);
1142 namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
1143 ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
1144 : namep->fvarname;
1145 if (namep -> vleng)
1146 namep -> vleng = (expptr) cpexpr (namep -> vleng);
1147 if (namep -> vdim) {
1148 nd = namep -> vdim -> ndim;
1149 size = sizeof(struct Dimblock) + 2*sizeof(expptr)*(nd-1);
1150 dp = (struct Dimblock *) ckalloc (size);
1151 cpn(size, (char *)namep->vdim, (char *)dp);
1152 namep -> vdim = dp;
1153 dp->nelt = (expptr)cpexpr(dp->nelt);
1154 for (i = 0; i < nd; i++) {
1155 dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
1156 } /* for */
1157 } /* if */
1158 list -> datap = (char *) namep;
1159 } /* for */
1160 } /* copy_data */
1161
1162
1163
1164 LOCAL void
docomleng(Void)1165 docomleng(Void)
1166 {
1167 register Extsym *p;
1168
1169 for(p = extsymtab ; p < nextext ; ++p)
1170 if(p->extstg == STGCOMMON)
1171 {
1172 if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
1173 && strcmp(Blank, p->cextname) )
1174 warn1("incompatible lengths for common block %.60s",
1175 p->fextname);
1176 if(p->maxleng < p->extleng)
1177 p->maxleng = p->extleng;
1178 p->extleng = 0;
1179 }
1180 }
1181
1182
1183 /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
1184
1185 void
1186 #ifdef KR_headers
frtemp(p)1187 frtemp(p)
1188 Addrp p;
1189 #else
1190 frtemp(Addrp p)
1191 #endif
1192 {
1193 /* put block on chain of temps to be reclaimed */
1194 holdtemps = mkchain((char *)p, holdtemps);
1195 }
1196
1197 void
freetemps(Void)1198 freetemps(Void)
1199 {
1200 register chainp p, p1;
1201 register Addrp q;
1202 register int t;
1203
1204 p1 = holdtemps;
1205 while(p = p1) {
1206 q = (Addrp)p->datap;
1207 t = q->vtype;
1208 if (t == TYCHAR && q->varleng != 0) {
1209 /* restore clobbered character string lengths */
1210 frexpr(q->vleng);
1211 q->vleng = ICON(q->varleng);
1212 }
1213 p1 = p->nextp;
1214 p->nextp = templist[t];
1215 templist[t] = p;
1216 }
1217 holdtemps = 0;
1218 }
1219
1220 /* allocate an automatic variable slot for each of nelt variables */
1221
1222 Addrp
1223 #ifdef KR_headers
autovar(nelt0,t,lengp,name)1224 autovar(nelt0, t, lengp, name)
1225 register int nelt0;
1226 register int t;
1227 expptr lengp;
1228 char *name;
1229 #else
1230 autovar(register int nelt0, register int t, expptr lengp, char *name)
1231 #endif
1232 {
1233 ftnint leng;
1234 register Addrp q;
1235 register int nelt = nelt0 > 0 ? nelt0 : 1;
1236 extern char *av_pfix[];
1237
1238 if(t == TYCHAR)
1239 if( ISICON(lengp) )
1240 leng = lengp->constblock.Const.ci;
1241 else {
1242 Fatal("automatic variable of nonconstant length");
1243 }
1244 else
1245 leng = typesize[t];
1246
1247 q = ALLOC(Addrblock);
1248 q->tag = TADDR;
1249 q->vtype = t;
1250 if(t == TYCHAR)
1251 {
1252 q->vleng = ICON(leng);
1253 q->varleng = leng;
1254 }
1255 q->vstg = STGAUTO;
1256 q->ntempelt = nelt;
1257 q->isarray = (nelt > 1);
1258 q->memoffset = ICON(0);
1259
1260 /* kludge for nls so we can have ret_val rather than ret_val_4 */
1261 if (*name == ' ')
1262 unamstring(q, name);
1263 else {
1264 q->uname_tag = UNAM_IDENT;
1265 temp_name(av_pfix[t], ++autonum[t], q->user.ident);
1266 }
1267 if (nelt0 > 0)
1268 declare_new_addr (q);
1269 return(q);
1270 }
1271
1272
1273 /* Returns a temporary of the appropriate type. Will reuse existing
1274 temporaries when possible */
1275
1276 Addrp
1277 #ifdef KR_headers
mktmpn(nelt,type,lengp)1278 mktmpn(nelt, type, lengp)
1279 int nelt;
1280 register int type;
1281 expptr lengp;
1282 #else
1283 mktmpn(int nelt, register int type, expptr lengp)
1284 #endif
1285 {
1286 ftnint leng;
1287 chainp p, oldp;
1288 register Addrp q;
1289 extern int krparens;
1290
1291 if(type==TYUNKNOWN || type==TYERROR)
1292 badtype("mktmpn", type);
1293
1294 if(type==TYCHAR)
1295 if(lengp && ISICON(lengp) )
1296 leng = lengp->constblock.Const.ci;
1297 else {
1298 err("adjustable length");
1299 return( (Addrp) errnode() );
1300 }
1301 else if (type > TYCHAR || type < TYADDR) {
1302 erri("mktmpn: unexpected type %d", type);
1303 exit(1);
1304 }
1305 /*
1306 * if a temporary of appropriate shape is on the templist,
1307 * remove it from the list and return it
1308 */
1309 if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX)))
1310 type++;
1311 for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp)
1312 {
1313 q = (Addrp) (p->datap);
1314 if(q->ntempelt==nelt &&
1315 (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
1316 {
1317 if(oldp)
1318 oldp->nextp = p->nextp;
1319 else
1320 templist[type] = p->nextp;
1321 free( (charptr) p);
1322 return(q);
1323 }
1324 }
1325 q = autovar(nelt, type, lengp, "");
1326 return(q);
1327 }
1328
1329
1330
1331
1332 /* mktmp -- create new local variable; call it something like name
1333 lengp is taken directly, not copied */
1334
1335 Addrp
1336 #ifdef KR_headers
mktmp(type,lengp)1337 mktmp(type, lengp)
1338 int type;
1339 expptr lengp;
1340 #else
1341 mktmp(int type, expptr lengp)
1342 #endif
1343 {
1344 Addrp rv;
1345 /* arrange for temporaries to be recycled */
1346 /* at the end of this statement... */
1347 rv = mktmpn(1,type,lengp);
1348 frtemp((Addrp)cpexpr((expptr)rv));
1349 return rv;
1350 }
1351
1352 /* mktmp0 omits frtemp() */
1353 Addrp
1354 #ifdef KR_headers
mktmp0(type,lengp)1355 mktmp0(type, lengp)
1356 int type;
1357 expptr lengp;
1358 #else
1359 mktmp0(int type, expptr lengp)
1360 #endif
1361 {
1362 Addrp rv;
1363 /* arrange for temporaries to be recycled */
1364 /* when this Addrp is freed */
1365 rv = mktmpn(1,type,lengp);
1366 rv->istemp = YES;
1367 return rv;
1368 }
1369
1370 /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
1371
1372 /* comblock -- Declare a new common block. Input parameters name the block;
1373 s will be NULL if the block is unnamed */
1374
1375 Extsym *
1376 #ifdef KR_headers
comblock(s)1377 comblock(s)
1378 register char *s;
1379 #else
1380 comblock(register char *s)
1381 #endif
1382 {
1383 Extsym *p;
1384 register char *t;
1385 register int c, i;
1386 char cbuf[256], *s0;
1387
1388 /* Give the unnamed common block a unique name */
1389
1390 if(*s == 0)
1391 p = mkext1(s0 = Blank, Blank);
1392 else {
1393 s0 = s;
1394 t = cbuf;
1395 for(i = 0; c = *t = *s++; t++)
1396 if (c == '_')
1397 i = 1;
1398 if (i)
1399 *t++ = '_';
1400 t[0] = '_';
1401 t[1] = 0;
1402 p = mkext1(s0,cbuf);
1403 }
1404 if(p->extstg == STGUNKNOWN)
1405 p->extstg = STGCOMMON;
1406 else if(p->extstg != STGCOMMON)
1407 {
1408 errstr("%.52s cannot be a common block: it is a subprogram.",
1409 s0);
1410 return(0);
1411 }
1412
1413 return( p );
1414 }
1415
1416
1417 /* incomm -- add a new variable to a common declaration */
1418
1419 void
1420 #ifdef KR_headers
incomm(c,v)1421 incomm(c, v)
1422 Extsym *c;
1423 Namep v;
1424 #else
1425 incomm(Extsym *c, Namep v)
1426 #endif
1427 {
1428 if (!c)
1429 return;
1430 if(v->vstg != STGUNKNOWN && !v->vimplstg)
1431 dclerr(v->vstg == STGARG
1432 ? "dummy arguments cannot be in common"
1433 : "incompatible common declaration", v);
1434 else
1435 {
1436 v->vstg = STGCOMMON;
1437 c->extp = mkchain((char *)v, c->extp);
1438 }
1439 }
1440
1441
1442
1443
1444 /* settype -- set the type or storage class of a Namep object. If
1445 v -> vstg == STGUNKNOWN && type < 0, attempt to reset vstg to be
1446 -type. This function will not change any earlier definitions in v,
1447 in will only attempt to fill out more information give the other params */
1448
1449 void
1450 #ifdef KR_headers
settype(v,type,length)1451 settype(v, type, length)
1452 register Namep v;
1453 register int type;
1454 register ftnint length;
1455 #else
1456 settype(register Namep v, register int type, register ftnint length)
1457 #endif
1458 {
1459 int type1;
1460
1461 if(type == TYUNKNOWN)
1462 return;
1463
1464 if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
1465 {
1466 v->vtype = TYSUBR;
1467 frexpr(v->vleng);
1468 v->vleng = 0;
1469 v->vimpltype = 0;
1470 }
1471 else if(type < 0) /* storage class set */
1472 {
1473 if(v->vstg == STGUNKNOWN)
1474 v->vstg = - type;
1475 else if(v->vstg != -type)
1476 dclerr("incompatible storage declarations", v);
1477 }
1478 else if(v->vtype == TYUNKNOWN
1479 || v->vtype != type
1480 && (v->vimpltype || v->vinftype || v->vinfproc))
1481 {
1482 if( (v->vtype = lengtype(type, length))==TYCHAR )
1483 if (length>=0)
1484 v->vleng = ICON(length);
1485 else if (parstate >= INDATA)
1486 v->vleng = ICON(1); /* avoid a memory fault */
1487 v->vimpltype = 0;
1488 v->vinftype = 0; /* 19960709 */
1489 v->vinfproc = 0; /* 19960709 */
1490
1491 if (v->vclass == CLPROC) {
1492 if (v->vstg == STGEXT
1493 && (type1 = extsymtab[v->vardesc.varno].extype)
1494 && type1 != v->vtype)
1495 changedtype(v);
1496 else if (v->vprocclass == PTHISPROC
1497 && (parstate >= INDATA
1498 || procclass == CLMAIN)
1499 && !xretslot[type]) {
1500 xretslot[type] = autovar(ONEOF(type,
1501 MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
1502 v->vleng, " ret_val");
1503 if (procclass == CLMAIN)
1504 errstr(
1505 "illegal use of %.60s (main program name)",
1506 v->fvarname);
1507 /* not completely right, but enough to */
1508 /* avoid memory faults; we won't */
1509 /* emit any C as we have illegal Fortran */
1510 }
1511 }
1512 }
1513 else if(v->vtype != type && v->vtype != lengtype(type, length)) {
1514 incompat:
1515 dclerr("incompatible type declarations", v);
1516 }
1517 else if (type==TYCHAR)
1518 if (v->vleng && v->vleng->constblock.Const.ci != length)
1519 goto incompat;
1520 else if (parstate >= INDATA)
1521 v->vleng = ICON(1); /* avoid a memory fault */
1522 }
1523
1524
1525
1526
1527
1528 /* lengtype -- returns the proper compiler type, given input of Fortran
1529 type and length specifier */
1530
1531 int
1532 #ifdef KR_headers
lengtype(type,len)1533 lengtype(type, len)
1534 register int type;
1535 ftnint len;
1536 #else
1537 lengtype(register int type, ftnint len)
1538 #endif
1539 {
1540 register int length = (int)len;
1541 switch(type)
1542 {
1543 case TYREAL:
1544 if(length == typesize[TYDREAL])
1545 return(TYDREAL);
1546 if(length == typesize[TYREAL])
1547 goto ret;
1548 break;
1549
1550 case TYCOMPLEX:
1551 if(length == typesize[TYDCOMPLEX])
1552 return(TYDCOMPLEX);
1553 if(length == typesize[TYCOMPLEX])
1554 goto ret;
1555 break;
1556
1557 case TYINT1:
1558 case TYSHORT:
1559 case TYDREAL:
1560 case TYDCOMPLEX:
1561 case TYCHAR:
1562 case TYLOGICAL1:
1563 case TYLOGICAL2:
1564 case TYUNKNOWN:
1565 case TYSUBR:
1566 case TYERROR:
1567 #ifdef TYQUAD
1568 case TYQUAD:
1569 #endif
1570 goto ret;
1571
1572 case TYLOGICAL:
1573 switch(length) {
1574 case 0: return tylog;
1575 case 1: return TYLOGICAL1;
1576 case 2: return TYLOGICAL2;
1577 case 4: goto ret;
1578 }
1579 break;
1580
1581 case TYLONG:
1582 if(length == 0)
1583 return(tyint);
1584 if (length == 1)
1585 return TYINT1;
1586 if(length == typesize[TYSHORT])
1587 return(TYSHORT);
1588 #ifdef TYQUAD
1589 if(length == typesize[TYQUAD] && use_tyquad)
1590 return(TYQUAD);
1591 #endif
1592 if(length == typesize[TYLONG])
1593 goto ret;
1594 break;
1595 default:
1596 badtype("lengtype", type);
1597 }
1598
1599 if(len != 0)
1600 err("incompatible type-length combination");
1601
1602 ret:
1603 return(type);
1604 }
1605
1606
1607
1608
1609
1610 /* setintr -- Set Intrinsic function */
1611
1612 void
1613 #ifdef KR_headers
setintr(v)1614 setintr(v)
1615 register Namep v;
1616 #else
1617 setintr(register Namep v)
1618 #endif
1619 {
1620 int k;
1621
1622 if(k = intrfunct(v->fvarname)) {
1623 if ((*(struct Intrpacked *)&k).f4)
1624 if (noextflag)
1625 goto unknown;
1626 else
1627 dcomplex_seen++;
1628 v->vardesc.varno = k;
1629 }
1630 else {
1631 unknown:
1632 dclerr("unknown intrinsic function", v);
1633 return;
1634 }
1635 if(v->vstg == STGUNKNOWN)
1636 v->vstg = STGINTR;
1637 else if(v->vstg!=STGINTR)
1638 dclerr("incompatible use of intrinsic function", v);
1639 if(v->vclass==CLUNKNOWN)
1640 v->vclass = CLPROC;
1641 if(v->vprocclass == PUNKNOWN)
1642 v->vprocclass = PINTRINSIC;
1643 else if(v->vprocclass != PINTRINSIC)
1644 dclerr("invalid intrinsic declaration", v);
1645 }
1646
1647
1648
1649 /* setext -- Set External declaration -- assume that unknowns will become
1650 procedures */
1651
1652 void
1653 #ifdef KR_headers
setext(v)1654 setext(v)
1655 register Namep v;
1656 #else
1657 setext(register Namep v)
1658 #endif
1659 {
1660 if(v->vclass == CLUNKNOWN)
1661 v->vclass = CLPROC;
1662 else if(v->vclass != CLPROC)
1663 dclerr("invalid external declaration", v);
1664
1665 if(v->vprocclass == PUNKNOWN)
1666 v->vprocclass = PEXTERNAL;
1667 else if(v->vprocclass != PEXTERNAL)
1668 dclerr("invalid external declaration", v);
1669 } /* setext */
1670
1671
1672
1673
1674 /* create dimensions block for array variable */
1675
1676 void
1677 #ifdef KR_headers
setbound(v,nd,dims)1678 setbound(v, nd, dims)
1679 register Namep v;
1680 int nd;
1681 struct Dims *dims;
1682 #else
1683 setbound(Namep v, int nd, struct Dims *dims)
1684 #endif
1685 {
1686 expptr q, q0, t;
1687 struct Dimblock *p;
1688 int i;
1689 extern chainp new_vars;
1690 char buf[256];
1691
1692 if(v->vclass == CLUNKNOWN)
1693 v->vclass = CLVAR;
1694 else if(v->vclass != CLVAR)
1695 {
1696 dclerr("only variables may be arrays", v);
1697 return;
1698 }
1699
1700 v->vdim = p = (struct Dimblock *)
1701 ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
1702 p->ndim = nd--;
1703 p->nelt = ICON(1);
1704 doin_setbound = 1;
1705
1706 if (noextflag)
1707 for(i = 0; i <= nd; i++)
1708 if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))
1709 || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) {
1710 sprintf(buf, "dimension %d of %s is not an integer.",
1711 i+1, v->fvarname);
1712 errext(buf);
1713 break;
1714 }
1715
1716 for(i = 0; i <= nd; i++) {
1717 if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)))
1718 dims[i].lb = mkconv(TYINT, q);
1719 if (((q = dims[i].ub) && !ISINT(q->headblock.vtype)))
1720 dims[i].ub = mkconv(TYINT, q);
1721 }
1722
1723 for(i = 0; i <= nd; ++i)
1724 {
1725 if( (q = dims[i].ub) == NULL)
1726 {
1727 if(i == nd)
1728 {
1729 frexpr(p->nelt);
1730 p->nelt = NULL;
1731 }
1732 else
1733 err("only last bound may be asterisk");
1734 p->dims[i].dimsize = ICON(1);
1735 p->dims[i].dimexpr = NULL;
1736 }
1737 else
1738 {
1739
1740 if(dims[i].lb)
1741 {
1742 q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
1743 q = mkexpr(OPPLUS, q, ICON(1) );
1744 }
1745 if( ISCONST(q) )
1746 {
1747 p->dims[i].dimsize = q;
1748 p->dims[i].dimexpr = (expptr) PNULL;
1749 }
1750 else {
1751 sprintf(buf, " %s_dim%d", v->fvarname, i+1);
1752 p->dims[i].dimsize = (expptr)
1753 autovar(1, tyint, EXNULL, buf);
1754 p->dims[i].dimexpr = q;
1755 if (i == nd)
1756 v->vlastdim = new_vars;
1757 v->vdimfinish = 1;
1758 }
1759 if(p->nelt)
1760 p->nelt = mkexpr(OPSTAR, p->nelt,
1761 cpexpr(p->dims[i].dimsize) );
1762 }
1763 }
1764
1765 q = dims[nd].lb;
1766 q0 = 0;
1767 if(q == NULL)
1768 q = q0 = ICON(1);
1769
1770 for(i = nd-1 ; i>=0 ; --i)
1771 {
1772 t = dims[i].lb;
1773 if(t == NULL)
1774 t = ICON(1);
1775 if(p->dims[i].dimsize) {
1776 if (q == q0) {
1777 q0 = 0;
1778 frexpr(q);
1779 q = cpexpr(p->dims[i].dimsize);
1780 }
1781 else
1782 q = mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q);
1783 q = mkexpr(OPPLUS, t, q);
1784 }
1785 }
1786
1787 if( ISCONST(q) )
1788 {
1789 p->baseoffset = q;
1790 p->basexpr = NULL;
1791 }
1792 else
1793 {
1794 sprintf(buf, " %s_offset", v->fvarname);
1795 p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
1796 p->basexpr = q;
1797 v->vdimfinish = 1;
1798 }
1799 doin_setbound = 0;
1800 }
1801
1802
1803 void
1804 #ifdef KR_headers
wr_abbrevs(outfile,function_head,vars)1805 wr_abbrevs(outfile, function_head, vars)
1806 FILE *outfile;
1807 int function_head;
1808 chainp vars;
1809 #else
1810 wr_abbrevs(FILE *outfile, int function_head, chainp vars)
1811 #endif
1812 {
1813 for (; vars; vars = vars -> nextp) {
1814 Namep name = (Namep) vars -> datap;
1815 if (!name->visused)
1816 continue;
1817
1818 if (function_head)
1819 nice_printf (outfile, "#define ");
1820 else
1821 nice_printf (outfile, "#undef ");
1822 out_name (outfile, name);
1823
1824 if (function_head) {
1825 Extsym *comm = &extsymtab[name -> vardesc.varno];
1826
1827 nice_printf (outfile, " (");
1828 extern_out (outfile, comm);
1829 nice_printf (outfile, "%d.", comm->curno);
1830 nice_printf (outfile, "%s)", name->cvarname);
1831 } /* if function_head */
1832 nice_printf (outfile, "\n");
1833 } /* for */
1834 } /* wr_abbrevs */
1835