lang/fortran/comp/proc.c

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