4.3BSD - /usr/src/usr.bin/f77/src/f77pass1/proc.c

   1: /*
   2:  * Copyright (c) 1980 Regents of the University of California.
   3:  * All rights reserved.  The Berkeley software License Agreement
   4:  * specifies the terms and conditions for redistribution.
   5:  */
   6: 
   7: #ifndef lint
   8: static char sccsid[] = "@(#)proc.c	5.7 (Berkeley) 1/30/86";
   9: #endif not lint
  10: 
  11: /*
  12:  * proc.c
  13:  *
  14:  * Routines for handling procedures, f77 compiler, pass 1.
  15:  *
  16:  * University of Utah CS Dept modification history:
  17:  *
  18:  * $Log:	proc.c,v $
  19:  * Revision 5.9  86/01/28  22:30:28  donn
  20:  * Let functions of type character have adjustable length.
  21:  *
  22:  * Revision 5.8  86/01/10  19:02:19  donn
  23:  * More dbx hacking -- filter out incomplete declarations (with bogus types).
  24:  *
  25:  * Revision 5.7  86/01/10  13:53:02  donn
  26:  * Since we now postpone determination of the type of an argument, we must
  27:  * make sure to emit stab information at the end of the routine when we
  28:  * definitely have the type.  Notice some care was taken to make sure that
  29:  * arguments appear in order in the output file since that's how dbx wants
  30:  * them.  Also a minor change for dummy procedures.
  31:  *
  32:  * Revision 5.6  86/01/06  16:28:06  donn
  33:  * Sigh.  We can't commit to defining a symbol as a variable instead of a
  34:  * function based only on what we have seen through the declaration section;
  35:  * this was properly handled for normal variables but not for arguments.
  36:  *
  37:  * Revision 5.5  86/01/01  21:59:17  donn
  38:  * Pick up CHARACTER*(*) declarations for variables which aren't dummy
  39:  * arguments, and complain about them.
  40:  *
  41:  * Revision 5.4  85/12/20  19:18:35  donn
  42:  * Don't assume that dummy procedures of unknown type are functions of type
  43:  * undefined until the user (mis-)uses them that way -- they may also be
  44:  * subroutines.
  45:  *
  46:  * Revision 5.3  85/09/30  23:21:07  donn
  47:  * Print space with prspace() in outlocvars() so that alignment is preserved.
  48:  *
  49:  * Revision 5.2  85/08/10  05:03:34  donn
  50:  * Support for NAMELIST i/o from Jerry Berkman.
  51:  *
  52:  * Revision 5.1  85/08/10  03:49:14  donn
  53:  * 4.3 alpha
  54:  *
  55:  * Revision 3.11  85/06/04  03:45:29  donn
  56:  * Changed retval() to recognize that a function declaration might have
  57:  * bombed out earlier, leaving an error node behind...
  58:  *
  59:  * Revision 3.10  85/03/08  23:13:06  donn
  60:  * Finally figured out why function calls and array elements are not legal
  61:  * dummy array dimension declarator elements.  Hacked safedim() to stop 'em.
  62:  *
  63:  * Revision 3.9  85/02/02  00:26:10  donn
  64:  * Removed the call to entrystab() in enddcl() -- this was redundant (it was
  65:  * also done in startproc()) and confusing to dbx to boot.
  66:  *
  67:  * Revision 3.8  85/01/14  04:21:53  donn
  68:  * Added changes to implement Jerry's '-q' option.
  69:  *
  70:  * Revision 3.7  85/01/11  21:10:35  donn
  71:  * In conjunction with other changes to implement SAVE statements, function
  72:  * nameblocks were changed to make it appear that they are 'saved' too --
  73:  * this arranges things so that function return values are forced out of
  74:  * register before a return.
  75:  *
  76:  * Revision 3.6  84/12/10  19:27:20  donn
  77:  * comblock() signals an illegal common block name by returning a null pointer,
  78:  * but incomm() wasn't able to handle it, leading to core dumps.  I put the
  79:  * fix in incomm() to pick up null common blocks.
  80:  *
  81:  * Revision 3.5  84/11/21  20:33:31  donn
  82:  * It seems that I/O elements are treated as character strings so that their
  83:  * length can be passed to the I/O routines...  Unfortunately the compiler
  84:  * assumes that no temporaries can be of type CHARACTER and casually tosses
  85:  * length and type info away when removing TEMP blocks.  This has been fixed...
  86:  *
  87:  * Revision 3.4  84/11/05  22:19:30  donn
  88:  * Fixed a silly bug in the last fix.
  89:  *
  90:  * Revision 3.3  84/10/29  08:15:23  donn
  91:  * Added code to check the type and shape of subscript declarations,
  92:  * per Jerry Berkman's suggestion.
  93:  *
  94:  * Revision 3.2  84/10/29  05:52:07  donn
  95:  * Added change suggested by Jerry Berkman to report an error when an array
  96:  * is redimensioned.
  97:  *
  98:  * Revision 3.1  84/10/13  02:12:31  donn
  99:  * Merged Jerry Berkman's version into mine.
 100:  *
 101:  * Revision 2.1  84/07/19  12:04:09  donn
 102:  * Changed comment headers for UofU.
 103:  *
 104:  * Revision 1.6  84/07/19  11:32:15  donn
 105:  * Incorporated fix to setbound() to detect backward array subscript limits.
 106:  * The fix is by Bob Corbett, donated by Jerry Berkman.
 107:  *
 108:  * Revision 1.5  84/07/18  18:25:50  donn
 109:  * Fixed problem with doentry() where a placeholder for a return value
 110:  * was not allocated if the first entry didn't require one but a later
 111:  * entry did.
 112:  *
 113:  * Revision 1.4  84/05/24  20:52:09  donn
 114:  * Installed firewall #ifdef around the code that recycles stack temporaries,
 115:  * since it seems to be broken and lacks a good fix for the time being.
 116:  *
 117:  * Revision 1.3  84/04/16  09:50:46  donn
 118:  * Fixed mkargtemp() so that it only passes back a copy of a temporary, keeping
 119:  * the original for its own use.  This fixes a set of bugs that are caused by
 120:  * elements in the argtemplist getting stomped on.
 121:  *
 122:  * Revision 1.2  84/02/28  21:12:58  donn
 123:  * Added Berkeley changes for subroutine call argument temporaries fix.
 124:  *
 125:  */
 126: 
 127: #include "defs.h"
 128: 
 129: #ifdef SDB
 130: #	include <a.out.h>
 131: #	ifndef N_SO
 132: #		include <stab.h>
 133: #	endif
 134: #endif
 135: 
 136: extern flag namesflag;
 137: 
 138: typedef
 139:   struct SizeList
 140:     {
 141:       struct SizeList *next;
 142:       ftnint size;
 143:       struct VarList *vars;
 144:     }
 145:   sizelist;
 146: 
 147: 
 148: typedef
 149:   struct VarList
 150:     {
 151:       struct VarList *next;
 152:       Namep np;
 153:       struct Equivblock *ep;
 154:     }
 155:   varlist;
 156: 
 157: 
 158: LOCAL sizelist *varsizes;
 159: 
 160: 
 161: /* start a new procedure */
 162: 
 163: newproc()
 164: {
 165: if(parstate != OUTSIDE)
 166:     {
 167:     execerr("missing end statement", CNULL);
 168:     endproc();
 169:     }
 170: 
 171: parstate = INSIDE;
 172: procclass = CLMAIN; /* default */
 173: }
 174: 
 175: 
 176: 
 177: /* end of procedure. generate variables, epilogs, and prologs */
 178: 
 179: endproc()
 180: {
 181: struct Labelblock *lp;
 182: 
 183: if(parstate < INDATA)
 184:     enddcl();
 185: if(ctlstack >= ctls)
 186:     err("DO loop or BLOCK IF not closed");
 187: for(lp = labeltab ; lp < labtabend ; ++lp)
 188:     if(lp->stateno!=0 && lp->labdefined==NO)
 189:         errstr("missing statement number %s", convic(lp->stateno) );
 190: 
 191: if (optimflag)
 192:   optimize();
 193: 
 194: outiodata();
 195: epicode();
 196: procode();
 197: donmlist();
 198: dobss();
 199: 
 200: #if FAMILY == PCC
 201:     putbracket();
 202: #endif
 203: fixlwm();
 204: procinit(); /* clean up for next procedure */
 205: }
 206: 
 207: 
 208: 
 209: /* End of declaration section of procedure.  Allocate storage. */
 210: 
 211: enddcl()
 212: {
 213: register struct Entrypoint *ep;
 214: 
 215: parstate = INEXEC;
 216: docommon();
 217: doequiv();
 218: docomleng();
 219: for(ep = entries ; ep ; ep = ep->entnextp) {
 220:     doentry(ep);
 221: }
 222: }
 223: 
 224: /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
 225: 
 226: /* Main program or Block data */
 227: 
 228: startproc(prgname, class)
 229: Namep prgname;
 230: int class;
 231: {
 232: struct Extsym *progname;
 233: register struct Entrypoint *p;
 234: 
 235: if(prgname)
 236:     procname = prgname->varname;
 237: if(namesflag == YES) {
 238:     fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
 239:     if(prgname)
 240:         fprintf(diagfile, " %s", varstr(XL, procname) );
 241:     fprintf(diagfile, ":\n");
 242:     }
 243: 
 244: if( prgname )
 245:     progname = newentry( prgname );
 246: else
 247:     progname = NULL;
 248: 
 249: p = ALLOC(Entrypoint);
 250: if(class == CLMAIN)
 251:     puthead("MAIN_", CLMAIN);
 252: else
 253:     puthead(CNULL, CLBLOCK);
 254: if(class == CLMAIN)
 255:     newentry( mkname(5, "MAIN") );
 256: p->entryname = progname;
 257: p->entrylabel = newlabel();
 258: entries = p;
 259: 
 260: procclass = class;
 261: retlabel = newlabel();
 262: #ifdef SDB
 263: if(sdbflag) {
 264:          entrystab(p,class);
 265: }
 266: #endif
 267: }
 268: 
 269: /* subroutine or function statement */
 270: 
 271: struct Extsym *newentry(v)
 272: register Namep v;
 273: {
 274: register struct Extsym *p;
 275: 
 276: p = mkext( varunder(VL, v->varname) );
 277: 
 278: if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
 279:     {
 280:     if(p == 0)
 281:         dclerr("invalid entry name", v);
 282:     else    dclerr("external name already used", v);
 283:     return(0);
 284:     }
 285: v->vstg = STGAUTO;
 286: v->vprocclass = PTHISPROC;
 287: v->vclass = CLPROC;
 288: p->extstg = STGEXT;
 289: p->extinit = YES;
 290: return(p);
 291: }
 292: 
 293: 
 294: entrypt(class, type, length, entname, args)
 295: int class, type;
 296: ftnint length;
 297: Namep entname;
 298: chainp args;
 299: {
 300: struct Extsym *entry;
 301: register Namep q;
 302: register struct Entrypoint *p, *ep;
 303: 
 304: if(namesflag == YES) {
 305:     if(class == CLENTRY)
 306:         fprintf(diagfile, "       entry ");
 307:     if(entname)
 308:         fprintf(diagfile, "   %s", varstr(XL, entname->varname) );
 309:     fprintf(diagfile, ":\n");
 310:     }
 311: 
 312: if( entname->vclass == CLPARAM ) {
 313:     errstr("entry name %s used in 'parameter' statement",
 314:         varstr(XL, entname->varname) );
 315:     return;
 316:     }
 317: if( ((type == TYSUBR) || (class == CLENTRY && proctype == TYSUBR))
 318:     && (entname->vtype != TYUNKNOWN && entname->vtype != TYSUBR) ) {
 319:     errstr("subroutine entry %s previously declared",
 320:         varstr(XL, entname->varname) );
 321:     return;
 322:     }
 323: if(  (entname->vstg != STGEXT && entname->vstg != STGUNKNOWN)
 324:     ||  (entname->vdim != NULL) ) {
 325:     errstr("subroutine or function entry %s previously declared",
 326:         varstr(XL, entname->varname) );
 327:     return;
 328:     }
 329: 
 330: if( (class == CLPROC || class == CLENTRY) && type != TYSUBR )
 331:     /* arrange to save function return values */
 332:     entname->vsave = YES;
 333: 
 334: entry = newentry( entname );
 335: 
 336: if(class != CLENTRY)
 337:     puthead( varstr(XL, procname = entry->extname), class);
 338: q = mkname(VL, nounder(XL,entry->extname) );
 339: 
 340: if( (type = lengtype(type, (int) length)) != TYCHAR)
 341:     length = 0;
 342: if(class == CLPROC)
 343:     {
 344:     procclass = CLPROC;
 345:     proctype = type;
 346:     procleng = length;
 347: 
 348:     retlabel = newlabel();
 349:     if(type == TYSUBR)
 350:         ret0label = newlabel();
 351:     }
 352: 
 353: p = ALLOC(Entrypoint);
 354: if(entries) /* put new block at end of entries list */
 355:     {
 356:     for(ep = entries; ep->entnextp; ep = ep->entnextp)
 357:         ;
 358:     ep->entnextp = p;
 359:     }
 360: else
 361:     entries = p;
 362: 
 363: p->entryname = entry;
 364: p->arglist = args;
 365: p->entrylabel = newlabel();
 366: p->enamep = q;
 367: 
 368: if(class == CLENTRY)
 369:     {
 370:     class = CLPROC;
 371:     if(proctype == TYSUBR)
 372:         type = TYSUBR;
 373:     }
 374: 
 375: q->vclass = class;
 376: q->vprocclass = PTHISPROC;
 377: settype(q, type, (int) length);
 378: /* hold all initial entry points till end of declarations */
 379: if(parstate >= INDATA) {
 380:     doentry(p);
 381: }
 382: #ifdef SDB
 383:     if(sdbflag)
 384:     { /* may need to preserve CLENTRY here */
 385:     entrystab(p,class);
 386:     }
 387: #endif
 388: }
 389: 
 390: /* generate epilogs */
 391: 
 392: LOCAL epicode()
 393: {
 394: register int i;
 395: 
 396: if(procclass==CLPROC)
 397:     {
 398:     if(proctype==TYSUBR)
 399:         {
 400:         putlabel(ret0label);
 401:         if(substars)
 402:             putforce(TYINT, ICON(0) );
 403:         putlabel(retlabel);
 404:         goret(TYSUBR);
 405:         }
 406:     else    {
 407:         putlabel(retlabel);
 408:         if(multitype)
 409:             {
 410:             typeaddr = autovar(1, TYADDR, PNULL);
 411:             putbranch( cpexpr(typeaddr) );
 412:             for(i = 0; i < NTYPES ; ++i)
 413:                 if(rtvlabel[i] != 0)
 414:                     {
 415:                     putlabel(rtvlabel[i]);
 416:                     retval(i);
 417:                     }
 418:             }
 419:         else
 420:             retval(proctype);
 421:         }
 422:     }
 423: 
 424: else if(procclass != CLBLOCK)
 425:     {
 426:     putlabel(retlabel);
 427:     goret(TYSUBR);
 428:     }
 429: }
 430: 
 431: 
 432: /* generate code to return value of type  t */
 433: 
 434: LOCAL retval(t)
 435: register int t;
 436: {
 437: register Addrp p;
 438: 
 439: switch(t)
 440:     {
 441:     case TYCHAR:
 442:     case TYCOMPLEX:
 443:     case TYDCOMPLEX:
 444:         break;
 445: 
 446:     case TYLOGICAL:
 447:         t = tylogical;
 448:     case TYADDR:
 449:     case TYSHORT:
 450:     case TYLONG:
 451:         p = (Addrp) cpexpr(retslot);
 452:         p->vtype = t;
 453:         putforce(t, p);
 454:         break;
 455: 
 456:     case TYREAL:
 457:     case TYDREAL:
 458:         p = (Addrp) cpexpr(retslot);
 459:         p->vtype = t;
 460:         putforce(t, p);
 461:         break;
 462: 
 463:     case TYERROR:
 464:         return;     /* someone else already complained */
 465: 
 466:     default:
 467:         badtype("retval", t);
 468:     }
 469: goret(t);
 470: }
 471: 
 472: 
 473: /* Allocate extra argument array if needed. Generate prologs. */
 474: 
 475: LOCAL procode()
 476: {
 477: register struct Entrypoint *p;
 478: Addrp argvec;
 479: 
 480: #if TARGET==GCOS
 481:     argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
 482: #else
 483:     if(lastargslot>0 && nentry>1)
 484: #if TARGET == VAX
 485:         argvec = autovar(1 + lastargslot/SZADDR, TYADDR, PNULL);
 486: #else
 487:         argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL);
 488: #endif
 489:     else
 490:         argvec = NULL;
 491: #endif
 492: 
 493: 
 494: #if TARGET == PDP11
 495:     /* for the optimizer */
 496:     if(fudgelabel)
 497:         putlabel(fudgelabel);
 498: #endif
 499: 
 500: for(p = entries ; p ; p = p->entnextp)
 501:     prolog(p, argvec);
 502: 
 503: #if FAMILY == PCC
 504:     putrbrack(procno);
 505: #endif
 506: 
 507: prendproc();
 508: }
 509: 
 510: 
 511: /*
 512:  * manipulate argument lists (allocate argument slot positions)
 513:  * keep track of return types and labels
 514:  */
 515: 
 516: LOCAL doentry(ep)
 517: struct Entrypoint *ep;
 518: {
 519: register int type;
 520: register Namep np;
 521: chainp p;
 522: register Namep q;
 523: Addrp mkarg();
 524: 
 525: ++nentry;
 526: if(procclass == CLMAIN)
 527:     {
 528:     if (optimflag)
 529:         optbuff (SKLABEL, 0, ep->entrylabel, 0);
 530:     else
 531:         putlabel(ep->entrylabel);
 532:     return;
 533:     }
 534: else if(procclass == CLBLOCK)
 535:     return;
 536: 
 537: impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) );
 538: type = np->vtype;
 539: if(proctype == TYUNKNOWN)
 540:     if( (proctype = type) == TYCHAR)
 541:         procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1));
 542: 
 543: if(proctype == TYCHAR)
 544:     {
 545:     if(type != TYCHAR)
 546:         err("noncharacter entry of character function");
 547:     else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)) != procleng)
 548:         err("mismatched character entry lengths");
 549:     }
 550: else if(type == TYCHAR)
 551:     err("character entry of noncharacter function");
 552: else if(type != proctype)
 553:     multitype = YES;
 554: if(rtvlabel[type] == 0)
 555:     rtvlabel[type] = newlabel();
 556: ep->typelabel = rtvlabel[type];
 557: 
 558: if(type == TYCHAR)
 559:     {
 560:     if(chslot < 0)
 561:         {
 562:         chslot = nextarg(TYADDR);
 563:         chlgslot = nextarg(TYLENG);
 564:         }
 565:     np->vstg = STGARG;
 566:     np->vardesc.varno = chslot;
 567:     if(procleng < 0)
 568:         np->vleng = (expptr) mkarg(TYLENG, chlgslot);
 569:     }
 570: else if( ISCOMPLEX(type) )
 571:     {
 572:     np->vstg = STGARG;
 573:     if(cxslot < 0)
 574:         cxslot = nextarg(TYADDR);
 575:     np->vardesc.varno = cxslot;
 576:     }
 577: else if(type != TYSUBR)
 578:     {
 579:     if(retslot == NULL)
 580:         retslot = autovar(1, TYDREAL, PNULL);
 581:     np->vstg = STGAUTO;
 582:     np->voffset = retslot->memoffset->constblock.const.ci;
 583:     }
 584: 
 585: for(p = ep->arglist ; p ; p = p->nextp)
 586:     if(! (( q = (Namep) (p->datap) )->vdcldone) )
 587:         q->vardesc.varno = nextarg(TYADDR);
 588: 
 589: for(p = ep->arglist ; p ; p = p->nextp)
 590:     if(! (( q = (Namep) (p->datap) )->vdcldone) )
 591:         {
 592:         if(q->vclass == CLPROC && q->vtype == TYUNKNOWN)
 593:             continue;
 594:         impldcl(q);
 595:         if(q->vtype == TYCHAR)
 596:             {
 597:             if(q->vleng == NULL)    /* character*(*) */
 598:                 q->vleng = (expptr)
 599:                         mkarg(TYLENG, nextarg(TYLENG) );
 600:             else if(nentry == 1)
 601:                 nextarg(TYLENG);
 602:             }
 603:         else if(q->vclass==CLPROC && nentry==1)
 604:             nextarg(TYLENG) ;
 605:         }
 606: 
 607: if (optimflag)
 608:     optbuff (SKLABEL, 0, ep->entrylabel, 0);
 609: else
 610:     putlabel(ep->entrylabel);
 611: }
 612: 
 613: 
 614: 
 615: LOCAL nextarg(type)
 616: int type;
 617: {
 618: int k;
 619: k = lastargslot;
 620: lastargslot += typesize[type];
 621: return(k);
 622: }
 623: 
 624: /* generate variable references */
 625: 
 626: LOCAL dobss()
 627: {
 628: register struct Hashentry *p;
 629: register Namep q;
 630: register int i;
 631: int align;
 632: ftnint leng, iarrl;
 633: char *memname();
 634: int qstg, qclass, qtype;
 635: 
 636: pruse(asmfile, USEBSS);
 637: varsizes = NULL;
 638: 
 639: for(p = hashtab ; p<lasthash ; ++p)
 640:     if(q = p->varp)
 641:     {
 642:     qstg = q->vstg;
 643:     qtype = q->vtype;
 644:     qclass = q->vclass;
 645: 
 646:     if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
 647:         (qclass==CLVAR && qstg==STGUNKNOWN) )
 648:         warn1("local variable %s never used", varstr(VL,q->varname) );
 649:     else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG)
 650:         mkext(varunder(VL, q->varname)) ->extstg = STGEXT;
 651: 
 652:     if (qclass == CLVAR && qstg == STGBSS)
 653:       {
 654:         if (SMALLVAR(q->varsize))
 655:           {
 656:         enlist(q->varsize, q, NULL);
 657:         q->inlcomm = NO;
 658:           }
 659:         else
 660:           {
 661:         if (q->init == NO)
 662:           {
 663:             preven(ALIDOUBLE);
 664:             prlocvar(memname(qstg, q->vardesc.varno), q->varsize);
 665:             q->inlcomm = YES;
 666:           }
 667:         else
 668:           prlocdata(memname(qstg, q->vardesc.varno), q->varsize,
 669:                 q->vtype, q->initoffset, &(q->inlcomm));
 670:           }
 671:       }
 672:     else if(qclass==CLVAR && qstg!=STGARG)
 673:         {
 674:         if(q->vdim && !ISICON(q->vdim->nelt) )
 675:             dclerr("adjustable dimension on non-argument", q);
 676:         if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
 677:             dclerr("adjustable leng on nonargument", q);
 678:         }
 679: 
 680:     chkdim(q);
 681:     }
 682: 
 683: for (i = 0 ; i < nequiv ; ++i)
 684:   if ( (leng = eqvclass[i].eqvleng) != 0 )
 685:     {
 686:       if (SMALLVAR(leng))
 687:     enlist(leng, NULL, eqvclass + i);
 688:       else if (eqvclass[i].init == NO)
 689:     {
 690:       preven(ALIDOUBLE);
 691:       prlocvar(memname(STGEQUIV, i), leng);
 692:       eqvclass[i].inlcomm = YES;
 693:     }
 694:       else
 695:     prlocdata(memname(STGEQUIV, i), leng, TYDREAL,
 696:           eqvclass[i].initoffset, &(eqvclass[i].inlcomm));
 697:     }
 698: 
 699:   outlocvars();
 700: #ifdef SDB
 701:     if(sdbflag) {
 702:       register struct Entrypoint *ep;
 703:       register chainp cp;
 704: 
 705:       for (ep = entries; ep; ep = ep->entnextp)
 706:     for (cp = ep->arglist ; cp ; cp = cp->nextp)
 707:       if ((q = (Namep) cp->datap) && q->vstg == STGARG) {
 708:         q->vdcldone = YES;
 709:         namestab(q);
 710:       }
 711:       for (p = hashtab ; p<lasthash ; ++p) if(q = p->varp) {
 712:     if (q->vtype == TYUNKNOWN || q->vtype == TYERROR)
 713:       continue;
 714:     qstg = q->vstg;
 715:     qclass = q->vclass;
 716:     q->vdcldone = YES;
 717:     if ( ONEOF(qclass, M(CLVAR)|M(CLPARAM)|M(CLPROC)) ) {
 718:       if (! ONEOF(qstg,M(STGCOMMON)|M(STGARG) ) )
 719:         namestab(q);
 720:     }
 721:       }
 722:     }
 723: #endif
 724: 
 725:   close(vdatafile);
 726:   close(vchkfile);
 727:   unlink(vdatafname);
 728:   unlink(vchkfname);
 729:   vdatahwm = 0;
 730: }
 731: 
 732: 
 733: 
 734: donmlist()
 735: {
 736: register struct Hashentry *p;
 737: register Namep q;
 738: 
 739: pruse(asmfile, USEINIT);
 740: 
 741: for(p=hashtab; p<lasthash; ++p)
 742:     if( (q = p->varp) && q->vclass==CLNAMELIST)
 743:         namelist(q);
 744: }
 745: 
 746: 
 747: doext()
 748: {
 749: struct Extsym *p;
 750: 
 751: for(p = extsymtab ; p<nextext ; ++p)
 752:     prext(p);
 753: }
 754: 
 755: 
 756: 
 757: 
 758: ftnint iarrlen(q)
 759: register Namep q;
 760: {
 761: ftnint leng;
 762: 
 763: leng = typesize[q->vtype];
 764: if(leng <= 0)
 765:     return(-1);
 766: if(q->vdim)
 767:     if( ISICON(q->vdim->nelt) )
 768:         leng *= q->vdim->nelt->constblock.const.ci;
 769:     else    return(-1);
 770: if(q->vleng)
 771:     if( ISICON(q->vleng) )
 772:         leng *= q->vleng->constblock.const.ci;
 773:     else    return(-1);
 774: return(leng);
 775: }
 776: 
 777: /* This routine creates a static block representing the namelist.
 778:    An equivalent declaration of the structure produced is:
 779: 	struct namelist
 780: 		{
 781: 		char namelistname[16];
 782: 		struct namelistentry
 783: 			{
 784: 			char varname[16]; #  16 plus null padding -> 20
 785: 			char *varaddr;
 786: 			short int type;
 787: 			short int len;	# length of type
 788: 			struct dimensions *dimp; # null means scalar
 789: 			} names[];
 790: 		};
 791: 
 792: 	struct dimensions
 793: 		{
 794: 		int numberofdimensions;
 795: 		int numberofelements
 796: 		int baseoffset;
 797: 		int span[numberofdimensions];
 798: 		};
 799:    where the namelistentry list terminates with a null varname
 800:    If dimp is not null, then the corner element of the array is at
 801:    varaddr.  However,  the element with subscripts (i1,...,in) is at
 802:    varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...)
 803: */
 804: 
 805: namelist(np)
 806: Namep np;
 807: {
 808: register chainp q;
 809: register Namep v;
 810: register struct Dimblock *dp;
 811: char *memname();
 812: int type, dimno, dimoffset;
 813: flag bad;
 814: 
 815: 
 816: preven(ALILONG);
 817: fprintf(asmfile, LABELFMT, memname(STGINIT, np->vardesc.varno));
 818: putstr(asmfile, varstr(VL, np->varname), 16);
 819: dimno = ++lastvarno;
 820: dimoffset = 0;
 821: bad = NO;
 822: 
 823: for(q = np->varxptr.namelist ; q ; q = q->nextp)
 824:     {
 825:     vardcl( v = (Namep) (q->datap) );
 826:     type = v->vtype;
 827:     if( ONEOF(v->vstg, MSKSTATIC) )
 828:         {
 829:         preven(ALILONG);
 830:         putstr(asmfile, varstr(VL,v->varname), 16);
 831:         praddr(asmfile, v->vstg, v->vardesc.varno, v->voffset);
 832:         prconi(asmfile, TYSHORT, type );
 833:         prconi(asmfile, TYSHORT,
 834:             type==TYCHAR ?
 835:                 (v->vleng->constblock.const.ci) :
 836:                     (ftnint) typesize[type]);
 837:         if(v->vdim)
 838:             {
 839:             praddr(asmfile, STGINIT, dimno, (ftnint)dimoffset);
 840:             dimoffset += (3 + v->vdim->ndim) * SZINT;
 841:             }
 842:         else
 843:             praddr(asmfile, STGNULL,0,(ftnint) 0);
 844:         }
 845:     else
 846:         {
 847:         dclerr("may not appear in namelist", v);
 848:         bad = YES;
 849:         }
 850:     }
 851: 
 852: if(bad)
 853:     return;
 854: 
 855: putstr(asmfile, "", 16);
 856: 
 857: if(dimoffset > 0)
 858:     {
 859:     fprintf(asmfile, LABELFMT, memname(STGINIT,dimno));
 860:     for(q = np->varxptr.namelist ; q ; q = q->nextp)
 861:         if(dp = q->datap->nameblock.vdim)
 862:             {
 863:             int i;
 864:             prconi(asmfile, TYINT, (ftnint) (dp->ndim) );
 865:             prconi(asmfile, TYINT,
 866:                 (ftnint) (dp->nelt->constblock.const.ci) );
 867:             prconi(asmfile, TYINT,
 868:                 (ftnint) (dp->baseoffset->constblock.const.ci));
 869:             for(i=0; i<dp->ndim ; ++i)
 870:                 prconi(asmfile, TYINT,
 871:                     dp->dims[i].dimsize->constblock.const.ci);
 872:             }
 873:     }
 874: 
 875: }
 876: 
 877: LOCAL docommon()
 878: {
 879: register struct Extsym *p;
 880: register chainp q;
 881: struct Dimblock *t;
 882: expptr neltp;
 883: register Namep v;
 884: ftnint size;
 885: int type;
 886: 
 887: for(p = extsymtab ; p<nextext ; ++p)
 888:     if(p->extstg==STGCOMMON)
 889:         {
 890: #ifdef SDB
 891:         if(sdbflag)
 892:             prstab(varstr(XL,p->extname), N_BCOMM, 0, 0);
 893: #endif
 894:         for(q = p->extp ; q ; q = q->nextp)
 895:             {
 896:             v = (Namep) (q->datap);
 897:             if(v->vdcldone == NO)
 898:                 vardcl(v);
 899:             type = v->vtype;
 900:             if(p->extleng % typealign[type] != 0)
 901:                 {
 902:                 dclerr("common alignment", v);
 903:                 p->extleng = roundup(p->extleng, typealign[type]);
 904:                 }
 905:             v->voffset = p->extleng;
 906:             v->vardesc.varno = p - extsymtab;
 907:             if(type == TYCHAR)
 908:                 size = v->vleng->constblock.const.ci;
 909:             else    size = typesize[type];
 910:             if(t = v->vdim)
 911:                 if( (neltp = t->nelt) && ISCONST(neltp) )
 912:                     size *= neltp->constblock.const.ci;
 913:                 else
 914:                     dclerr("adjustable array in common", v);
 915:             p->extleng += size;
 916: #ifdef SDB
 917:             if(sdbflag)
 918:                 {
 919:                 namestab(v);
 920:                 }
 921: #endif
 922:             }
 923: 
 924:         frchain( &(p->extp) );
 925: #ifdef SDB
 926:         if(sdbflag)
 927:             prstab(varstr(XL,p->extname), N_ECOMM, 0, 0);
 928: #endif
 929:         }
 930: }
 931: 
 932: 
 933: 
 934: 
 935: 
 936: LOCAL docomleng()
 937: {
 938: register struct Extsym *p;
 939: 
 940: for(p = extsymtab ; p < nextext ; ++p)
 941:     if(p->extstg == STGCOMMON)
 942:         {
 943:         if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
 944:             && !eqn(XL,"_BLNK__ ",p->extname) )
 945:             warn1("incompatible lengths for common block %s",
 946:                 nounder(XL, p->extname) );
 947:         if(p->maxleng < p->extleng)
 948:             p->maxleng = p->extleng;
 949:         p->extleng = 0;
 950:     }
 951: }
 952: 
 953: 
 954: 
 955: 
 956: /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
 957: 
 958: /*  frees a temporary block  */
 959: 
 960: frtemp(p)
 961: Tempp p;
 962: {
 963: Addrp t;
 964: 
 965: if (optimflag)
 966:     {
 967:     if (p->tag != TTEMP)
 968:         badtag ("frtemp",p->tag);
 969:     t = p->memalloc;
 970:     }
 971: else
 972:     t = (Addrp) p;
 973: 
 974: /* restore clobbered character string lengths */
 975: if(t->vtype==TYCHAR && t->varleng!=0)
 976:     {
 977:     frexpr(t->vleng);
 978:     t->vleng = ICON(t->varleng);
 979:     }
 980: 
 981: /* put block on chain of temps to be reclaimed */
 982: holdtemps = mkchain(t, holdtemps);
 983: }
 984: 
 985: 
 986: 
 987: /* allocate an automatic variable slot */
 988: 
 989: Addrp autovar(nelt, t, lengp)
 990: register int nelt, t;
 991: expptr lengp;
 992: {
 993: ftnint leng;
 994: register Addrp q;
 995: 
 996: if(lengp)
 997:     if( ISICON(lengp) )
 998:         leng = lengp->constblock.const.ci;
 999:     else    {
1000:         fatal("automatic variable of nonconstant length");
1001:         }
1002: else
1003:     leng = typesize[t];
1004: autoleng = roundup( autoleng, typealign[t]);
1005: 
1006: q = ALLOC(Addrblock);
1007: q->tag = TADDR;
1008: q->vtype = t;
1009: if(lengp)
1010:     {
1011:     q->vleng = ICON(leng);
1012:     q->varleng = leng;
1013:     }
1014: q->vstg = STGAUTO;
1015: q->memno = newlabel();
1016: q->ntempelt = nelt;
1017: #if TARGET==PDP11 || TARGET==VAX
1018:     /* stack grows downward */
1019:     autoleng += nelt*leng;
1020:     q->memoffset = ICON( - autoleng );
1021: #else
1022:     q->memoffset = ICON( autoleng );
1023:     autoleng += nelt*leng;
1024: #endif
1025: 
1026: return(q);
1027: }
1028: 
1029: 
1030: 
1031: /*
1032:  *  create a temporary block (TTEMP) when optimizing,
1033:  *  an ordinary TADDR block when not optimizing
1034:  */
1035: 
1036: Tempp mktmpn(nelt, type, lengp)
1037: int nelt;
1038: register int type;
1039: expptr lengp;
1040: {
1041: ftnint leng;
1042: chainp p, oldp;
1043: register Tempp q;
1044: Addrp altemp;
1045: 
1046: if (! optimflag)
1047:     return ( (Tempp) mkaltmpn(nelt,type,lengp) );
1048: if(type==TYUNKNOWN || type==TYERROR)
1049:     badtype("mktmpn", type);
1050: 
1051: if(type==TYCHAR)
1052:     if( ISICON(lengp) )
1053:         leng = lengp->constblock.const.ci;
1054:     else    {
1055:         err("adjustable length");
1056:         return( (Tempp) errnode() );
1057:         }
1058: else
1059:     leng = typesize[type];
1060: 
1061: q = ALLOC(Tempblock);
1062: q->tag = TTEMP;
1063: q->vtype = type;
1064: if(type == TYCHAR)
1065:     {
1066:     q->vleng = ICON(leng);
1067:     q->varleng = leng;
1068:     }
1069: 
1070: altemp = ALLOC(Addrblock);
1071: altemp->tag = TADDR;
1072: altemp->vstg = STGUNKNOWN;
1073: q->memalloc = altemp;
1074: 
1075: q->ntempelt = nelt;
1076: q->istemp = YES;
1077: return(q);
1078: }
1079: 
1080: 
1081: 
1082: Addrp mktemp(type, lengp)
1083: int type;
1084: expptr lengp;
1085: {
1086: return( (Addrp) mktmpn(1,type,lengp) );
1087: }
1088: 
1089: 
1090: 
1091: /*  allocate a temporary location for the given temporary block;
1092:     if already allocated, return its location  */
1093: 
1094: Addrp altmpn(tp)
1095: Tempp tp;
1096: 
1097: {
1098: Addrp t, q;
1099: 
1100: if (tp->tag != TTEMP)
1101:     badtag ("altmpn",tp->tag);
1102: 
1103: t = tp->memalloc;
1104: if (t->vstg != STGUNKNOWN)
1105:     {
1106:     if (tp->vtype == TYCHAR)
1107:         {
1108:         /*
1109: 		 * Unformatted I/O parameters are treated like character
1110: 		 *	strings (sigh) -- propagate type and length.
1111: 		 */
1112:         t = (Addrp) cpexpr(t);
1113:         t->vtype = tp->vtype;
1114:         t->vleng = tp->vleng;
1115:         t->varleng = tp->varleng;
1116:         }
1117:     return (t);
1118:     }
1119: 
1120: q = mkaltmpn (tp->ntempelt, tp->vtype, tp->vleng);
1121: cpn (sizeof(struct Addrblock), (char*)q, (char*)t);
1122: free ( (charptr) q);
1123: return(t);
1124: }
1125: 
1126: 
1127: 
1128: /*  create and allocate space immediately for a temporary  */
1129: 
1130: Addrp mkaltemp(type,lengp)
1131: int type;
1132: expptr lengp;
1133: {
1134: return (mkaltmpn(1,type,lengp));
1135: }
1136: 
1137: 
1138: 
1139: Addrp mkaltmpn(nelt,type,lengp)
1140: int nelt;
1141: register int type;
1142: expptr lengp;
1143: {
1144: ftnint leng;
1145: chainp p, oldp;
1146: register Addrp q;
1147: 
1148: if(type==TYUNKNOWN || type==TYERROR)
1149:     badtype("mkaltmpn", type);
1150: 
1151: if(type==TYCHAR)
1152:     if( ISICON(lengp) )
1153:         leng = lengp->constblock.const.ci;
1154:     else    {
1155:         err("adjustable length");
1156:         return( (Addrp) errnode() );
1157:         }
1158: 
1159: /*
1160:  * if a temporary of appropriate shape is on the templist,
1161:  * remove it from the list and return it
1162:  */
1163: 
1164: #ifdef notdef
1165: /*
1166:  * This code is broken until SKFRTEMP slots can be processed in putopt()
1167:  *	instead of in optimize() -- all kinds of things in putpcc.c can
1168:  *	bomb because of this.  Sigh.
1169:  */
1170: for(oldp=CHNULL, p=templist  ;  p  ;  oldp=p, p=p->nextp)
1171:     {
1172:     q = (Addrp) (p->datap);
1173:     if(q->vtype==type && q->ntempelt==nelt &&
1174:         (type!=TYCHAR || q->vleng->constblock.const.ci==leng) )
1175:         {
1176:         if(oldp)
1177:             oldp->nextp = p->nextp;
1178:         else
1179:             templist = p->nextp;
1180:         free( (charptr) p);
1181: 
1182:         if (debugflag[14])
1183:             fprintf(diagfile,"mkaltmpn reusing offset %d\n",
1184:                 q->memoffset->constblock.const.ci);
1185:         return(q);
1186:         }
1187:     }
1188: #endif notdef
1189: q = autovar(nelt, type, lengp);
1190: q->istemp = YES;
1191: 
1192: if (debugflag[14])
1193:     fprintf(diagfile,"mkaltmpn new offset %d\n",
1194:         q->memoffset->constblock.const.ci);
1195: return(q);
1196: }
1197: 
1198: 
1199: 
1200: /*  The following routine is a patch which is only needed because the	*/
1201: /*  code for processing actual arguments for calls does not allocate	*/
1202: /*  the temps it needs before optimization takes place.  A better	*/
1203: /*  solution is possible, but I do not have the time to implement it	*/
1204: /*  now.								*/
1205: /*									*/
1206: /*					Robert P. Corbett		*/
1207: 
1208: Addrp
1209: mkargtemp(type, lengp)
1210: int type;
1211: expptr lengp;
1212: {
1213:   ftnint leng;
1214:   chainp oldp, p;
1215:   Addrp q;
1216: 
1217:   if (type == TYUNKNOWN || type == TYERROR)
1218:     badtype("mkargtemp", type);
1219: 
1220:   if (type == TYCHAR)
1221:     {
1222:       if (ISICON(lengp))
1223:     leng = lengp->constblock.const.ci;
1224:       else
1225:     {
1226:       err("adjustable length");
1227:       return ((Addrp) errnode());
1228:     }
1229:     }
1230: 
1231:   oldp = CHNULL;
1232:   p = argtemplist;
1233: 
1234:   while (p)
1235:     {
1236:       q = (Addrp) (p->datap);
1237:       if (q->vtype == type
1238:       && (type != TYCHAR || q->vleng->constblock.const.ci == leng))
1239:     {
1240:       if (oldp)
1241:         oldp->nextp = p->nextp;
1242:       else
1243:         argtemplist = p->nextp;
1244: 
1245:       p->nextp = activearglist;
1246:       activearglist = p;
1247: 
1248:       return ((Addrp) cpexpr(q));
1249:     }
1250: 
1251:       oldp = p;
1252:       p = p->nextp;
1253:     }
1254: 
1255:   q = autovar(1, type, lengp);
1256:   activearglist = mkchain(q, activearglist);
1257:   return ((Addrp) cpexpr(q));
1258: }
1259: 
1260: /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
1261: 
1262: struct Extsym *comblock(len, s)
1263: register int len;
1264: register char *s;
1265: {
1266: struct Extsym *p;
1267: 
1268: if(len == 0)
1269:     {
1270:     s = BLANKCOMMON;
1271:     len = strlen(s);
1272:     }
1273: p = mkext( varunder(len, s) );
1274: if(p->extstg == STGUNKNOWN)
1275:     p->extstg = STGCOMMON;
1276: else if(p->extstg != STGCOMMON)
1277:     {
1278:     errstr("%s cannot be a common block name", s);
1279:     return(0);
1280:     }
1281: 
1282: return( p );
1283: }
1284: 
1285: 
1286: incomm(c, v)
1287: struct Extsym *c;
1288: Namep v;
1289: {
1290: if(v->vstg != STGUNKNOWN)
1291:     dclerr("incompatible common declaration", v);
1292: else
1293:     {
1294:     if(c == (struct Extsym *) 0)
1295:         return;     /* Illegal common block name upstream */
1296:     v->vstg = STGCOMMON;
1297:     c->extp = hookup(c->extp, mkchain(v,CHNULL) );
1298:     }
1299: }
1300: 
1301: 
1302: 
1303: 
1304: settype(v, type, length)
1305: register Namep  v;
1306: register int type;
1307: register int length;
1308: {
1309: if(type == TYUNKNOWN)
1310:     return;
1311: 
1312: if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
1313:     {
1314:     v->vtype = TYSUBR;
1315:     frexpr(v->vleng);
1316:     }
1317: else if(type < 0)   /* storage class set */
1318:     {
1319:     if(v->vstg == STGUNKNOWN)
1320:         v->vstg = - type;
1321:     else if(v->vstg != -type)
1322:         dclerr("incompatible storage declarations", v);
1323:     }
1324: else if(v->vtype == TYUNKNOWN)
1325:     {
1326:     if( (v->vtype = lengtype(type, length))==TYCHAR )
1327:         {
1328:         if(length >= 0)
1329:             v->vleng = ICON(length);
1330:         else if(!(v->vstg == STGARG || v->vclass == CLENTRY ||
1331:               (v->vclass == CLPROC && v->vprocclass == PTHISPROC)))
1332:             {
1333:             dclerr("illegal adjustable length character variable", v);
1334:             v->vleng = ICON(0);
1335:             }
1336:         }
1337:     }
1338: else if(v->vtype!=type || (type==TYCHAR && v->vleng->constblock.const.ci!=length) )
1339:     dclerr("incompatible type declarations", v);
1340: }
1341: 
1342: 
1343: 
1344: 
1345: 
1346: lengtype(type, length)
1347: register int type;
1348: register int length;
1349: {
1350: switch(type)
1351:     {
1352:     case TYREAL:
1353:         if(length == 8)
1354:             return(TYDREAL);
1355:         if(length == 4)
1356:             goto ret;
1357:         break;
1358: 
1359:     case TYCOMPLEX:
1360:         if(length == 16)
1361:             return(TYDCOMPLEX);
1362:         if(length == 8)
1363:             goto ret;
1364:         break;
1365: 
1366:     case TYSHORT:
1367:     case TYDREAL:
1368:     case TYDCOMPLEX:
1369:     case TYCHAR:
1370:     case TYUNKNOWN:
1371:     case TYSUBR:
1372:     case TYERROR:
1373:         goto ret;
1374: 
1375:     case TYLOGICAL:
1376:         if(length == typesize[TYLOGICAL])
1377:             goto ret;
1378:         break;
1379: 
1380:     case TYLONG:
1381:         if(length == 0)
1382:             return(tyint);
1383:         if(length == 2)
1384:             return(TYSHORT);
1385:         if(length == 4)
1386:             goto ret;
1387:         break;
1388:     default:
1389:         badtype("lengtype", type);
1390:     }
1391: 
1392: if(length != 0)
1393:     err("incompatible type-length combination");
1394: 
1395: ret:
1396:     return(type);
1397: }
1398: 
1399: 
1400: 
1401: 
1402: 
1403: setintr(v)
1404: register Namep  v;
1405: {
1406: register int k;
1407: 
1408: if(v->vstg == STGUNKNOWN)
1409:     v->vstg = STGINTR;
1410: else if(v->vstg!=STGINTR)
1411:     dclerr("incompatible use of intrinsic function", v);
1412: if(v->vclass==CLUNKNOWN)
1413:     v->vclass = CLPROC;
1414: if(v->vprocclass == PUNKNOWN)
1415:     v->vprocclass = PINTRINSIC;
1416: else if(v->vprocclass != PINTRINSIC)
1417:     dclerr("invalid intrinsic declaration", v);
1418: if(k = intrfunct(v->varname))
1419:     v->vardesc.varno = k;
1420: else
1421:     dclerr("unknown intrinsic function", v);
1422: }
1423: 
1424: 
1425: 
1426: setext(v)
1427: register Namep  v;
1428: {
1429: if(v->vclass == CLUNKNOWN)
1430:     v->vclass = CLPROC;
1431: else if(v->vclass != CLPROC)
1432:     dclerr("conflicting declarations", v);
1433: 
1434: if(v->vprocclass == PUNKNOWN)
1435:     v->vprocclass = PEXTERNAL;
1436: else if(v->vprocclass != PEXTERNAL)
1437:     dclerr("conflicting declarations", v);
1438: }
1439: 
1440: 
1441: 
1442: 
1443: /* create dimensions block for array variable */
1444: 
1445: setbound(v, nd, dims)
1446: register Namep  v;
1447: int nd;
1448: struct { expptr lb, ub; } dims[ ];
1449: {
1450: register expptr q, t;
1451: register struct Dimblock *p;
1452: int i;
1453: 
1454: if(v->vclass == CLUNKNOWN)
1455:     v->vclass = CLVAR;
1456: else if(v->vclass != CLVAR)
1457:     {
1458:     dclerr("only variables may be arrays", v);
1459:     return;
1460:     }
1461: if(v->vdim)
1462:     {
1463:     dclerr("redimensioned array", v);
1464:     return;
1465:     }
1466: 
1467: v->vdim = p = (struct Dimblock *)
1468:         ckalloc( sizeof(int) + (3+6*nd)*sizeof(expptr) );
1469: p->ndim = nd;
1470: p->nelt = ICON(1);
1471: 
1472: for(i=0 ; i<nd ; ++i)
1473:     {
1474: #ifdef SDB
1475:         if(sdbflag) {
1476: /* Save the bounds trees built up by the grammar routines for use in stabs */
1477: 
1478:         if(dims[i].lb == NULL) p->dims[i].lb=ICON(1);
1479:             else p->dims[i].lb= (expptr) cpexpr(dims[i].lb);
1480:                 if(ISCONST(p->dims[i].lb)) p->dims[i].lbaddr = (expptr) PNULL;
1481:                 else p->dims[i].lbaddr = (expptr) autovar(1, tyint, PNULL);
1482: 
1483:         if(dims[i].ub == NULL) p->dims[i].ub=ICON(1);
1484:             else p->dims[i].ub = (expptr) cpexpr(dims[i].ub);
1485:                 if(ISCONST(p->dims[i].ub)) p->dims[i].ubaddr = (expptr) PNULL;
1486:                 else p->dims[i].ubaddr = (expptr) autovar(1, tyint, PNULL);
1487:     }
1488: #endif
1489:     if( (q = dims[i].ub) == NULL)
1490:         {
1491:         if(i == nd-1)
1492:             {
1493:             frexpr(p->nelt);
1494:             p->nelt = NULL;
1495:             }
1496:         else
1497:             err("only last bound may be asterisk");
1498:         p->dims[i].dimsize = ICON(1);;
1499:         p->dims[i].dimexpr = NULL;
1500:         }
1501:     else
1502:         {
1503:         if(dims[i].lb)
1504:             {
1505:             q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
1506:             q = mkexpr(OPPLUS, q, ICON(1) );
1507:             }
1508:         if( ISCONST(q) )
1509:             {
1510:             if (!ISINT(q->headblock.vtype)) {
1511:                dclerr("dimension bounds must be integer expression", v);
1512:                frexpr(q);
1513:                q = ICON(0);
1514:                }
1515:             if ( q->constblock.const.ci <= 0)
1516:                {
1517:                dclerr("array bounds out of sequence", v);
1518:                frexpr(q);
1519:                q = ICON(0);
1520:                }
1521:             p->dims[i].dimsize = q;
1522:             p->dims[i].dimexpr = (expptr) PNULL;
1523:             }
1524:         else    {
1525:             p->dims[i].dimsize = (expptr) autovar(1, tyint, PNULL);
1526:             p->dims[i].dimexpr = q;
1527:             }
1528:         if(p->nelt)
1529:             p->nelt = mkexpr(OPSTAR, p->nelt,
1530:                     cpexpr(p->dims[i].dimsize) );
1531:         }
1532:     }
1533: 
1534: q = dims[nd-1].lb;
1535: if(q == NULL)
1536:     q = ICON(1);
1537: 
1538: for(i = nd-2 ; i>=0 ; --i)
1539:     {
1540:     t = dims[i].lb;
1541:     if(t == NULL)
1542:         t = ICON(1);
1543:     if(p->dims[i].dimsize)
1544:         q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
1545:     }
1546: 
1547: if( ISCONST(q) )
1548:     {
1549:     p->baseoffset = q;
1550:     p->basexpr = NULL;
1551:     }
1552: else
1553:     {
1554:     p->baseoffset = (expptr) autovar(1, tyint, PNULL);
1555:     p->basexpr = q;
1556:     }
1557: }
1558: 
1559: 
1560: 
1561: /*
1562:  * Check the dimensions of q to ensure that they are appropriately defined.
1563:  */
1564: LOCAL chkdim(q)
1565: register Namep q;
1566: {
1567:   register struct Dimblock *p;
1568:   register int i;
1569:   expptr e;
1570: 
1571:   if (q == NULL)
1572:     return;
1573:   if (q->vclass != CLVAR)
1574:     return;
1575:   if (q->vdim == NULL)
1576:     return;
1577:   p = q->vdim;
1578:   for (i = 0; i < p->ndim; ++i)
1579:     {
1580: #ifdef SDB
1581:       if (sdbflag)
1582:     {
1583:       if (e = p->dims[i].lb)
1584:         chkdime(e, q);
1585:       if (e = p->dims[i].ub)
1586:         chkdime(e, q);
1587:     }
1588:       else
1589: #endif SDB
1590:       if (e = p->dims[i].dimexpr)
1591:     chkdime(e, q);
1592:     }
1593: }
1594: 
1595: 
1596: 
1597: /*
1598:  * The actual checking for chkdim() -- examines each expression.
1599:  */
1600: LOCAL chkdime(expr, q)
1601: expptr expr;
1602: Namep q;
1603: {
1604:   register expptr e;
1605: 
1606:   e = fixtype(cpexpr(expr));
1607:   if (!ISINT(e->exprblock.vtype))
1608:     dclerr("non-integer dimension", q);
1609:   else if (!safedim(e))
1610:     dclerr("undefined dimension", q);
1611:   frexpr(e);
1612:   return;
1613: }
1614: 
1615: 
1616: 
1617: /*
1618:  * A recursive routine to find undefined variables in dimension expressions.
1619:  */
1620: LOCAL safedim(e)
1621: expptr e;
1622: {
1623:   chainp cp;
1624: 
1625:   if (e == NULL)
1626:     return 1;
1627:   switch (e->tag)
1628:     {
1629:       case TEXPR:
1630:     if (e->exprblock.opcode == OPCALL || e->exprblock.opcode == OPCCALL)
1631:       return 0;
1632:     return safedim(e->exprblock.leftp) && safedim(e->exprblock.rightp);
1633:       case TADDR:
1634:     switch (e->addrblock.vstg)
1635:       {
1636:         case STGCOMMON:
1637:         case STGARG:
1638:         case STGCONST:
1639:         case STGEQUIV:
1640:           if (e->addrblock.isarray)
1641:         return 0;
1642:           return safedim(e->addrblock.memoffset);
1643:         default:
1644:           return 0;
1645:       }
1646:       case TCONST:
1647:       case TTEMP:
1648:     return 1;
1649:     }
1650:   return 0;
1651: }
1652: 
1653: 
1654: 
1655: LOCAL enlist(size, np, ep)
1656: ftnint size;
1657: Namep np;
1658: struct Equivblock *ep;
1659: {
1660:   register sizelist *sp;
1661:   register sizelist *t;
1662:   register varlist *p;
1663: 
1664:   sp = varsizes;
1665: 
1666:   if (sp == NULL)
1667:     {
1668:       sp = ALLOC(SizeList);
1669:       sp->size = size;
1670:       varsizes = sp;
1671:     }
1672:   else
1673:     {
1674:       while (sp->size != size)
1675:     {
1676:       if (sp->next != NULL && sp->next->size <= size)
1677:         sp = sp->next;
1678:       else
1679:         {
1680:           t = sp;
1681:           sp = ALLOC(SizeList);
1682:           sp->size = size;
1683:           sp->next = t->next;
1684:           t->next = sp;
1685:         }
1686:     }
1687:     }
1688: 
1689:   p = ALLOC(VarList);
1690:   p->next = sp->vars;
1691:   p->np = np;
1692:   p->ep = ep;
1693: 
1694:   sp->vars = p;
1695: 
1696:   return;
1697: }
1698: 
1699: 
1700: 
1701: outlocvars()
1702: {
1703: 
1704:   register varlist *first, *last;
1705:   register varlist *vp, *t;
1706:   register sizelist *sp, *sp1;
1707:   register Namep np;
1708:   register struct Equivblock *ep;
1709:   register int i;
1710:   register int alt;
1711:   register int type;
1712:   char sname[100];
1713:   char setbuff[100];
1714: 
1715:   sp = varsizes;
1716:   if (sp == NULL)
1717:     return;
1718: 
1719:   vp = sp->vars;
1720:   if (vp->np != NULL)
1721:     {
1722:       np = vp->np;
1723:       sprintf(setbuff, "\t.set\tv.%d,v.%d\n", bsslabel,
1724:           np->vardesc.varno);
1725:     }
1726:   else
1727:     {
1728:       i = vp->ep - eqvclass;
1729:       sprintf(setbuff, "\t.set\tv.%d,q.%d\n", bsslabel, i + eqvstart);
1730:     }
1731: 
1732:   first = last = NULL;
1733:   alt = NO;
1734: 
1735:   while (sp != NULL)
1736:     {
1737:       vp = sp->vars;
1738:       while (vp != NULL)
1739:     {
1740:       t = vp->next;
1741:       if (alt == YES)
1742:         {
1743:           alt = NO;
1744:           vp->next = first;
1745:           first = vp;
1746:         }
1747:       else
1748:         {
1749:           alt = YES;
1750:           if (last != NULL)
1751:             last->next = vp;
1752:           else
1753:         first = vp;
1754:           vp->next = NULL;
1755:           last = vp;
1756:         }
1757:       vp = t;
1758:     }
1759:       sp1 = sp;
1760:       sp = sp->next;
1761:       free((char *) sp1);
1762:     }
1763: 
1764:   vp = first;
1765:   while(vp != NULL)
1766:     {
1767:       if (vp->np != NULL)
1768:     {
1769:       np = vp->np;
1770:       sprintf(sname, "v.%d", np->vardesc.varno);
1771:       if (np->init)
1772:         prlocdata(sname, np->varsize, np->vtype, np->initoffset,
1773:               &(np->inlcomm));
1774:       else
1775:         {
1776:           pralign(typealign[np->vtype]);
1777:           fprintf(initfile, "%s:\n", sname);
1778:           prspace(np->varsize);
1779:         }
1780:       np->inlcomm = NO;
1781:     }
1782:       else
1783:     {
1784:       ep = vp->ep;
1785:       i = ep - eqvclass;
1786:       if (ep->eqvleng >= 8)
1787:         type = TYDREAL;
1788:       else if (ep->eqvleng >= 4)
1789:         type = TYLONG;
1790:       else if (ep->eqvleng >= 2)
1791:         type = TYSHORT;
1792:       else
1793:         type = TYCHAR;
1794:       sprintf(sname, "q.%d", i + eqvstart);
1795:       if (ep->init)
1796:         prlocdata(sname, ep->eqvleng, type, ep->initoffset,
1797:               &(ep->inlcomm));
1798:       else
1799:         {
1800:           pralign(typealign[type]);
1801:           fprintf(initfile, "%s:\n", sname);
1802:           prspace(ep->eqvleng);
1803:         }
1804:       ep->inlcomm = NO;
1805:     }
1806:       t = vp;
1807:       vp = vp->next;
1808:       free((char *) t);
1809:     }
1810:   fprintf(initfile, "%s\n", setbuff);
1811:   return;
1812: }

Defined functions

Defined variables

Defined struct's

Defined typedef's