1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
4 Permission to use, copy, modify, and distribute this software
5 and its documentation for any purpose and without fee is hereby
6 granted, provided that the above copyright notice appear in all
7 copies and that both that the copyright notice and this
8 permission notice and warranty disclaimer appear in supporting
9 documentation, and that the names of AT&T Bell Laboratories or
10 Bellcore or any of their entities not be used in advertising or
11 publicity pertaining to distribution of the software without
12 specific, written prior permission.
14 AT&T and Bellcore disclaim all warranties with regard to this
15 software, including all implied warranties of merchantability
16 and fitness. In no event shall AT&T or Bellcore be liable for
17 any special, indirect or consequential damages or any damages
18 whatsoever resulting from loss of use, data or profits, whether
19 in an action of contract, negligence or other tortious action,
20 arising out of or in connection with the use or performance of
22 ****************************************************************/
29 #define EXNULL (union Expression *)0
31 LOCAL dobss(), docomleng(), docommon(), doentry(),
32 epicode(), nextarg(), retval();
34 static char Blank[] = BLANKCOMMON;
36 static char *postfix[] = { "h", "i", "r", "d", "c", "z", "i" };
39 int prev_proc, proc_argchanges, proc_protochanges;
54 e = &extsymtab[q->vardesc.varno];
55 if (!(at = e->arginfo)) {
59 else if (at->changes & 2 && qtype != TYUNKNOWN)
62 if (type1 == TYUNKNOWN)
64 if (qtype == TYUNKNOWN)
73 sprintf(buf, "%.90s: inconsistent declarations:\n\
74 here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
75 qtype == TYSUBR ? "" : " function",
76 ftn_types[type1], type1 == TYSUBR ? "" : " function");
90 q->uname_tag = UNAM_IDENT;
94 q->uname_tag = UNAM_CHARP;
95 q->user.Charp = t = mem(k+1, 0);
101 fix_entry_returns() /* for multiple entry points */
105 struct Entrypoint *e;
108 e = entries = (struct Entrypoint *)revchain((chainp)entries);
109 allargs = revchain(allargs);
113 /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
115 for(i = TYSHORT; i <= TYLOGICAL; i++)
117 sprintf(a->user.ident, "(*ret_val).%s",
133 while(e = e->entnextp);
137 putentries(outfile) /* put out wrappers for multiple entries */
140 char base[IDENT_LEN];
141 struct Entrypoint *e;
142 Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
143 chainp args, lengths, length_comp();
144 void listargs(), list_arg_types();
145 int i, k, mt, nL, type;
146 extern char *dfltarg[], **dfltproc;
148 nL = (nallargs + nallchargs) * sizeof(Namep *);
149 A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
151 Alp = (Namep **)(Ae1 = Ae + nallchargs);
153 for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
154 np = (Namep)args->datap;
155 if (np->vtype == TYCHAR && np->vclass != CLPROC)
162 sprintf(base, "%s0_", e->enamep->cvarname);
165 lengths = length_comp(e, 0);
166 proctype = type = np->vtype;
168 protowrite(protofile, type, np->cvarname, e, lengths);
169 nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
170 nice_printf(outfile, "%s", np->cvarname);
172 listargs(outfile, e, 0, lengths);
173 nice_printf(outfile, "\n");
175 list_arg_types(outfile, e, lengths, 0, "\n");
176 nice_printf(outfile, "{\n");
181 "Multitype ret_val;\n%s(%d, &ret_val",
183 else if (ISCOMPLEX(type))
184 nice_printf(outfile, "%s(%d,%s", base, k,
185 xretslot[type]->user.ident); /*)*/
186 else if (type == TYCHAR)
188 "%s(%d, ret_val, ret_val_len", base, k); /*)*/
190 nice_printf(outfile, "return %s(%d", base, k); /*)*/
192 memset((char *)A, 0, nL);
193 for(args = e->arglist; args; args = args->nextp) {
194 np = (Namep)args->datap;
196 if (np->vtype == TYCHAR && np->vclass != CLPROC)
197 *Alp[np->argno] = np;
200 for(a = A; a < Ae; a++, args = args->nextp)
201 nice_printf(outfile, ", %s", (np = *a)
203 : ((Namep)args->datap)->vclass == CLPROC
204 ? dfltproc[((Namep)args->datap)->vtype]
205 : dfltarg[((Namep)args->datap)->vtype]);
208 nice_printf(outfile, ", %s_len", np->cvarname);
210 nice_printf(outfile, ", (ftnint)0");
211 nice_printf(outfile, /*(*/ ");\n");
213 if (type == TYCOMPLEX)
215 "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\nreturn 0;\n");
216 else if (type == TYDCOMPLEX)
218 "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\nreturn 0;\n");
219 else nice_printf(outfile, "return ret_val.%s;\n",
220 postfix[type-TYSHORT]);
222 else if (ONEOF(type, M(TYCHAR)|M(TYCOMPLEX)|M(TYDCOMPLEX)))
223 nice_printf(outfile, "return 0;\n");
224 nice_printf(outfile, "}\n");
227 while(e = e->entnextp);
235 struct Entrypoint *e = entries;
238 nice_printf(outfile, "switch(n__) {\n");
240 while(e = e->entnextp)
241 nice_printf(outfile, "case %d: goto %s;\n", ++k,
242 user_label((long)(extsymtab - e->entryname - 1)));
243 nice_printf(outfile, "}\n\n");
247 /* start a new procedure */
251 if(parstate != OUTSIDE)
253 execerr("missing end statement", CNULL);
258 procclass = CLMAIN; /* default */
265 register Argtypes *at;
267 /* arrange to get correct count of prototypes that would
268 change by running f2c again */
270 if (prev_proc && proc_argchanges)
272 prev_proc = proc_argchanges = 0;
273 for(cp = new_procs; cp; cp = cp->nextp)
274 if (at = ((Namep)cp->datap)->arginfo)
279 /* end of procedure. generate variables, epilogs, and prologs */
283 struct Labelblock *lp;
286 if(parstate < INDATA)
289 err("DO loop or BLOCK IF not closed");
290 for(lp = labeltab ; lp < labtabend ; ++lp)
291 if(lp->stateno!=0 && lp->labdefined==NO)
292 errstr("missing statement label %s",
293 convic(lp->stateno) );
295 /* Save copies of the common variables in extptr -> allextp */
297 for (ext = extsymtab; ext < nextext; ext++)
298 if (ext -> extstg == STGCOMMON && ext -> extp) {
299 extern int usedefsforcommon;
301 /* Write out the abbreviations for common block reference */
303 copy_data (ext -> extp);
304 if (usedefsforcommon) {
305 wr_abbrevs (c_file, 1, ext -> extp);
306 ext -> used_here = 1;
309 ext -> extp = CHNULL;
323 procinit(); /* clean up for next procedure */
328 /* End of declaration section of procedure. Allocate storage. */
332 register struct Entrypoint *ep;
333 struct Entrypoint *ep0;
334 extern void freetemps();
339 /* Now the hash table entries for fields of common blocks have STGCOMMON,
340 vdcldone, voffset, and varno. And the common blocks themselves have
341 their full sizes in extleng. */
346 /* This implies that entry points in the declarations are buffered in
347 entries but not written out */
349 if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
350 /* entries could be 0 in case of an error */
352 while(ep = ep->entnextp);
353 entries = (struct Entrypoint *)revchain((chainp)ep0);
359 for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
360 p1_label((long)cp->datap);
365 /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
367 /* Main program or Block data */
369 startproc(progname, class)
373 register struct Entrypoint *p;
375 p = ALLOC(Entrypoint);
376 if(class == CLMAIN) {
377 puthead(CNULL, CLMAIN);
379 strcpy (main_alias, progname->cextname);
381 puthead(CNULL, CLBLOCK);
383 newentry( mkname(" MAIN"), 0 )->extinit = 1;
384 p->entryname = progname;
388 fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
390 fprintf(diagfile, " %s", progname->fextname);
391 procname = progname->cextname;
393 fprintf(diagfile, ":\n");
397 /* subroutine or function statement */
399 Extsym *newentry(v, substmsg)
404 char buf[128], badname[64];
406 static char already[] = "external name already used";
408 p = mkext(v->fvarname, addunder(v->cvarname));
410 if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
412 sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
414 sprintf(buf,"%s\n\tsubstituting \"%s\"",
420 p = mkext(v->fvarname, badname);
423 v->vprocclass = PTHISPROC;
425 if (p->extstg == STGEXT)
430 v->vardesc.varno = p - extsymtab;
435 entrypt(class, type, length, entry, args)
442 register struct Entrypoint *p;
446 puthead( procname = entry->cextname, class);
448 fprintf(diagfile, " entry ");
449 fprintf(diagfile, " %s:\n", entry->fextname);
451 q = mkname(entry->fextname);
455 if( (type = lengtype(type, length)) != TYCHAR)
464 p = ALLOC(Entrypoint);
466 p->entnextp = entries;
469 p->entryname = entry;
470 p->arglist = revchain(args);
476 if(proctype == TYSUBR)
481 q->vprocclass = PTHISPROC;
482 settype(q, type, length);
483 /* hold all initial entry points till end of declarations */
484 if(parstate >= INDATA)
488 /* generate epilogs */
490 /* epicode -- write out the proper function return mechanism at the end of
491 the procedure declaration. Handles multiple return value types, as
492 well as cooercion into the proper value */
496 extern int lastwasbranch;
498 if(procclass==CLPROC)
503 /* Return a zero only when the alternate return mechanism has been
504 specified in the function header */
506 if (substars && lastwasbranch == NO)
507 p1_subr_ret (ICON(0));
509 else if (!multitype && lastwasbranch == NO)
516 /* generate code to return value of type t */
537 p = (Addrp) cpexpr((expptr)retslot);
539 p1_subr_ret (mkconv (t, fixtype((expptr)p)));
543 badtype("retval", t);
548 /* Do parameter adjustments */
553 prolog(outfile, allargs);
559 /* Finish bound computations now that all variables are declared.
560 * This used to be in setbound(), but under -u the following incurred
561 * an erroneous error message:
562 * subroutine foo(x,n)
571 register struct Dimblock *p;
574 extern expptr make_int_expr();
580 for(i = 0; i < nd; i++)
581 if (q = p->dims[i].dimexpr)
582 p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
584 p->basexpr = make_int_expr(putx(fixtype(q)));
591 { errstr("duplicate argument %.80s", q->fvarname); }
594 manipulate argument lists (allocate argument slot positions)
595 * keep track of return types and labels
599 struct Entrypoint *ep;
607 Extsym *entryname = ep->entryname;
610 p1_label((long)(extsymtab - entryname - 1));
612 /* The main program isn't allowed to have parameters, so any given
613 parameters are ignored */
615 if(procclass == CLMAIN || procclass == CLBLOCK)
618 /* So now we're working with something other than CLMAIN or CLBLOCK.
619 Determine the type of its return value. */
621 impldcl( np = mkname(entryname->fextname) );
623 proc_argchanges = prev_proc && type != entryname->extype;
624 entryname->extseen = 1;
625 if(proctype == TYUNKNOWN)
626 if( (proctype = type) == TYCHAR)
627 procleng = np->vleng ? np->vleng->constblock.Const.ci
630 if(proctype == TYCHAR)
633 err("noncharacter entry of character function");
635 /* Functions returning type char can only have multiple entries if all
636 entries return the same length */
638 else if( (np->vleng ? np->vleng->constblock.Const.ci :
639 (ftnint) (-1)) != procleng)
640 err("mismatched character entry lengths");
642 else if(type == TYCHAR)
643 err("character entry of noncharacter function");
644 else if(type != proctype)
646 if(rtvlabel[type] == 0)
647 rtvlabel[type] = newlabel();
648 ep->typelabel = rtvlabel[type];
654 chslot = nextarg(TYADDR);
655 chlgslot = nextarg(TYLENG);
659 /* Put a new argument in the function, one which will hold the result of
660 a character function. This will have to be named sometime, probably in
664 np->vleng = (expptr) mkarg(TYLENG, chlgslot);
665 np->vleng->addrblock.uname_tag = UNAM_IDENT;
666 strcpy (np -> vleng -> addrblock.user.ident,
669 if (!xretslot[TYCHAR]) {
670 xretslot[TYCHAR] = rs =
671 autovar(0, type, ISCONST(np->vleng)
672 ? np->vleng : ICON(0), "");
673 strcpy(rs->user.ident, "ret_val");
677 /* Handle a complex return type -- declare a new parameter (pointer to
680 else if( ISCOMPLEX(type) ) {
683 autovar(0, type, EXNULL, " ret_val");
684 /* the blank is for use in out_addr */
687 cxslot = nextarg(TYADDR);
689 else if (type != TYSUBR) {
691 xretslot[type] = retslot =
692 autovar(1, type, EXNULL, " ret_val");
693 /* the blank is for use in out_addr */
697 for(p = ep->arglist ; p ; p = p->nextp)
698 if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
700 q->vardesc.varno = nextarg(TYADDR);
701 allargs = mkchain((char *)q, allargs);
702 q->argno = nallargs++;
704 else if (nentry == 1)
706 else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
707 if ((Namep)p1->datap == q)
711 for(p = ep->arglist ; p ; p = p->nextp) {
712 if(! (( q = (Namep) (p->datap) )->vdcldone) )
716 if(q->vtype == TYCHAR)
719 /* If we don't know the length of a char*(*) (i.e. a string), we must add
720 in this additional length argument. */
723 if (q->vclass == CLPROC)
725 else if (q->vleng == NULL) {
728 mkarg(TYLENG, nextarg(TYLENG) );
729 unamstring((Addrp)q->vleng,
736 if (q->vtype == TYCHAR && q->vclass != CLPROC)
740 if (entryname->extype != type)
743 /* save information for checking consistency of arg lists */
746 if (entryname->exproto)
748 save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
749 0, np->fvarname, STGEXT, k, np->vtype);
760 lastargslot += typesize[type];
766 register struct Hashentry *p;
768 int qstg, qclass, qtype;
771 for(p = hashtab ; p<lasthash ; ++p)
778 if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
779 (qclass==CLVAR && qstg==STGUNKNOWN) ) {
780 if (!(q->vis_assigned | q->vimpldovar))
781 warn1("local variable %s never used",
784 else if(qclass==CLVAR && qstg==STGBSS)
787 /* Give external procedures the proper storage class */
789 else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
791 e = mkext(q->fvarname,addunder(q->cvarname));
793 q->vardesc.varno = e - extsymtab;
794 if (e->extype != qtype)
799 if(q->vdim && !ISICON(q->vdim->nelt) )
800 dclerr("adjustable dimension on non-argument", q);
801 if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
802 dclerr("adjustable leng on nonargument", q);
803 } /* if qstg != STGARG */
804 } /* if qclass == CLVAR */
813 register struct Hashentry *p;
816 for(p=hashtab; p<lasthash; ++p)
817 if( (q = p->varp) && q->vclass==CLNAMELIST)
822 /* iarrlen -- Returns the size of the array in bytes, or -1 */
829 leng = typesize[q->vtype];
833 if( ISICON(q->vdim->nelt) )
834 leng *= q->vdim->nelt->constblock.Const.ci;
837 if( ISICON(q->vleng) )
838 leng *= q->vleng->constblock.Const.ci;
854 for(q = np->varxptr.namelist ; q ; q = q->nextp)
856 vardcl( v = (Namep) (q->datap) );
857 if( !ONEOF(v->vstg, MSKSTATIC) )
858 dclerr("may not appear in namelist", v);
869 /* docommon -- called at the end of procedure declarations, before
870 equivalences and the procedure body */
874 register Extsym *extptr;
875 register chainp q, q1;
878 register Namep comvar;
880 int i, k, pref, type;
881 extern int type_pref[];
883 for(extptr = extsymtab ; extptr<nextext ; ++extptr)
884 if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
886 /* If a common declaration also had a list of variables ... */
888 q = extptr->extp = revchain(q);
890 for(k = TYCHAR; q ; q = q->nextp)
892 comvar = (Namep) (q->datap);
894 if(comvar->vdcldone == NO)
896 type = comvar->vtype;
897 if (pref < type_pref[type])
898 pref = type_pref[k = type];
899 if(extptr->extleng % typealign[type] != 0) {
900 dclerr("common alignment", comvar);
901 --nerr; /* don't give bad return code for this */
903 extptr->extleng = roundup(extptr->extleng, typealign[type]);
905 } /* if extptr -> extleng % */
907 /* Set the offset into the common block */
909 comvar->voffset = extptr->extleng;
910 comvar->vardesc.varno = extptr - extsymtab;
912 size = comvar->vleng->constblock.Const.ci;
914 size = typesize[type];
916 if( (neltp = t->nelt) && ISCONST(neltp) )
917 size *= neltp->constblock.Const.ci;
919 dclerr("adjustable array in common", comvar);
921 /* Adjust the length of the common block so far */
923 extptr->extleng += size;
928 /* Determine curno and, if new, save this identifier chain */
931 for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
932 if (struct_eq((chainp)q->datap, q1))
935 extptr->curno = extptr->maxno - i;
937 extptr->curno = ++extptr->maxno;
938 extptr->allextp = mkchain((char *)extptr->extp,
941 } /* if extptr -> extstg == STGCOMMON */
943 /* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
944 varno. And the common block itself has its full size in extleng. */
949 /* copy_data -- copy the Namep entries so they are available even after
950 the hash table is empty */
955 for (; list; list = list -> nextp) {
956 Namep namep = ALLOC (Nameblock);
960 cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
961 namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
963 namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
964 ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
967 namep -> vleng = (expptr) cpexpr (namep -> vleng);
969 nd = namep -> vdim -> ndim;
970 size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
971 dp = (struct Dimblock *) ckalloc (size);
972 cpn(size, (char *)namep->vdim, (char *)dp);
974 dp->nelt = (expptr)cpexpr(dp->nelt);
975 for (i = 0; i < nd; i++) {
976 dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
979 list -> datap = (char *) namep;
989 for(p = extsymtab ; p < nextext ; ++p)
990 if(p->extstg == STGCOMMON)
992 if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
993 && strcmp(Blank, p->cextname) )
994 warn1("incompatible lengths for common block %.60s",
996 if(p->maxleng < p->extleng)
997 p->maxleng = p->extleng;
1003 /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
1008 /* put block on chain of temps to be reclaimed */
1009 holdtemps = mkchain((char *)p, holdtemps);
1015 register chainp p, p1;
1021 q = (Addrp)p->datap;
1023 if (t == TYCHAR && q->varleng != 0) {
1024 /* restore clobbered character string lengths */
1026 q->vleng = ICON(q->varleng);
1029 p->nextp = templist[t];
1035 /* allocate an automatic variable slot for each of nelt variables */
1037 Addrp autovar(nelt0, t, lengp, name)
1038 register int nelt0, t;
1045 register int nelt = nelt0 > 0 ? nelt0 : 1;
1046 extern char *av_pfix[];
1050 leng = lengp->constblock.Const.ci;
1052 Fatal("automatic variable of nonconstant length");
1057 q = ALLOC(Addrblock);
1062 q->vleng = ICON(leng);
1067 q->isarray = (nelt > 1);
1068 q->memoffset = ICON(0);
1070 /* kludge for nls so we can have ret_val rather than ret_val_4 */
1072 unamstring(q, name+1);
1074 q->uname_tag = UNAM_IDENT;
1075 temp_name(av_pfix[t], ++autonum[t], q->user.ident);
1078 declare_new_addr (q);
1083 /* Returns a temporary of the appropriate type. Will reuse existing
1084 temporaries when possible */
1086 Addrp mktmpn(nelt, type, lengp)
1095 if(type==TYUNKNOWN || type==TYERROR)
1096 badtype("mktmpn", type);
1100 leng = lengp->constblock.Const.ci;
1102 err("adjustable length");
1103 return( (Addrp) errnode() );
1105 else if (type > TYCHAR || type < TYADDR) {
1106 erri("mktmpn: unexpected type %d", type);
1110 * if a temporary of appropriate shape is on the templist,
1111 * remove it from the list and return it
1113 for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp)
1115 q = (Addrp) (p->datap);
1116 if(q->ntempelt==nelt &&
1117 (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
1120 oldp->nextp = p->nextp;
1122 templist[type] = p->nextp;
1127 q = autovar(nelt, type, lengp, "");
1134 /* mktemp -- create new local variable; call it something like name
1135 lengp is taken directly, not copied */
1137 Addrp Mktemp(type, lengp)
1142 /* arrange for temporaries to be recycled */
1143 /* at the end of this statement... */
1144 rv = mktmpn(1,type,lengp);
1145 frtemp((Addrp)cpexpr((expptr)rv));
1149 /* mktmp0 omits frtemp() */
1150 Addrp mktmp0(type, lengp)
1155 /* arrange for temporaries to be recycled */
1156 /* when this Addrp is freed */
1157 rv = mktmpn(1,type,lengp);
1162 /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
1164 /* comblock -- Declare a new common block. Input parameters name the block;
1165 s will be NULL if the block is unnamed */
1173 char cbuf[256], *s0;
1175 /* Give the unnamed common block a unique name */
1178 p = mkext(Blank,Blank);
1182 for(i = 0; c = *t = *s++; t++)
1191 if(p->extstg == STGUNKNOWN)
1192 p->extstg = STGCOMMON;
1193 else if(p->extstg != STGCOMMON)
1195 errstr("%.68s cannot be a common block name", s);
1203 /* incomm -- add a new variable to a common declaration */
1211 if(v->vstg != STGUNKNOWN && !v->vimplstg)
1212 dclerr("incompatible common declaration", v);
1215 v->vstg = STGCOMMON;
1216 c->extp = mkchain((char *)v, c->extp);
1223 /* settype -- set the type or storage class of a Namep object. If
1224 v -> vstg == STGUNKNOWN && type < 0, attempt to reset vstg to be
1225 -type. This function will not change any earlier definitions in v,
1226 in will only attempt to fill out more information give the other params */
1228 settype(v, type, length)
1231 register ftnint length;
1235 if(type == TYUNKNOWN)
1238 if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
1245 else if(type < 0) /* storage class set */
1247 if(v->vstg == STGUNKNOWN)
1249 else if(v->vstg != -type)
1250 dclerr("incompatible storage declarations", v);
1252 else if(v->vtype == TYUNKNOWN || v->vimpltype && v->vtype != type)
1254 if( (v->vtype = lengtype(type, length))==TYCHAR && length>=0)
1255 v->vleng = ICON(length);
1258 if (v->vclass == CLPROC && v->vstg == STGEXT
1259 && (type1 = extsymtab[v->vardesc.varno].extype)
1260 && type1 != v->vtype)
1263 else if(v->vtype!=type
1264 || (type==TYCHAR && v->vleng->constblock.Const.ci!=length) )
1265 dclerr("incompatible type declarations", v);
1272 /* lengtype -- returns the proper compiler type, given input of Fortran
1273 type and length specifier */
1279 register int length = (int)len;
1283 if(length == typesize[TYDREAL])
1285 if(length == typesize[TYREAL])
1290 if(length == typesize[TYDCOMPLEX])
1292 if(length == typesize[TYCOMPLEX])
1306 if(length == typesize[TYLOGICAL])
1308 if(length == 1 || length == 2) {
1309 erri("treating LOGICAL*%d as LOGICAL", length);
1310 --nerr; /* allow generation of .c file */
1318 if(length == typesize[TYSHORT])
1320 if(length == typesize[TYLONG])
1324 badtype("lengtype", type);
1328 err("incompatible type-length combination");
1338 /* setintr -- Set Intrinsic function */
1345 if(v->vstg == STGUNKNOWN)
1347 else if(v->vstg!=STGINTR)
1348 dclerr("incompatible use of intrinsic function", v);
1349 if(v->vclass==CLUNKNOWN)
1351 if(v->vprocclass == PUNKNOWN)
1352 v->vprocclass = PINTRINSIC;
1353 else if(v->vprocclass != PINTRINSIC)
1354 dclerr("invalid intrinsic declaration", v);
1355 if(k = intrfunct(v->fvarname)) {
1356 if ((*(struct Intrpacked *)&k).f4)
1361 v->vardesc.varno = k;
1365 dclerr("unknown intrinsic function", v);
1371 /* setext -- Set External declaration -- assume that unknowns will become
1377 if(v->vclass == CLUNKNOWN)
1379 else if(v->vclass != CLPROC)
1380 dclerr("invalid external declaration", v);
1382 if(v->vprocclass == PUNKNOWN)
1383 v->vprocclass = PEXTERNAL;
1384 else if(v->vprocclass != PEXTERNAL)
1385 dclerr("invalid external declaration", v);
1391 /* create dimensions block for array variable */
1393 setbound(v, nd, dims)
1400 register expptr q, t;
1401 register struct Dimblock *p;
1403 extern chainp new_vars;
1406 if(v->vclass == CLUNKNOWN)
1408 else if(v->vclass != CLVAR)
1410 dclerr("only variables may be arrays", v);
1414 v->vdim = p = (struct Dimblock *)
1415 ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
1420 for(i = 0; i <= nd; ++i)
1422 if( (q = dims[i].ub) == NULL)
1430 err("only last bound may be asterisk");
1431 p->dims[i].dimsize = ICON(1);
1433 p->dims[i].dimexpr = NULL;
1440 q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
1441 q = mkexpr(OPPLUS, q, ICON(1) );
1445 p->dims[i].dimsize = q;
1446 p->dims[i].dimexpr = (expptr) PNULL;
1449 sprintf(buf, " %s_dim%d", v->fvarname, i+1);
1450 p->dims[i].dimsize = (expptr)
1451 autovar(1, tyint, EXNULL, buf);
1452 p->dims[i].dimexpr = q;
1454 v->vlastdim = new_vars;
1458 p->nelt = mkexpr(OPSTAR, p->nelt,
1459 cpexpr(p->dims[i].dimsize) );
1467 for(i = nd-1 ; i>=0 ; --i)
1472 if(p->dims[i].dimsize)
1473 q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
1483 sprintf(buf, " %s_offset", v->fvarname);
1484 p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
1492 wr_abbrevs (outfile, function_head, vars)
1497 for (; vars; vars = vars -> nextp) {
1498 Namep name = (Namep) vars -> datap;
1503 nice_printf (outfile, "#define ");
1505 nice_printf (outfile, "#undef ");
1506 out_name (outfile, name);
1508 if (function_head) {
1509 Extsym *comm = &extsymtab[name -> vardesc.varno];
1511 nice_printf (outfile, " (");
1512 extern_out (outfile, comm);
1513 nice_printf (outfile, "%d.", comm->curno);
1514 nice_printf (outfile, "%s)", name->cvarname);
1515 } /* if function_head */
1516 nice_printf (outfile, "\n");