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.8 (Berkeley) 01/03/88"; 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.constant.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.constant.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.constant.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.constant.ci; 769 else return(-1); 770 if(q->vleng) 771 if( ISICON(q->vleng) ) 772 leng *= q->vleng->constblock.constant.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.constant.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.constant.ci) ); 867 prconi(asmfile, TYINT, 868 (ftnint) (dp->baseoffset->constblock.constant.ci)); 869 for(i=0; i<dp->ndim ; ++i) 870 prconi(asmfile, TYINT, 871 dp->dims[i].dimsize->constblock.constant.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.constant.ci; 909 else size = typesize[type]; 910 if(t = v->vdim) 911 if( (neltp = t->nelt) && ISCONST(neltp) ) 912 size *= neltp->constblock.constant.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.constant.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.constant.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.constant.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.constant.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.constant.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.constant.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.constant.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.constant.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.constant.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.constant.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 } 1813