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