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