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