00001 /****************************************************************
00002 Copyright 1990, 1994-6 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 #include "defs.h"
00025 #include "names.h"
00026 #include "output.h"
00027 #include "p1defs.h"
00028 
00029 /* round a up to the nearest multiple of b:
00030 
00031    a = b * floor ( (a + (b - 1)) / b )*/
00032 
00033 #undef roundup
00034 #define roundup(a,b)    ( b * ( (a+b-1)/b) )
00035 
00036 #define EXNULL (union Expression *)0
00037 
00038 static void dobss Argdcl((void));
00039 static void docomleng Argdcl((void));
00040 static void docommon Argdcl((void));
00041 static void doentry Argdcl((struct Entrypoint*));
00042 static void epicode Argdcl((void));
00043 static int nextarg Argdcl((int));
00044 static void retval Argdcl((int));
00045 
00046 static char Blank[] = BLANKCOMMON;
00047 
00048  static char *postfix[] = { "g", "h", "i",
00049 #ifdef TYQUAD
00050                                         "j",
00051 #endif
00052                                         "r", "d", "c", "z", "g", "h", "i" };
00053 
00054  chainp new_procs;
00055  int prev_proc, proc_argchanges, proc_protochanges;
00056 
00057  void
00058 #ifdef KR_headers
00059 changedtype(q)
00060         Namep q;
00061 #else
00062 changedtype(Namep q)
00063 #endif
00064 {
00065         char buf[200];
00066         int qtype, type1;
00067         register Extsym *e;
00068         Argtypes *at;
00069 
00070         if (q->vtypewarned)
00071                 return;
00072         q->vtypewarned = 1;
00073         qtype = q->vtype;
00074         e = &extsymtab[q->vardesc.varno];
00075         if (!(at = e->arginfo)) {
00076                 if (!e->exused)
00077                         return;
00078                 }
00079         else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
00080                 proc_protochanges++;
00081         type1 = e->extype;
00082         if (type1 == TYUNKNOWN)
00083                 return;
00084         if (qtype == TYUNKNOWN)
00085                 /* e.g.,
00086                         subroutine foo
00087                         end
00088                         external foo
00089                         call goo(foo)
00090                         end
00091                 */
00092                 return;
00093         sprintf(buf, "%.90s: inconsistent declarations:\n\
00094         here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
00095                 qtype == TYSUBR ? "" : " function",
00096                 ftn_types[type1], type1 == TYSUBR ? "" : " function");
00097         warn(buf);
00098         }
00099 
00100  void
00101 #ifdef KR_headers
00102 unamstring(q, s)
00103         register Addrp q;
00104         register char *s;
00105 #else
00106 unamstring(register Addrp q, register char *s)
00107 #endif
00108 {
00109         register int k;
00110         register char *t;
00111 
00112         k = strlen(s);
00113         if (k < IDENT_LEN) {
00114                 q->uname_tag = UNAM_IDENT;
00115                 t = q->user.ident;
00116                 }
00117         else {
00118                 q->uname_tag = UNAM_CHARP;
00119                 q->user.Charp = t = mem(k+1, 0);
00120                 }
00121         strcpy(t, s);
00122         }
00123 
00124  static void
00125 fix_entry_returns(Void) /* for multiple entry points */
00126 {
00127         Addrp a;
00128         int i;
00129         struct Entrypoint *e;
00130         Namep np;
00131 
00132         e = entries = (struct Entrypoint *)revchain((chainp)entries);
00133         allargs = revchain(allargs);
00134         if (!multitype)
00135                 return;
00136 
00137         /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
00138 
00139         for(i = TYINT1; i <= TYLOGICAL; i++)
00140                 if (a = xretslot[i])
00141                         sprintf(a->user.ident, "(*ret_val).%s",
00142                                 postfix[i-TYINT1]);
00143 
00144         do {
00145                 np = e->enamep;
00146                 switch(np->vtype) {
00147                         case TYINT1:
00148                         case TYSHORT:
00149                         case TYLONG:
00150 #ifdef TYQUAD
00151                         case TYQUAD:
00152 #endif
00153                         case TYREAL:
00154                         case TYDREAL:
00155                         case TYCOMPLEX:
00156                         case TYDCOMPLEX:
00157                         case TYLOGICAL1:
00158                         case TYLOGICAL2:
00159                         case TYLOGICAL:
00160                                 np->vstg = STGARG;
00161                         }
00162                 }
00163                 while(e = e->entnextp);
00164         }
00165 
00166  static void
00167 #ifdef KR_headers
00168 putentries(outfile)
00169         FILE *outfile;
00170 #else
00171 putentries(FILE *outfile)
00172 #endif
00173         /* put out wrappers for multiple entries */
00174 {
00175         char base[MAXNAMELEN+4];
00176         struct Entrypoint *e;
00177         Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
00178         chainp args, lengths;
00179         int i, k, mt, nL, t, type;
00180         extern char *dfltarg[], **dfltproc;
00181 
00182         e = entries;
00183         if (!e->enamep) /* only possible with erroneous input */
00184                 return;
00185         nL = (nallargs + nallchargs) * sizeof(Namep *);
00186         A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
00187         Ae = A + nallargs;
00188         Alp = (Namep **)(Ae1 = Ae + nallchargs);
00189         i = k = 0;
00190         for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
00191                 np = (Namep)args->datap;
00192                 if (np->vtype == TYCHAR && np->vclass != CLPROC)
00193                         *a1 = &Ae[i++];
00194                 }
00195 
00196         mt = multitype;
00197         multitype = 0;
00198         sprintf(base, "%s0_", e->enamep->cvarname);
00199         do {
00200                 np = e->enamep;
00201                 lengths = length_comp(e, 0);
00202                 proctype = type = np->vtype;
00203                 if (protofile)
00204                         protowrite(protofile, type, np->cvarname, e, lengths);
00205                 nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
00206                 nice_printf(outfile, "%s", np->cvarname);
00207                 if (!Ansi) {
00208                         listargs(outfile, e, 0, lengths);
00209                         nice_printf(outfile, "\n");
00210                         }
00211                 list_arg_types(outfile, e, lengths, 0, "\n");
00212                 nice_printf(outfile, "{\n");
00213                 frchain(&lengths);
00214                 next_tab(outfile);
00215                 if (mt)
00216                         nice_printf(outfile,
00217                                 "Multitype ret_val;\n%s(%d, &ret_val",
00218                                 base, k); /*)*/
00219                 else if (ISCOMPLEX(type))
00220                         nice_printf(outfile, "%s(%d,%s", base, k,
00221                                 xretslot[type]->user.ident); /*)*/
00222                 else if (type == TYCHAR)
00223                         nice_printf(outfile,
00224                                 "%s(%d, ret_val, ret_val_len", base, k); /*)*/
00225                 else
00226                         nice_printf(outfile, "return %s(%d", base, k); /*)*/
00227                 k++;
00228                 memset((char *)A, 0, nL);
00229                 for(args = e->arglist; args; args = args->nextp) {
00230                         np = (Namep)args->datap;
00231                         A[np->argno] = np;
00232                         if (np->vtype == TYCHAR && np->vclass != CLPROC)
00233                                 *Alp[np->argno] = np;
00234                         }
00235                 args = allargs;
00236                 for(a = A; a < Ae; a++, args = args->nextp) {
00237                         t = ((Namep)args->datap)->vtype;
00238                         nice_printf(outfile, ", %s", (np = *a)
00239                                 ? np->cvarname
00240                                 : ((Namep)args->datap)->vclass == CLPROC
00241                                 ? dfltproc[((Namep)args->datap)->vimpltype
00242                                         ? (Castargs ? TYUNKNOWN : TYSUBR)
00243                                         : t == TYREAL && forcedouble && !Castargs
00244                                         ? TYDREAL : t]
00245                                 : dfltarg[((Namep)args->datap)->vtype]);
00246                         }
00247                 for(; a < Ae1; a++)
00248                         if (np = *a)
00249                                 nice_printf(outfile, ", %s",
00250                                         new_arg_length(np));
00251                         else
00252                                 nice_printf(outfile, ", (ftnint)0");
00253                 nice_printf(outfile, /*(*/ ");\n");
00254                 if (mt) {
00255                         if (type == TYCOMPLEX)
00256                                 nice_printf(outfile,
00257                     "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
00258                         else if (type == TYDCOMPLEX)
00259                                 nice_printf(outfile,
00260                     "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
00261                         else if (type <= TYLOGICAL)
00262                                 nice_printf(outfile, "return ret_val.%s;\n",
00263                                         postfix[type-TYINT1]);
00264                         }
00265                 nice_printf(outfile, "}\n");
00266                 prev_tab(outfile);
00267                 }
00268                 while(e = e->entnextp);
00269         free((char *)A);
00270         }
00271 
00272  static void
00273 #ifdef KR_headers
00274 entry_goto(outfile)
00275         FILE *outfile;
00276 #else
00277 entry_goto(FILE *outfile)
00278 #endif
00279 {
00280         struct Entrypoint *e = entries;
00281         int k = 0;
00282 
00283         nice_printf(outfile, "switch(n__) {\n");
00284         next_tab(outfile);
00285         while(e = e->entnextp)
00286                 nice_printf(outfile, "case %d: goto %s;\n", ++k,
00287                         user_label((long)(extsymtab - e->entryname - 1)));
00288         nice_printf(outfile, "}\n\n");
00289         prev_tab(outfile);
00290         }
00291 
00292 /* start a new procedure */
00293 
00294  void
00295 newproc(Void)
00296 {
00297         if(parstate != OUTSIDE)
00298         {
00299                 execerr("missing end statement", CNULL);
00300                 endproc();
00301         }
00302 
00303         parstate = INSIDE;
00304         procclass = CLMAIN;     /* default */
00305 }
00306 
00307  static void
00308 zap_changes(Void)
00309 {
00310         register chainp cp;
00311         register Argtypes *at;
00312 
00313         /* arrange to get correct count of prototypes that would
00314            change by running f2c again */
00315 
00316         if (prev_proc && proc_argchanges)
00317                 proc_protochanges++;
00318         prev_proc = proc_argchanges = 0;
00319         for(cp = new_procs; cp; cp = cp->nextp)
00320                 if (at = ((Namep)cp->datap)->arginfo)
00321                         at->changes &= ~1;
00322         frchain(&new_procs);
00323         }
00324 
00325 /* end of procedure. generate variables, epilogs, and prologs */
00326 
00327  void
00328 endproc(Void)
00329 {
00330         struct Labelblock *lp;
00331         Extsym *ext;
00332 
00333         if(parstate < INDATA)
00334                 enddcl();
00335         if(ctlstack >= ctls)
00336                 err("DO loop or BLOCK IF not closed");
00337         for(lp = labeltab ; lp < labtabend ; ++lp)
00338                 if(lp->stateno!=0 && lp->labdefined==NO)
00339                         errstr("missing statement label %s",
00340                                 convic(lp->stateno) );
00341 
00342 /* Save copies of the common variables in extptr -> allextp */
00343 
00344         for (ext = extsymtab; ext < nextext; ext++)
00345                 if (ext -> extstg == STGCOMMON && ext -> extp) {
00346                         extern int usedefsforcommon;
00347 
00348 /* Write out the abbreviations for common block reference */
00349 
00350                         copy_data (ext -> extp);
00351                         if (usedefsforcommon) {
00352                                 wr_abbrevs (c_file, 1, ext -> extp);
00353                                 ext -> used_here = 1;
00354                                 }
00355                         else
00356                                 ext -> extp = CHNULL;
00357 
00358                         }
00359 
00360         if (nentry > 1)
00361                 fix_entry_returns();
00362         epicode();
00363         donmlist();
00364         dobss();
00365         start_formatting ();
00366         if (nentry > 1)
00367                 putentries(c_file);
00368 
00369         zap_changes();
00370         procinit();     /* clean up for next procedure */
00371 }
00372 
00373 
00374 
00375 /* End of declaration section of procedure.  Allocate storage. */
00376 
00377  void
00378 enddcl(Void)
00379 {
00380         register struct Entrypoint *ep;
00381         struct Entrypoint *ep0;
00382         chainp cp;
00383         extern char *err_proc;
00384         static char comblks[] = "common blocks";
00385 
00386         err_proc = comblks;
00387         docommon();
00388 
00389 /* Now the hash table entries for fields of common blocks have STGCOMMON,
00390    vdcldone, voffset, and varno.  And the common blocks themselves have
00391    their full sizes in extleng. */
00392 
00393         err_proc = "equivalences";
00394         doequiv();
00395 
00396         err_proc = comblks;
00397         docomleng();
00398 
00399 /* This implies that entry points in the declarations are buffered in
00400    entries   but not written out */
00401 
00402         err_proc = "entries";
00403         if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
00404                 /* entries could be 0 in case of an error */
00405                 do doentry(ep);
00406                         while(ep = ep->entnextp);
00407                 entries = (struct Entrypoint *)revchain((chainp)ep0);
00408                 }
00409 
00410         err_proc = 0;
00411         parstate = INEXEC;
00412         p1put(P1_PROCODE);
00413         freetemps();
00414         if (earlylabs) {
00415                 for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
00416                         p1_label((long)cp->datap);
00417                 frchain(&earlylabs);
00418                 }
00419         p1_line_number(lineno); /* for files that start with a MAIN program */
00420                                 /* that starts with an executable statement */
00421 }
00422 
00423 /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
00424 
00425 /* Main program or Block data */
00426 
00427  void
00428 #ifdef KR_headers
00429 startproc(progname, classKRH)
00430         Extsym *progname;
00431         int classKRH;
00432 #else
00433 startproc(Extsym *progname, int classKRH)
00434 #endif
00435 {
00436         register struct Entrypoint *p;
00437 
00438         p = ALLOC(Entrypoint);
00439         if(classKRH == CLMAIN) {
00440                 puthead(CNULL, CLMAIN);
00441                 if (progname)
00442                     strcpy (main_alias, progname->cextname);
00443         } else {
00444                 if (progname) {
00445                         /* Construct an empty subroutine with this name */
00446                         /* in case the name is needed to force loading */
00447                         /* of this block-data subprogram: the name can */
00448                         /* appear elsewhere in an external statement. */
00449                         entrypt(CLPROC, TYSUBR, (ftnint)0, progname, (chainp)0);
00450                         endproc();
00451                         newproc();
00452                         }
00453                 puthead(CNULL, CLBLOCK);
00454                 }
00455         if(classKRH == CLMAIN)
00456                 newentry( mkname(" MAIN"), 0 )->extinit = 1;
00457         p->entryname = progname;
00458         entries = p;
00459 
00460         procclass = classKRH;
00461         fprintf(diagfile, "   %s", (classKRH==CLMAIN ? "MAIN" : "BLOCK DATA") );
00462         if(progname) {
00463                 fprintf(diagfile, " %s", progname->fextname);
00464                 procname = progname->cextname;
00465                 }
00466         fprintf(diagfile, ":\n");
00467         fflush(diagfile);
00468 }
00469 
00470 /* subroutine or function statement */
00471 
00472  Extsym *
00473 #ifdef KR_headers
00474 newentry(v, substmsg)
00475         register Namep v;
00476         int substmsg;
00477 #else
00478 newentry(register Namep v, int substmsg)
00479 #endif
00480 {
00481         register Extsym *p;
00482         char buf[128], badname[64];
00483         static int nbad = 0;
00484         static char already[] = "external name already used";
00485 
00486         p = mkext(v->fvarname, addunder(v->cvarname));
00487 
00488         if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
00489         {
00490                 sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
00491                 if (substmsg) {
00492                         sprintf(buf,"%s\n\tsubstituting \"%s\"",
00493                                 already, badname);
00494                         dclerr(buf, v);
00495                         }
00496                 else
00497                         dclerr(already, v);
00498                 p = mkext(v->fvarname, badname);
00499         }
00500         v->vstg = STGAUTO;
00501         v->vprocclass = PTHISPROC;
00502         v->vclass = CLPROC;
00503         if (p->extstg == STGEXT)
00504                 prev_proc = 1;
00505         else
00506                 p->extstg = STGEXT;
00507         p->extinit = YES;
00508         v->vardesc.varno = p - extsymtab;
00509         return(p);
00510 }
00511 
00512  void
00513 #ifdef KR_headers
00514 entrypt(classKRH, type, length, entry, args)
00515         int classKRH;
00516         int type;
00517         ftnint length;
00518         Extsym *entry;
00519         chainp args;
00520 #else
00521 entrypt(int classKRH, int type, ftnint length, Extsym *entry, chainp args)
00522 #endif
00523 {
00524         register Namep q;
00525         register struct Entrypoint *p;
00526 
00527         if(classKRH != CLENTRY)
00528                 puthead( procname = entry->cextname, classKRH);
00529         else
00530                 fprintf(diagfile, "       entry ");
00531         fprintf(diagfile, "   %s:\n", entry->fextname);
00532         fflush(diagfile);
00533         q = mkname(entry->fextname);
00534         if (type == TYSUBR)
00535                 q->vstg = STGEXT;
00536 
00537         type = lengtype(type, length);
00538         if(classKRH == CLPROC)
00539         {
00540                 procclass = CLPROC;
00541                 proctype = type;
00542                 procleng = type == TYCHAR ? length : 0;
00543         }
00544 
00545         p = ALLOC(Entrypoint);
00546 
00547         p->entnextp = entries;
00548         entries = p;
00549 
00550         p->entryname = entry;
00551         p->arglist = revchain(args);
00552         p->enamep = q;
00553 
00554         if(classKRH == CLENTRY)
00555         {
00556                 classKRH = CLPROC;
00557                 if(proctype == TYSUBR)
00558                         type = TYSUBR;
00559         }
00560 
00561         q->vclass = classKRH;
00562         q->vprocclass = 0;
00563         settype(q, type, length);
00564         q->vprocclass = PTHISPROC;
00565         /* hold all initial entry points till end of declarations */
00566         if(parstate >= INDATA)
00567                 doentry(p);
00568 }
00569 
00570 /* generate epilogs */
00571 
00572 /* epicode -- write out the proper function return mechanism at the end of
00573    the procedure declaration.  Handles multiple return value types, as
00574    well as cooercion into the proper value */
00575 
00576  LOCAL void
00577 epicode(Void)
00578 {
00579         extern int lastwasbranch;
00580 
00581         if(procclass==CLPROC)
00582         {
00583                 if(proctype==TYSUBR)
00584                 {
00585 
00586 /* Return a zero only when the alternate return mechanism has been
00587    specified in the function header */
00588 
00589                         if ((substars || Ansi) && lastwasbranch != YES)
00590                             p1_subr_ret (ICON(0));
00591                 }
00592                 else if (!multitype && lastwasbranch != YES)
00593                         retval(proctype);
00594         }
00595         else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
00596                 p1_subr_ret (ICON(0));
00597         lastwasbranch = NO;
00598 }
00599 
00600 
00601 /* generate code to return value of type  t */
00602 
00603  LOCAL void
00604 #ifdef KR_headers
00605 retval(t)
00606         register int t;
00607 #else
00608 retval(register int t)
00609 #endif
00610 {
00611         register Addrp p;
00612 
00613         switch(t)
00614         {
00615         case TYCHAR:
00616         case TYCOMPLEX:
00617         case TYDCOMPLEX:
00618                 break;
00619 
00620         case TYLOGICAL:
00621                 t = tylogical;
00622         case TYINT1:
00623         case TYADDR:
00624         case TYSHORT:
00625         case TYLONG:
00626 #ifdef TYQUAD
00627         case TYQUAD:
00628 #endif
00629         case TYREAL:
00630         case TYDREAL:
00631         case TYLOGICAL1:
00632         case TYLOGICAL2:
00633                 p = (Addrp) cpexpr((expptr)retslot);
00634                 p->vtype = t;
00635                 p1_subr_ret (mkconv (t, fixtype((expptr)p)));
00636                 break;
00637 
00638         default:
00639                 badtype("retval", t);
00640         }
00641 }
00642 
00643 
00644 /* Do parameter adjustments */
00645 
00646  void
00647 #ifdef KR_headers
00648 procode(outfile)
00649         FILE *outfile;
00650 #else
00651 procode(FILE *outfile)
00652 #endif
00653 {
00654         prolog(outfile, allargs);
00655 
00656         if (nentry > 1)
00657                 entry_goto(outfile);
00658         }
00659 
00660  static void
00661 #ifdef KR_headers
00662 bad_dimtype(q) Namep q;
00663 #else
00664 bad_dimtype(Namep q)
00665 #endif
00666 {
00667         errstr("bad dimension type for %.70s", q->fvarname);
00668         }
00669 
00670 /* Finish bound computations now that all variables are declared.
00671  * This used to be in setbound(), but under -u the following incurred
00672  * an erroneous error message:
00673  *      subroutine foo(x,n)
00674  *      real x(n)
00675  *      integer n
00676  */
00677 
00678  static void
00679 #ifdef KR_headers
00680 dim_finish(v)
00681         Namep v;
00682 #else
00683 dim_finish(Namep v)
00684 #endif
00685 {
00686         register struct Dimblock *p;
00687         register expptr q;
00688         register int i, nd;
00689 
00690         p = v->vdim;
00691         v->vdimfinish = 0;
00692         nd = p->ndim;
00693         doin_setbound = 1;
00694         for(i = 0; i < nd; i++)
00695                 if (q = p->dims[i].dimexpr) {
00696                         q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
00697                         if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
00698                                 bad_dimtype(v);
00699                         }
00700         if (q = p->basexpr)
00701                 p->basexpr = make_int_expr(putx(fixtype(q)));
00702         doin_setbound = 0;
00703         }
00704 
00705  static void
00706 #ifdef KR_headers
00707 duparg(q)
00708         Namep q;
00709 #else
00710 duparg(Namep q)
00711 #endif
00712 { errstr("duplicate argument %.80s", q->fvarname); }
00713 
00714 /*
00715    manipulate argument lists (allocate argument slot positions)
00716  * keep track of return types and labels
00717  */
00718 
00719  LOCAL void
00720 #ifdef KR_headers
00721 doentry(ep)
00722         struct Entrypoint *ep;
00723 #else
00724 doentry(struct Entrypoint *ep)
00725 #endif
00726 {
00727         register int type;
00728         register Namep np;
00729         chainp p, p1;
00730         register Namep q;
00731         Addrp rs;
00732         int it, k;
00733         extern char dflttype[26];
00734         Extsym *entryname = ep->entryname;
00735 
00736         if (++nentry > 1)
00737                 p1_label((long)(extsymtab - entryname - 1));
00738 
00739 /* The main program isn't allowed to have parameters, so any given
00740    parameters are ignored */
00741 
00742         if(procclass == CLMAIN || procclass == CLBLOCK)
00743                 return;
00744 
00745 /* So now we're working with something other than CLMAIN or CLBLOCK.
00746    Determine the type of its return value. */
00747 
00748         impldcl( np = mkname(entryname->fextname) );
00749         type = np->vtype;
00750         proc_argchanges = prev_proc && type != entryname->extype;
00751         entryname->extseen = 1;
00752         if(proctype == TYUNKNOWN)
00753                 if( (proctype = type) == TYCHAR)
00754                         procleng = np->vleng ? np->vleng->constblock.Const.ci
00755                                              : (ftnint) (-1);
00756 
00757         if(proctype == TYCHAR)
00758         {
00759                 if(type != TYCHAR)
00760                         err("noncharacter entry of character function");
00761 
00762 /* Functions returning type   char   can only have multiple entries if all
00763    entries return the same length */
00764 
00765                 else if( (np->vleng ? np->vleng->constblock.Const.ci :
00766                     (ftnint) (-1)) != procleng)
00767                         err("mismatched character entry lengths");
00768         }
00769         else if(type == TYCHAR)
00770                 err("character entry of noncharacter function");
00771         else if(type != proctype)
00772                 multitype = YES;
00773         if(rtvlabel[type] == 0)
00774                 rtvlabel[type] = (int)newlabel();
00775         ep->typelabel = rtvlabel[type];
00776 
00777         if(type == TYCHAR)
00778         {
00779                 if(chslot < 0)
00780                 {
00781                         chslot = nextarg(TYADDR);
00782                         chlgslot = nextarg(TYLENG);
00783                 }
00784                 np->vstg = STGARG;
00785 
00786 /* Put a new argument in the function, one which will hold the result of
00787    a character function.  This will have to be named sometime, probably in
00788    mkarg(). */
00789 
00790                 if(procleng < 0) {
00791                         np->vleng = (expptr) mkarg(TYLENG, chlgslot);
00792                         np->vleng->addrblock.uname_tag = UNAM_IDENT;
00793                         strcpy (np -> vleng -> addrblock.user.ident,
00794                                 new_func_length());
00795                         }
00796                 if (!xretslot[TYCHAR]) {
00797                         xretslot[TYCHAR] = rs =
00798                                 autovar(0, type, ISCONST(np->vleng)
00799                                         ? np->vleng : ICON(0), "");
00800                         strcpy(rs->user.ident, "ret_val");
00801                         }
00802         }
00803 
00804 /* Handle a   complex   return type -- declare a new parameter (pointer to
00805    a complex value) */
00806 
00807         else if( ISCOMPLEX(type) ) {
00808                 if (!xretslot[type])
00809                         xretslot[type] =
00810                                 autovar(0, type, EXNULL, " ret_val");
00811                                 /* the blank is for use in out_addr */
00812                 np->vstg = STGARG;
00813                 if(cxslot < 0)
00814                         cxslot = nextarg(TYADDR);
00815                 }
00816         else if (type != TYSUBR) {
00817                 if (type == TYUNKNOWN) {
00818                         dclerr("untyped function", np);
00819                         proctype = type = np->vtype =
00820                                 dflttype[letter(np->fvarname[0])];
00821                         }
00822                 if (!xretslot[type])
00823                         xretslot[type] = retslot =
00824                                 autovar(1, type, EXNULL, " ret_val");
00825                                 /* the blank is for use in out_addr */
00826                 np->vstg = STGAUTO;
00827                 }
00828 
00829         for(p = ep->arglist ; p ; p = p->nextp)
00830                 if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
00831                         q->vknownarg = 1;
00832                         q->vardesc.varno = nextarg(TYADDR);
00833                         allargs = mkchain((char *)q, allargs);
00834                         q->argno = nallargs++;
00835                         }
00836                 else if (nentry == 1)
00837                         duparg(q);
00838                 else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
00839                         if ((Namep)p1->datap == q)
00840                                 duparg(q);
00841 
00842         k = 0;
00843         for(p = ep->arglist ; p ; p = p->nextp) {
00844                 if(! (( q = (Namep) (p->datap) )->vdcldone) )
00845                         {
00846                         impldcl(q);
00847                         q->vdcldone = YES;
00848                         if(q->vtype == TYCHAR)
00849                                 {
00850 
00851 /* If we don't know the length of a char*(*) (i.e. a string), we must add
00852    in this additional length argument. */
00853 
00854                                 ++nallchargs;
00855                                 if (q->vclass == CLPROC)
00856                                         nallchargs--;
00857                                 else if (q->vleng == NULL) {
00858                                         /* character*(*) */
00859                                         q->vleng = (expptr)
00860                                             mkarg(TYLENG, nextarg(TYLENG) );
00861                                         unamstring((Addrp)q->vleng,
00862                                                 new_arg_length(q));
00863                                         }
00864                                 }
00865                         }
00866                 if (q->vdimfinish)
00867                         dim_finish(q);
00868                 if (q->vtype == TYCHAR && q->vclass != CLPROC)
00869                         k++;
00870                 }
00871 
00872         if (entryname->extype != type)
00873                 changedtype(np);
00874 
00875         /* save information for checking consistency of arg lists */
00876 
00877         it = infertypes;
00878         if (entryname->exproto)
00879                 infertypes = 1;
00880         save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
00881                         0, np->fvarname, STGEXT, k, np->vtype, 2);
00882         infertypes = it;
00883 }
00884 
00885 
00886 
00887  LOCAL int
00888 #ifdef KR_headers
00889 nextarg(type)
00890         int type;
00891 #else
00892 nextarg(int type)
00893 #endif
00894 {
00895         type = type;    /* shut up warning */
00896         return(lastargslot++);
00897         }
00898 
00899  LOCAL void
00900 #ifdef KR_headers
00901 dim_check(q)
00902         Namep q;
00903 #else
00904 dim_check(Namep q)
00905 #endif
00906 {
00907         register struct Dimblock *vdim = q->vdim;
00908         register expptr nelt;
00909 
00910         if(!(nelt = vdim->nelt) || !ISCONST(nelt))
00911                 dclerr("adjustable dimension on non-argument", q);
00912         else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL))
00913                 bad_dimtype(q);
00914         else if (ISINT(nelt->headblock.vtype)
00915                     && nelt->constblock.Const.ci <= 0
00916                  || nelt->constblock.Const.cd[0] <= 0)
00917                 dclerr("nonpositive dimension", q);
00918         }
00919 
00920  LOCAL void
00921 dobss(Void)
00922 {
00923         register struct Hashentry *p;
00924         register Namep q;
00925         int qstg, qclass, qtype;
00926         Extsym *e;
00927 
00928         for(p = hashtab ; p<lasthash ; ++p)
00929                 if(q = p->varp)
00930                 {
00931                         qstg = q->vstg;
00932                         qtype = q->vtype;
00933                         qclass = q->vclass;
00934 
00935                         if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
00936                             (qclass==CLVAR && qstg==STGUNKNOWN) ) {
00937                                 if (!(q->vis_assigned | q->vimpldovar))
00938                                         warn1("local variable %s never used",
00939                                                 q->fvarname);
00940                                 }
00941                         else if(qclass==CLVAR && qstg==STGBSS)
00942                         { ; }
00943 
00944 /* Give external procedures the proper storage class */
00945 
00946                         else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
00947                                         && qstg!=STGARG) {
00948                                 e = mkext(q->fvarname,addunder(q->cvarname));
00949                                 e->extstg = STGEXT;
00950                                 q->vardesc.varno = e - extsymtab;
00951                                 if (e->extype != qtype)
00952                                         changedtype(q);
00953                                 }
00954                         if(qclass==CLVAR) {
00955                             if (qstg != STGARG && q->vdim)
00956                                 dim_check(q);
00957                         } /* if qclass == CLVAR */
00958                 }
00959 
00960 }
00961 
00962 
00963  void
00964 donmlist(Void)
00965 {
00966         register struct Hashentry *p;
00967         register Namep q;
00968 
00969         for(p=hashtab; p<lasthash; ++p)
00970                 if( (q = p->varp) && q->vclass==CLNAMELIST)
00971                         namelist(q);
00972 }
00973 
00974 
00975 /* iarrlen -- Returns the size of the array in bytes, or -1 */
00976 
00977  ftnint
00978 #ifdef KR_headers
00979 iarrlen(q)
00980         register Namep q;
00981 #else
00982 iarrlen(register Namep q)
00983 #endif
00984 {
00985         ftnint leng;
00986 
00987         leng = typesize[q->vtype];
00988         if(leng <= 0)
00989                 return(-1);
00990         if(q->vdim)
00991                 if( ISICON(q->vdim->nelt) )
00992                         leng *= q->vdim->nelt->constblock.Const.ci;
00993                 else    return(-1);
00994         if(q->vleng)
00995                 if( ISICON(q->vleng) )
00996                         leng *= q->vleng->constblock.Const.ci;
00997                 else return(-1);
00998         return(leng);
00999 }
01000 
01001  void
01002 #ifdef KR_headers
01003 namelist(np)
01004         Namep np;
01005 #else
01006 namelist(Namep np)
01007 #endif
01008 {
01009         register chainp q;
01010         register Namep v;
01011         int y;
01012 
01013         if (!np->visused)
01014                 return;
01015         y = 0;
01016 
01017         for(q = np->varxptr.namelist ; q ; q = q->nextp)
01018         {
01019                 vardcl( v = (Namep) (q->datap) );
01020                 if( !ONEOF(v->vstg, MSKSTATIC) )
01021                         dclerr("may not appear in namelist", v);
01022                 else {
01023                         v->vnamelist = 1;
01024                         v->visused = 1;
01025                         v->vsave = 1;
01026                         y = 1;
01027                         }
01028         np->visused = y;
01029         }
01030 }
01031 
01032 /* docommon -- called at the end of procedure declarations, before
01033    equivalences and the procedure body */
01034 
01035  LOCAL void
01036 docommon(Void)
01037 {
01038     register Extsym *extptr;
01039     register chainp q, q1;
01040     struct Dimblock *t;
01041     expptr neltp;
01042     register Namep comvar;
01043     ftnint size;
01044     int i, k, pref, type;
01045     extern int type_pref[];
01046 
01047     for(extptr = extsymtab ; extptr<nextext ; ++extptr)
01048         if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
01049 
01050 /* If a common declaration also had a list of variables ... */
01051 
01052             q = extptr->extp = revchain(q);
01053             pref = 1;
01054             for(k = TYCHAR; q ; q = q->nextp)
01055             {
01056                 comvar = (Namep) (q->datap);
01057 
01058                 if(comvar->vdcldone == NO)
01059                     vardcl(comvar);
01060                 type = comvar->vtype;
01061                 if (pref < type_pref[type])
01062                         pref = type_pref[k = type];
01063                 if(extptr->extleng % typealign[type] != 0) {
01064                     dclerr("common alignment", comvar);
01065                     --nerr; /* don't give bad return code for this */
01066 #if 0
01067                     extptr->extleng = roundup(extptr->extleng, typealign[type]);
01068 #endif
01069                 } /* if extptr -> extleng % */
01070 
01071 /* Set the offset into the common block */
01072 
01073                 comvar->voffset = extptr->extleng;
01074                 comvar->vardesc.varno = extptr - extsymtab;
01075                 if(type == TYCHAR)
01076                         if (comvar->vleng)
01077                                 size = comvar->vleng->constblock.Const.ci;
01078                         else  {
01079                                 dclerr("character*(*) in common", comvar);
01080                                 size = 1;
01081                                 }
01082                 else
01083                         size = typesize[type];
01084                 if(t = comvar->vdim)
01085                     if( (neltp = t->nelt) && ISCONST(neltp) )
01086                         size *= neltp->constblock.Const.ci;
01087                     else
01088                         dclerr("adjustable array in common", comvar);
01089 
01090 /* Adjust the length of the common block so far */
01091 
01092                 extptr->extleng += size;
01093             } /* for */
01094 
01095             extptr->extype = k;
01096 
01097 /* Determine curno and, if new, save this identifier chain */
01098 
01099             q1 = extptr->extp;
01100             for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
01101                 if (struct_eq((chainp)q->datap, q1))
01102                         break;
01103             if (q)
01104                 extptr->curno = extptr->maxno - i;
01105             else {
01106                 extptr->curno = ++extptr->maxno;
01107                 extptr->allextp = mkchain((char *)extptr->extp,
01108                                                 extptr->allextp);
01109                 }
01110         } /* if extptr -> extstg == STGCOMMON */
01111 
01112 /* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
01113    varno.  And the common block itself has its full size in extleng. */
01114 
01115 } /* docommon */
01116 
01117 
01118 /* copy_data -- copy the Namep entries so they are available even after
01119    the hash table is empty */
01120 
01121  void
01122 #ifdef KR_headers
01123 copy_data(list)
01124         chainp list;
01125 #else
01126 copy_data(chainp list)
01127 #endif
01128 {
01129     for (; list; list = list -> nextp) {
01130         Namep namep = ALLOC (Nameblock);
01131         int size, nd, i;
01132         struct Dimblock *dp;
01133 
01134         cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
01135         namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
01136                 namep->fvarname);
01137         namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
01138                 ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
01139                 : namep->fvarname;
01140         if (namep -> vleng)
01141             namep -> vleng = (expptr) cpexpr (namep -> vleng);
01142         if (namep -> vdim) {
01143             nd = namep -> vdim -> ndim;
01144             size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
01145             dp = (struct Dimblock *) ckalloc (size);
01146             cpn(size, (char *)namep->vdim, (char *)dp);
01147             namep -> vdim = dp;
01148             dp->nelt = (expptr)cpexpr(dp->nelt);
01149             for (i = 0; i < nd; i++) {
01150                 dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
01151             } /* for */
01152         } /* if */
01153         list -> datap = (char *) namep;
01154     } /* for */
01155 } /* copy_data */
01156 
01157 
01158 
01159  LOCAL void
01160 docomleng(Void)
01161 {
01162         register Extsym *p;
01163 
01164         for(p = extsymtab ; p < nextext ; ++p)
01165                 if(p->extstg == STGCOMMON)
01166                 {
01167                         if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
01168                             && strcmp(Blank, p->cextname) )
01169                                 warn1("incompatible lengths for common block %.60s",
01170                                     p->fextname);
01171                         if(p->maxleng < p->extleng)
01172                                 p->maxleng = p->extleng;
01173                         p->extleng = 0;
01174                 }
01175 }
01176 
01177 
01178 /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
01179 
01180  void
01181 #ifdef KR_headers
01182 frtemp(p)
01183         Addrp p;
01184 #else
01185 frtemp(Addrp p)
01186 #endif
01187 {
01188         /* put block on chain of temps to be reclaimed */
01189         holdtemps = mkchain((char *)p, holdtemps);
01190 }
01191 
01192  void
01193 freetemps(Void)
01194 {
01195         register chainp p, p1;
01196         register Addrp q;
01197         register int t;
01198 
01199         p1 = holdtemps;
01200         while(p = p1) {
01201                 q = (Addrp)p->datap;
01202                 t = q->vtype;
01203                 if (t == TYCHAR && q->varleng != 0) {
01204                         /* restore clobbered character string lengths */
01205                         frexpr(q->vleng);
01206                         q->vleng = ICON(q->varleng);
01207                         }
01208                 p1 = p->nextp;
01209                 p->nextp = templist[t];
01210                 templist[t] = p;
01211                 }
01212         holdtemps = 0;
01213         }
01214 
01215 /* allocate an automatic variable slot for each of   nelt   variables */
01216 
01217  Addrp
01218 #ifdef KR_headers
01219 autovar(nelt0, t, lengp, name)
01220         register int nelt0;
01221         register int t;
01222         expptr lengp;
01223         char *name;
01224 #else
01225 autovar(register int nelt0, register int t, expptr lengp, char *name)
01226 #endif
01227 {
01228         ftnint leng;
01229         register Addrp q;
01230         register int nelt = nelt0 > 0 ? nelt0 : 1;
01231         extern char *av_pfix[];
01232 
01233         if(t == TYCHAR)
01234                 if( ISICON(lengp) )
01235                         leng = lengp->constblock.Const.ci;
01236                 else    {
01237                         Fatal("automatic variable of nonconstant length");
01238                 }
01239         else
01240                 leng = typesize[t];
01241 
01242         q = ALLOC(Addrblock);
01243         q->tag = TADDR;
01244         q->vtype = t;
01245         if(t == TYCHAR)
01246         {
01247                 q->vleng = ICON(leng);
01248                 q->varleng = leng;
01249         }
01250         q->vstg = STGAUTO;
01251         q->ntempelt = nelt;
01252         q->isarray = (nelt > 1);
01253         q->memoffset = ICON(0);
01254 
01255         /* kludge for nls so we can have ret_val rather than ret_val_4 */
01256         if (*name == ' ')
01257                 unamstring(q, name);
01258         else {
01259                 q->uname_tag = UNAM_IDENT;
01260                 temp_name(av_pfix[t], ++autonum[t], q->user.ident);
01261                 }
01262         if (nelt0 > 0)
01263                 declare_new_addr (q);
01264         return(q);
01265 }
01266 
01267 
01268 /* Returns a temporary of the appropriate type.  Will reuse existing
01269    temporaries when possible */
01270 
01271  Addrp
01272 #ifdef KR_headers
01273 mktmpn(nelt, type, lengp)
01274         int nelt;
01275         register int type;
01276         expptr lengp;
01277 #else
01278 mktmpn(int nelt, register int type, expptr lengp)
01279 #endif
01280 {
01281         ftnint leng;
01282         chainp p, oldp;
01283         register Addrp q;
01284         extern int krparens;
01285 
01286         if(type==TYUNKNOWN || type==TYERROR)
01287                 badtype("mktmpn", type);
01288 
01289         if(type==TYCHAR)
01290                 if(lengp && ISICON(lengp) )
01291                         leng = lengp->constblock.Const.ci;
01292                 else    {
01293                         err("adjustable length");
01294                         return( (Addrp) errnode() );
01295                 }
01296         else if (type > TYCHAR || type < TYADDR) {
01297                 erri("mktmpn: unexpected type %d", type);
01298                 exit(1);
01299                 }
01300 /*
01301  * if a temporary of appropriate shape is on the templist,
01302  * remove it from the list and return it
01303  */
01304         if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX)))
01305                 type++;
01306         for(oldp=CHNULL, p=templist[type];  p  ;  oldp=p, p=p->nextp)
01307         {
01308                 q = (Addrp) (p->datap);
01309                 if(q->ntempelt==nelt &&
01310                     (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
01311                 {
01312                         if(oldp)
01313                                 oldp->nextp = p->nextp;
01314                         else
01315                                 templist[type] = p->nextp;
01316                         free( (charptr) p);
01317                         return(q);
01318                 }
01319         }
01320         q = autovar(nelt, type, lengp, "");
01321         return(q);
01322 }
01323 
01324 
01325 
01326 
01327 /* mktmp -- create new local variable; call it something like   name
01328    lengp   is taken directly, not copied */
01329 
01330  Addrp
01331 #ifdef KR_headers
01332 mktmp(type, lengp)
01333         int type;
01334         expptr lengp;
01335 #else
01336 mktmp(int type, expptr lengp)
01337 #endif
01338 {
01339         Addrp rv;
01340         /* arrange for temporaries to be recycled */
01341         /* at the end of this statement... */
01342         rv = mktmpn(1,type,lengp);
01343         frtemp((Addrp)cpexpr((expptr)rv));
01344         return rv;
01345 }
01346 
01347 /* mktmp0 omits frtemp() */
01348  Addrp
01349 #ifdef KR_headers
01350 mktmp0(type, lengp)
01351         int type;
01352         expptr lengp;
01353 #else
01354 mktmp0(int type, expptr lengp)
01355 #endif
01356 {
01357         Addrp rv;
01358         /* arrange for temporaries to be recycled */
01359         /* when this Addrp is freed */
01360         rv = mktmpn(1,type,lengp);
01361         rv->istemp = YES;
01362         return rv;
01363 }
01364 
01365 /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
01366 
01367 /* comblock -- Declare a new common block.  Input parameters name the block;
01368    s   will be NULL if the block is unnamed */
01369 
01370  Extsym *
01371 #ifdef KR_headers
01372 comblock(s)
01373         register char *s;
01374 #else
01375 comblock(register char *s)
01376 #endif
01377 {
01378         Extsym *p;
01379         register char *t;
01380         register int c, i;
01381         char cbuf[256], *s0;
01382 
01383 /* Give the unnamed common block a unique name */
01384 
01385         if(*s == 0)
01386                 p = mkext1(s0 = Blank, Blank);
01387         else {
01388                 s0 = s;
01389                 t = cbuf;
01390                 for(i = 0; c = *t = *s++; t++)
01391                         if (c == '_')
01392                                 i = 1;
01393                 if (i)
01394                         *t++ = '_';
01395                 t[0] = '_';
01396                 t[1] = 0;
01397                 p = mkext1(s0,cbuf);
01398                 }
01399         if(p->extstg == STGUNKNOWN)
01400                 p->extstg = STGCOMMON;
01401         else if(p->extstg != STGCOMMON)
01402         {
01403                 errstr("%.52s cannot be a common block: it is a subprogram.",
01404                         s0);
01405                 return(0);
01406         }
01407 
01408         return( p );
01409 }
01410 
01411 
01412 /* incomm -- add a new variable to a common declaration */
01413 
01414  void
01415 #ifdef KR_headers
01416 incomm(c, v)
01417         Extsym *c;
01418         Namep v;
01419 #else
01420 incomm(Extsym *c, Namep v)
01421 #endif
01422 {
01423         if (!c)
01424                 return;
01425         if(v->vstg != STGUNKNOWN && !v->vimplstg)
01426                 dclerr(v->vstg == STGARG
01427                         ? "dummy arguments cannot be in common"
01428                         : "incompatible common declaration", v);
01429         else
01430         {
01431                 v->vstg = STGCOMMON;
01432                 c->extp = mkchain((char *)v, c->extp);
01433         }
01434 }
01435 
01436 
01437 
01438 
01439 /* settype -- set the type or storage class of a Namep object.  If
01440    v -> vstg == STGUNKNOWN && type < 0,   attempt to reset vstg to be
01441    -type.  This function will not change any earlier definitions in   v,
01442    in will only attempt to fill out more information give the other params */
01443 
01444  void
01445 #ifdef KR_headers
01446 settype(v, type, length)
01447         register Namep v;
01448         register int type;
01449         register ftnint length;
01450 #else
01451 settype(register Namep v, register int type, register ftnint length)
01452 #endif
01453 {
01454         int type1;
01455 
01456         if(type == TYUNKNOWN)
01457                 return;
01458 
01459         if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
01460         {
01461                 v->vtype = TYSUBR;
01462                 frexpr(v->vleng);
01463                 v->vleng = 0;
01464                 v->vimpltype = 0;
01465         }
01466         else if(type < 0)       /* storage class set */
01467         {
01468                 if(v->vstg == STGUNKNOWN)
01469                         v->vstg = - type;
01470                 else if(v->vstg != -type)
01471                         dclerr("incompatible storage declarations", v);
01472         }
01473         else if(v->vtype == TYUNKNOWN
01474                 || v->vtype != type
01475                         && (v->vimpltype || v->vinftype || v->vinfproc))
01476         {
01477                 if( (v->vtype = lengtype(type, length))==TYCHAR )
01478                         if (length>=0)
01479                                 v->vleng = ICON(length);
01480                         else if (parstate >= INDATA)
01481                                 v->vleng = ICON(1);     /* avoid a memory fault */
01482                 v->vimpltype = 0;
01483                 v->vinftype = 0; /* 19960709 */
01484                 v->vinfproc = 0; /* 19960709 */
01485 
01486                 if (v->vclass == CLPROC) {
01487                         if (v->vstg == STGEXT
01488                          && (type1 = extsymtab[v->vardesc.varno].extype)
01489                          &&  type1 != v->vtype)
01490                                 changedtype(v);
01491                         else if (v->vprocclass == PTHISPROC
01492                                         && (parstate >= INDATA
01493                                                 || procclass == CLMAIN)
01494                                         && !xretslot[type]) {
01495                                 xretslot[type] = autovar(ONEOF(type,
01496                                         MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
01497                                         v->vleng, " ret_val");
01498                                 if (procclass == CLMAIN)
01499                                         errstr(
01500                                 "illegal use of %.60s (main program name)",
01501                                         v->fvarname);
01502                                 /* not completely right, but enough to */
01503                                 /* avoid memory faults; we won't */
01504                                 /* emit any C as we have illegal Fortran */
01505                                 }
01506                         }
01507         }
01508         else if(v->vtype!=type) {
01509  incompat:
01510                 dclerr("incompatible type declarations", v);
01511                 }
01512         else if (type==TYCHAR)
01513                 if (v->vleng && v->vleng->constblock.Const.ci != length)
01514                         goto incompat;
01515                 else if (parstate >= INDATA)
01516                         v->vleng = ICON(1);     /* avoid a memory fault */
01517 }
01518 
01519 
01520 
01521 
01522 
01523 /* lengtype -- returns the proper compiler type, given input of Fortran
01524    type and length specifier */
01525 
01526  int
01527 #ifdef KR_headers
01528 lengtype(type, len)
01529         register int type;
01530         ftnint len;
01531 #else
01532 lengtype(register int type, ftnint len)
01533 #endif
01534 {
01535         register int length = (int)len;
01536         switch(type)
01537         {
01538         case TYREAL:
01539                 if(length == typesize[TYDREAL])
01540                         return(TYDREAL);
01541                 if(length == typesize[TYREAL])
01542                         goto ret;
01543                 break;
01544 
01545         case TYCOMPLEX:
01546                 if(length == typesize[TYDCOMPLEX])
01547                         return(TYDCOMPLEX);
01548                 if(length == typesize[TYCOMPLEX])
01549                         goto ret;
01550                 break;
01551 
01552         case TYINT1:
01553         case TYSHORT:
01554         case TYDREAL:
01555         case TYDCOMPLEX:
01556         case TYCHAR:
01557         case TYLOGICAL1:
01558         case TYLOGICAL2:
01559         case TYUNKNOWN:
01560         case TYSUBR:
01561         case TYERROR:
01562 #ifdef TYQUAD
01563         case TYQUAD:
01564 #endif
01565                 goto ret;
01566 
01567         case TYLOGICAL:
01568                 switch(length) {
01569                         case 0: return tylog;
01570                         case 1: return TYLOGICAL1;
01571                         case 2: return TYLOGICAL2;
01572                         case 4: goto ret;
01573                         }
01574 #if 0 /*!!??!!*/
01575                 if(length == typesize[TYLOGICAL])
01576                         goto ret;
01577 #endif
01578                 break;
01579 
01580         case TYLONG:
01581                 if(length == 0)
01582                         return(tyint);
01583                 if (length == 1)
01584                         return TYINT1;
01585                 if(length == typesize[TYSHORT])
01586                         return(TYSHORT);
01587 #ifdef TYQUAD
01588                 if(length == typesize[TYQUAD] && use_tyquad)
01589                         return(TYQUAD);
01590 #endif
01591                 if(length == typesize[TYLONG])
01592                         goto ret;
01593                 break;
01594         default:
01595                 badtype("lengtype", type);
01596         }
01597 
01598         if(len != 0)
01599                 err("incompatible type-length combination");
01600 
01601 ret:
01602         return(type);
01603 }
01604 
01605 
01606 
01607 
01608 
01609 /* setintr -- Set Intrinsic function */
01610 
01611  void
01612 #ifdef KR_headers
01613 setintr(v)
01614         register Namep v;
01615 #else
01616 setintr(register Namep v)
01617 #endif
01618 {
01619         int k;
01620 
01621         if(k = intrfunct(v->fvarname)) {
01622                 if ((*(struct Intrpacked *)&k).f4)
01623                         if (noextflag)
01624                                 goto unknown;
01625                         else
01626                                 dcomplex_seen++;
01627                 v->vardesc.varno = k;
01628                 }
01629         else {
01630  unknown:
01631                 dclerr("unknown intrinsic function", v);
01632                 return;
01633                 }
01634         if(v->vstg == STGUNKNOWN)
01635                 v->vstg = STGINTR;
01636         else if(v->vstg!=STGINTR)
01637                 dclerr("incompatible use of intrinsic function", v);
01638         if(v->vclass==CLUNKNOWN)
01639                 v->vclass = CLPROC;
01640         if(v->vprocclass == PUNKNOWN)
01641                 v->vprocclass = PINTRINSIC;
01642         else if(v->vprocclass != PINTRINSIC)
01643                 dclerr("invalid intrinsic declaration", v);
01644 }
01645 
01646 
01647 
01648 /* setext -- Set External declaration -- assume that unknowns will become
01649    procedures */
01650 
01651  void
01652 #ifdef KR_headers
01653 setext(v)
01654         register Namep v;
01655 #else
01656 setext(register Namep v)
01657 #endif
01658 {
01659         if(v->vclass == CLUNKNOWN)
01660                 v->vclass = CLPROC;
01661         else if(v->vclass != CLPROC)
01662                 dclerr("invalid external declaration", v);
01663 
01664         if(v->vprocclass == PUNKNOWN)
01665                 v->vprocclass = PEXTERNAL;
01666         else if(v->vprocclass != PEXTERNAL)
01667                 dclerr("invalid external declaration", v);
01668 } /* setext */
01669 
01670 
01671 
01672 
01673 /* create dimensions block for array variable */
01674 
01675  void
01676 #ifdef KR_headers
01677 setbound(v, nd, dims)
01678         register Namep v;
01679         int nd;
01680         struct Dims *dims;
01681 #else
01682 setbound(register Namep v, int nd, struct Dims *dims)
01683 #endif
01684 {
01685         register expptr q, t;
01686         register struct Dimblock *p;
01687         int i;
01688         extern chainp new_vars;
01689         char buf[256];
01690 
01691         if(v->vclass == CLUNKNOWN)
01692                 v->vclass = CLVAR;
01693         else if(v->vclass != CLVAR)
01694         {
01695                 dclerr("only variables may be arrays", v);
01696                 return;
01697         }
01698 
01699         v->vdim = p = (struct Dimblock *)
01700             ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
01701         p->ndim = nd--;
01702         p->nelt = ICON(1);
01703         doin_setbound = 1;
01704 
01705         if (noextflag)
01706                 for(i = 0; i <= nd; i++)
01707                         if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))
01708                          || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) {
01709                                 sprintf(buf, "dimension %d of %s is not an integer.",
01710                                         i+1, v->fvarname);
01711                                 errext(buf);
01712                                 break;
01713                                 }
01714 
01715         for(i = 0; i <= nd; i++) {
01716                 if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)))
01717                         dims[i].lb = mkconv(TYINT, q);
01718                 if (((q = dims[i].ub) && !ISINT(q->headblock.vtype)))
01719                         dims[i].ub = mkconv(TYINT, q);
01720                 }
01721 
01722         for(i = 0; i <= nd; ++i)
01723         {
01724                 if( (q = dims[i].ub) == NULL)
01725                 {
01726                         if(i == nd)
01727                         {
01728                                 frexpr(p->nelt);
01729                                 p->nelt = NULL;
01730                         }
01731                         else
01732                                 err("only last bound may be asterisk");
01733                         p->dims[i].dimsize = ICON(1);
01734                         p->dims[i].dimexpr = NULL;
01735                 }
01736                 else
01737                 {
01738 
01739                         if(dims[i].lb)
01740                         {
01741                                 q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
01742                                 q = mkexpr(OPPLUS, q, ICON(1) );
01743                         }
01744                         if( ISCONST(q) )
01745                         {
01746                                 p->dims[i].dimsize = q;
01747                                 p->dims[i].dimexpr = (expptr) PNULL;
01748                         }
01749                         else {
01750                                 sprintf(buf, " %s_dim%d", v->fvarname, i+1);
01751                                 p->dims[i].dimsize = (expptr)
01752                                         autovar(1, tyint, EXNULL, buf);
01753                                 p->dims[i].dimexpr = q;
01754                                 if (i == nd)
01755                                         v->vlastdim = new_vars;
01756                                 v->vdimfinish = 1;
01757                         }
01758                         if(p->nelt)
01759                                 p->nelt = mkexpr(OPSTAR, p->nelt,
01760                                     cpexpr(p->dims[i].dimsize) );
01761                 }
01762         }
01763 
01764         q = dims[nd].lb;
01765         if(q == NULL)
01766                 q = ICON(1);
01767 
01768         for(i = nd-1 ; i>=0 ; --i)
01769         {
01770                 t = dims[i].lb;
01771                 if(t == NULL)
01772                         t = ICON(1);
01773                 if(p->dims[i].dimsize)
01774                         q = mkexpr(OPPLUS, t,
01775                                 mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q));
01776         }
01777 
01778         if( ISCONST(q) )
01779         {
01780                 p->baseoffset = q;
01781                 p->basexpr = NULL;
01782         }
01783         else
01784         {
01785                 sprintf(buf, " %s_offset", v->fvarname);
01786                 p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
01787                 p->basexpr = q;
01788                 v->vdimfinish = 1;
01789         }
01790         doin_setbound = 0;
01791 }
01792 
01793 
01794  void
01795 #ifdef KR_headers
01796 wr_abbrevs(outfile, function_head, vars)
01797         FILE *outfile;
01798         int function_head;
01799         chainp vars;
01800 #else
01801 wr_abbrevs(FILE *outfile, int function_head, chainp vars)
01802 #endif
01803 {
01804     for (; vars; vars = vars -> nextp) {
01805         Namep name = (Namep) vars -> datap;
01806         if (!name->visused)
01807                 continue;
01808 
01809         if (function_head)
01810             nice_printf (outfile, "#define ");
01811         else
01812             nice_printf (outfile, "#undef ");
01813         out_name (outfile, name);
01814 
01815         if (function_head) {
01816             Extsym *comm = &extsymtab[name -> vardesc.varno];
01817 
01818             nice_printf (outfile, " (");
01819             extern_out (outfile, comm);
01820             nice_printf (outfile, "%d.", comm->curno);
01821             nice_printf (outfile, "%s)", name->cvarname);
01822         } /* if function_head */
01823         nice_printf (outfile, "\n");
01824     } /* for */
01825 } /* wr_abbrevs */