1/* Id: proc.c,v 1.14 2008/12/24 17:40:41 sgk Exp */ 2/* $NetBSD$ */ 3/* 4 * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved. 5 * 6 * Redistribution and use in source and binary forms, with or without 7 * modification, are permitted provided that the following conditions 8 * are met: 9 * 10 * Redistributions of source code and documentation must retain the above 11 * copyright notice, this list of conditions and the following disclaimer. 12 * Redistributions in binary form must reproduce the above copyright 13 * notice, this list of conditionsand the following disclaimer in the 14 * documentation and/or other materials provided with the distribution. 15 * All advertising materials mentioning features or use of this software 16 * must display the following acknowledgement: 17 * This product includes software developed or owned by Caldera 18 * International, Inc. 19 * Neither the name of Caldera International, Inc. nor the names of other 20 * contributors may be used to endorse or promote products derived from 21 * this software without specific prior written permission. 22 * 23 * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA 24 * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR 25 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 26 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 * DISCLAIMED. IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE 28 * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 29 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 30 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 31 * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT, 32 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 33 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 * POSSIBILITY OF SUCH DAMAGE. 35 */ 36#include <string.h> 37 38#include "defines.h" 39#include "defs.h" 40 41LOCAL void doentry(struct entrypoint *ep); 42LOCAL void retval(int t); 43LOCAL void epicode(void); 44LOCAL void procode(void); 45LOCAL int nextarg(int); 46LOCAL int nextarg(int); 47LOCAL void dobss(void); 48LOCAL void docommon(void); 49LOCAL void docomleng(void); 50 51 52/* start a new procedure */ 53 54void 55newproc() 56{ 57 if(parstate != OUTSIDE) { 58 execerr("missing end statement"); 59 endproc(); 60 } 61 62 parstate = INSIDE; 63 procclass = CLMAIN; /* default */ 64} 65 66 67 68/* end of procedure. generate variables, epilogs, and prologs */ 69 70void 71endproc() 72{ 73 struct labelblock *lp; 74 75 if(parstate < INDATA) 76 enddcl(); 77 if(ctlstack >= ctls) 78 err("DO loop or BLOCK IF not closed"); 79 for(lp = labeltab ; lp < labtabend ; ++lp) 80 if(lp->stateno!=0 && lp->labdefined==NO) 81 err1("missing statement number %s", 82 convic(lp->stateno) ); 83 84 epicode(); 85 procode(); 86 dobss(); 87 prdbginfo(); 88 89 putbracket(); 90 91 procinit(); /* clean up for next procedure */ 92} 93 94 95 96/* 97 * End of declaration section of procedure. Allocate storage. 98 */ 99void 100enddcl() 101{ 102 chainp p; 103 104 parstate = INEXEC; 105 docommon(); 106 doequiv(); 107 docomleng(); 108 for(p = entries ; p ; p = p->entrypoint.nextp) 109 doentry(&p->entrypoint); 110} 111 112/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */ 113 114/* 115 * Called when a PROGRAM or BLOCK DATA statement is found, or if a statement 116 * is encountered outside of any block. 117 */ 118void 119startproc(struct extsym *progname, int class) 120{ 121 chainp p; 122 123 p = ALLOC(entrypoint); 124 if(class == CLMAIN) { 125 puthead("MAIN__"); 126 newentry( mkname(5, "MAIN_") ); 127 } 128 p->entrypoint.entryname = progname; 129 p->entrypoint.entrylabel = newlabel(); 130 entries = p; 131 132 procclass = class; 133 retlabel = newlabel(); 134 if (!quietflag) { 135 fprintf(diagfile, " %s", 136 (class==CLMAIN ? "MAIN" : "BLOCK DATA") ); 137 if (progname) 138 fprintf(diagfile, " %s", 139 nounder(XL, procname = progname->extname)); 140 fprintf(diagfile, ":\n"); 141 } 142} 143 144/* subroutine or function statement */ 145 146struct extsym * 147newentry(struct bigblock *v) 148{ 149 struct extsym *p; 150 151 p = mkext( varunder(VL, v->b_name.varname) ); 152 153 if (p==NULL || p->extinit || 154 !ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT))) { 155 if(p == 0) 156 dclerr("invalid entry name", v); 157 else 158 dclerr("external name already used", v); 159 return(0); 160 } 161 v->vstg = STGAUTO; 162 v->b_name.vprocclass = PTHISPROC; 163 v->vclass = CLPROC; 164 p->extstg = STGEXT; 165 p->extinit = YES; 166 return(p); 167} 168 169/* 170 * Called if a SUBROUTINE, FUNCTION or ENTRY statement is found. 171 */ 172void 173entrypt(int class, int type, ftnint length, struct extsym *entry, chainp args) 174{ 175 struct bigblock *q; 176 chainp p; 177 178 if(class != CLENTRY) 179 puthead( varstr(XL, procname = entry->extname) ); 180 if (!quietflag) { 181 if (class == CLENTRY) 182 fprintf(diagfile, " entry "); 183 fprintf(diagfile, " %s:\n", nounder(XL, entry->extname)); 184 } 185 q = mkname(VL, nounder(XL,entry->extname) ); 186 187 if( (type = lengtype(type, (int) length)) != TYCHAR) 188 length = 0; 189 190 if(class == CLPROC) { 191 procclass = CLPROC; 192 proctype = type; 193 procleng = length; 194 195 retlabel = newlabel(); 196 if(type == TYSUBR) 197 ret0label = newlabel(); 198 } 199 200 p = ALLOC(entrypoint); 201 entries = hookup(entries, p); 202 p->entrypoint.entryname = entry; 203 p->entrypoint.arglist = args; 204 p->entrypoint.entrylabel = newlabel(); 205 p->entrypoint.enamep = q; 206 207 if(class == CLENTRY) { 208 class = CLPROC; 209 if(proctype == TYSUBR) 210 type = TYSUBR; 211 } 212 213 q->vclass = class; 214 q->b_name.vprocclass = PTHISPROC; 215 settype(q, type, (int) length); 216 /* hold all initial entry points till end of declarations */ 217 if(parstate >= INDATA) 218 doentry(&p->entrypoint); 219} 220 221/* generate epilogs */ 222 223int multitypes = 0; /* XXX */ 224 225LOCAL void 226epicode() 227{ 228 int i; 229 230 if(procclass==CLPROC) { 231 if(proctype==TYSUBR) { 232 putlabel(ret0label); 233 if(substars) 234 putforce(TYINT, MKICON(0) ); 235 putlabel(retlabel); 236 goret(TYSUBR); 237 } else { 238 putlabel(retlabel); 239 if(multitypes) { 240 typeaddr = autovar(1, TYADDR, NULL); 241 putbranch( cpexpr(typeaddr) ); 242 for(i = 0; i < NTYPES ; ++i) { 243 if(rtvlabel[i] != 0) { 244 putlabel(rtvlabel[i]); 245 retval(i); 246 } 247 } 248 } else 249 retval(proctype); 250 } 251 } else if(procclass != CLBLOCK) { 252 putlabel(retlabel); 253 goret(TYSUBR); 254 } 255} 256 257 258/* generate code to return value of type t */ 259 260LOCAL void 261retval(t) 262register int t; 263{ 264register struct bigblock *p; 265 266switch(t) 267 { 268 case TYCHAR: 269 case TYCOMPLEX: 270 case TYDCOMPLEX: 271 break; 272 273 case TYLOGICAL: 274 t = tylogical; 275 case TYADDR: 276 case TYSHORT: 277 case TYLONG: 278 p = cpexpr(retslot); 279 p->vtype = t; 280 putforce(t, p); 281 break; 282 283 case TYREAL: 284 case TYDREAL: 285 p = cpexpr(retslot); 286 p->vtype = t; 287 putforce(t, p); 288 break; 289 290 default: 291 fatal1("retval: impossible type %d", t); 292 } 293goret(t); 294} 295 296 297/* Allocate extra argument array if needed. Generate prologs. */ 298 299LOCAL void 300procode() 301{ 302register chainp p; 303struct bigblock *argvec; 304 305 if(lastargslot>0 && nentry>1) 306 argvec = autovar(lastargslot/FSZADDR, TYADDR, NULL); 307 else 308 argvec = NULL; 309 310 for(p = entries ; p ; p = p->entrypoint.nextp) 311 prolog(&p->entrypoint, argvec); 312 313 putrbrack(procno); 314 315 prendproc(); 316} 317 318/* 319 manipulate argument lists (allocate argument slot positions) 320 * keep track of return types and labels 321 */ 322LOCAL void 323doentry(struct entrypoint *ep) 324{ 325 int type; 326 struct bigblock *np, *q; 327 chainp p; 328 329 ++nentry; 330 if(procclass == CLMAIN) { 331 putlabel(ep->entrylabel); 332 return; 333 } else if(procclass == CLBLOCK) 334 return; 335 336 impldcl(np = mkname(VL, nounder(XL, ep->entryname->extname))); 337 type = np->vtype; 338 if(proctype == TYUNKNOWN) 339 if( (proctype = type) == TYCHAR) 340 procleng = (np->vleng ? np->vleng->b_const.fconst.ci : (ftnint) 0); 341 342 if(proctype == TYCHAR) { 343 if(type != TYCHAR) 344 err("noncharacter entry of character function"); 345 else if( (np->vleng ? np->vleng->b_const.fconst.ci : (ftnint) 0) != procleng) 346 err("mismatched character entry lengths"); 347 } else if(type == TYCHAR) 348 err("character entry of noncharacter function"); 349 else if(type != proctype) 350 multitype = YES; 351 if(rtvlabel[type] == 0) 352 rtvlabel[type] = newlabel(); 353 ep->typelabel = rtvlabel[type]; 354 355 if(type == TYCHAR) { 356 if(chslot < 0) { 357 chslot = nextarg(TYADDR); 358 chlgslot = nextarg(TYLENG); 359 } 360 np->vstg = STGARG; 361 np->b_name.vardesc.varno = chslot; 362 if(procleng == 0) 363 np->vleng = mkarg(TYLENG, chlgslot); 364 } else if( ISCOMPLEX(type) ) { 365 np->vstg = STGARG; 366 if(cxslot < 0) 367 cxslot = nextarg(TYADDR); 368 np->b_name.vardesc.varno = cxslot; 369 } else if(type != TYSUBR) { 370 if(nentry == 1) 371 retslot = autovar(1, TYDREAL, NULL); 372 np->vstg = STGAUTO; 373 np->b_name.voffset = retslot->b_addr.memoffset->b_const.fconst.ci; 374 } 375 376 for(p = ep->arglist ; p ; p = p->chain.nextp) 377 if(! ((q = p->chain.datap)->b_name.vdcldone) ) 378 q->b_name.vardesc.varno = nextarg(TYADDR); 379 380 for(p = ep->arglist ; p ; p = p->chain.nextp) 381 if(! ((q = p->chain.datap)->b_name.vdcldone) ) { 382 impldcl(q); 383 q->b_name.vdcldone = YES; 384 if(q->vtype == TYCHAR) { 385 if(q->vleng == NULL) /* character*(*) */ 386 q->vleng = mkarg(TYLENG, nextarg(TYLENG) ); 387 else if(nentry == 1) 388 nextarg(TYLENG); 389 } else if(q->vclass==CLPROC && nentry==1) 390 nextarg(TYLENG) ; 391 } 392 putlabel(ep->entrylabel); 393} 394 395 396 397LOCAL int 398nextarg(type) 399int type; 400{ 401int k; 402k = lastargslot; 403lastargslot += typesize[type]; 404return(k); 405} 406 407/* generate variable references */ 408 409LOCAL void 410dobss() 411{ 412register struct hashentry *p; 413register struct bigblock *q; 414register int i; 415int align; 416ftnint leng, iarrl; 417 418 setloc(UDATA); 419 420for(p = hashtab ; p<lasthash ; ++p) 421 if((q = p->varp)) 422 { 423 if( (q->vclass==CLUNKNOWN && q->vstg!=STGARG) || 424 (q->vclass==CLVAR && q->vstg==STGUNKNOWN) ) 425 warn1("local variable %s never used", varstr(VL,q->b_name.varname) ); 426 else if(q->vclass==CLVAR && q->vstg==STGBSS) 427 { 428 align = (q->vtype==TYCHAR ? ALILONG : typealign[q->vtype]); 429 if(bssleng % align != 0) 430 { 431 bssleng = roundup(bssleng, align); 432 preven(align); 433 } 434 prlocvar( memname(STGBSS, q->b_name.vardesc.varno), iarrl = iarrlen(q) ); 435 bssleng += iarrl; 436 } 437 else if(q->vclass==CLPROC && q->b_name.vprocclass==PEXTERNAL && q->vstg!=STGARG) 438 mkext(varunder(VL, q->b_name.varname)) ->extstg = STGEXT; 439 440 if(q->vclass==CLVAR && q->vstg!=STGARG) 441 { 442 if(q->b_name.vdim && !ISICON(q->b_name.vdim->nelt) ) 443 dclerr("adjustable dimension on non-argument", q); 444 if(q->vtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng))) 445 dclerr("adjustable leng on nonargument", q); 446 } 447 } 448 449for(i = 0 ; i < nequiv ; ++i) 450 if(eqvclass[i].eqvinit==NO && (leng = eqvclass[i].eqvleng)!=0 ) 451 { 452 bssleng = roundup(bssleng, ALIDOUBLE); 453 preven(ALIDOUBLE); 454 prlocvar( memname(STGEQUIV, i), leng); 455 bssleng += leng; 456 } 457} 458 459 460 461void 462doext() 463{ 464struct extsym *p; 465 466for(p = extsymtab ; p<nextext ; ++p) 467 prext( varstr(XL, p->extname), p->maxleng, p->extinit); 468} 469 470 471 472 473ftnint iarrlen(q) 474register struct bigblock *q; 475{ 476ftnint leng; 477 478leng = typesize[q->vtype]; 479if(leng <= 0) 480 return(-1); 481if(q->b_name.vdim) { 482 if( ISICON(q->b_name.vdim->nelt) ) 483 leng *= q->b_name.vdim->nelt->b_const.fconst.ci; 484 else return(-1); 485} 486if(q->vleng) { 487 if( ISICON(q->vleng) ) 488 leng *= q->vleng->b_const.fconst.ci; 489 else return(-1); 490} 491return(leng); 492} 493 494LOCAL void 495docommon() 496{ 497register struct extsym *p; 498register chainp q; 499struct dimblock *t; 500bigptr neltp; 501register struct bigblock *v; 502ftnint size; 503int type; 504 505for(p = extsymtab ; p<nextext ; ++p) 506 if(p->extstg==STGCOMMON) 507 { 508 for(q = p->extp ; q ; q = q->chain.nextp) 509 { 510 v = q->chain.datap; 511 if(v->b_name.vdcldone == NO) 512 vardcl(v); 513 type = v->vtype; 514 if(p->extleng % typealign[type] != 0) 515 { 516 dclerr("common alignment", v); 517 p->extleng = roundup(p->extleng, typealign[type]); 518 } 519 v->b_name.voffset = p->extleng; 520 v->b_name.vardesc.varno = p - extsymtab; 521 if(type == TYCHAR) 522 size = v->vleng->b_const.fconst.ci; 523 else size = typesize[type]; 524 if((t = v->b_name.vdim)) { 525 if( (neltp = t->nelt) && ISCONST(neltp) ) 526 size *= neltp->b_const.fconst.ci; 527 else 528 dclerr("adjustable array in common", v); 529 } 530 p->extleng += size; 531 } 532 533 frchain( &(p->extp) ); 534 } 535} 536 537 538 539 540 541LOCAL void 542docomleng() 543{ 544register struct extsym *p; 545 546for(p = extsymtab ; p < nextext ; ++p) 547 if(p->extstg == STGCOMMON) 548 { 549 if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng && 550 !eqn(XL,"_BLNK__ ",p->extname) ) 551 warn1("incompatible lengths for common block %s", 552 nounder(XL, p->extname) ); 553 if(p->maxleng < p->extleng) 554 p->maxleng = p->extleng; 555 p->extleng = 0; 556 } 557} 558 559 560 561 562/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */ 563void 564frtemp(p) 565struct bigblock *p; 566{ 567holdtemps = mkchain(p, holdtemps); 568} 569 570 571 572 573/* allocate an automatic variable slot */ 574 575struct bigblock * 576autovar(int nelt, int t, bigptr lengp) 577{ 578 ftnint leng = 0; 579 register struct bigblock *q; 580 581 if(t == TYCHAR) { 582 if( ISICON(lengp) ) 583 leng = lengp->b_const.fconst.ci; 584 else 585 fatal("automatic variable of nonconstant length"); 586 } else 587 leng = typesize[t]; 588 autoleng = roundup( autoleng, typealign[t]); 589 590 q = BALLO(); 591 q->tag = TADDR; 592 q->vtype = t; 593 if(t == TYCHAR) 594 q->vleng = MKICON(leng); 595 q->vstg = STGAUTO; 596 q->b_addr.ntempelt = nelt; 597#ifdef BACKAUTO 598 /* stack grows downward */ 599 autoleng += nelt*leng; 600 q->b_addr.memoffset = MKICON( - autoleng ); 601#else 602 q->b_addr.memoffset = MKICON( autoleng ); 603 autoleng += nelt*leng; 604#endif 605 606 return(q); 607} 608 609 610struct bigblock *mktmpn(nelt, type, lengp) 611int nelt; 612register int type; 613bigptr lengp; 614{ 615ftnint leng = 0; /* XXX gcc */ 616chainp p, oldp; 617register struct bigblock *q; 618 619if(type==TYUNKNOWN || type==TYERROR) 620 fatal1("mktmpn: invalid type %d", type); 621 622if(type==TYCHAR) { 623 if( ISICON(lengp) ) 624 leng = lengp->b_const.fconst.ci; 625 else { 626 err("adjustable length"); 627 return( errnode() ); 628 } 629} 630for(oldp = (chainp)&templist ; (p = oldp->chain.nextp) ; oldp = p) 631 { 632 q = p->chain.datap; 633 if(q->vtype==type && q->b_addr.ntempelt==nelt && 634 (type!=TYCHAR || q->vleng->b_const.fconst.ci==leng) ) 635 { 636 oldp->chain.nextp = p->chain.nextp; 637 ckfree(p); 638 return(q); 639 } 640 } 641q = autovar(nelt, type, lengp); 642q->b_addr.istemp = YES; 643return(q); 644} 645 646 647 648 649struct bigblock *fmktemp(type, lengp) 650int type; 651bigptr lengp; 652{ 653return( mktmpn(1,type,lengp) ); 654} 655 656/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */ 657 658struct extsym *comblock(len, s) 659register int len; 660register char *s; 661{ 662struct extsym *p; 663 664if(len == 0) 665 { 666 s = BLANKCOMMON; 667 len = strlen(s); 668 } 669p = mkext( varunder(len, s) ); 670if(p->extstg == STGUNKNOWN) 671 p->extstg = STGCOMMON; 672else if(p->extstg != STGCOMMON) 673 { 674 err1("%s cannot be a common block name", s); 675 return(0); 676 } 677 678return( p ); 679} 680 681void 682incomm(c, v) 683struct extsym *c; 684struct bigblock *v; 685{ 686if(v->vstg != STGUNKNOWN) 687 dclerr("incompatible common declaration", v); 688else 689 { 690 v->vstg = STGCOMMON; 691 c->extp = hookup(c->extp, mkchain(v,NULL) ); 692 } 693} 694 695 696 697void 698settype(v, type, length) 699register struct bigblock * v; 700register int type; 701register int length; 702{ 703if(type == TYUNKNOWN) 704 return; 705 706if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) 707 { 708 v->vtype = TYSUBR; 709 frexpr(v->vleng); 710 } 711else if(type < 0) /* storage class set */ 712 { 713 if(v->vstg == STGUNKNOWN) 714 v->vstg = - type; 715 else if(v->vstg != -type) 716 dclerr("incompatible storage declarations", v); 717 } 718else if(v->vtype == TYUNKNOWN) 719 { 720 if( (v->vtype = lengtype(type, length))==TYCHAR && length!=0) 721 v->vleng = MKICON(length); 722 } 723else if(v->vtype!=type || (type==TYCHAR && v->vleng->b_const.fconst.ci!=length) ) 724 dclerr("incompatible type declarations", v); 725} 726 727 728 729 730int 731lengtype(type, length) 732register int type; 733register int length; 734{ 735switch(type) 736 { 737 case TYREAL: 738 if(length == 8) 739 return(TYDREAL); 740 if(length == 4) 741 goto ret; 742 break; 743 744 case TYCOMPLEX: 745 if(length == 16) 746 return(TYDCOMPLEX); 747 if(length == 8) 748 goto ret; 749 break; 750 751 case TYSHORT: 752 case TYDREAL: 753 case TYDCOMPLEX: 754 case TYCHAR: 755 case TYUNKNOWN: 756 case TYSUBR: 757 case TYERROR: 758 goto ret; 759 760 case TYLOGICAL: 761 if(length == 4) 762 goto ret; 763 break; 764 765 case TYLONG: 766 if(length == 0) 767 return(tyint); 768 if(length == 2) 769 return(TYSHORT); 770 if(length == 4) 771 goto ret; 772 break; 773 default: 774 fatal1("lengtype: invalid type %d", type); 775 } 776 777if(length != 0) 778 err("incompatible type-length combination"); 779 780ret: 781 return(type); 782} 783 784 785 786 787void 788setintr(v) 789register struct bigblock * v; 790{ 791register int k; 792 793if(v->vstg == STGUNKNOWN) 794 v->vstg = STGINTR; 795else if(v->vstg!=STGINTR) 796 dclerr("incompatible use of intrinsic function", v); 797if(v->vclass==CLUNKNOWN) 798 v->vclass = CLPROC; 799if(v->b_name.vprocclass == PUNKNOWN) 800 v->b_name.vprocclass = PINTRINSIC; 801else if(v->b_name.vprocclass != PINTRINSIC) 802 dclerr("invalid intrinsic declaration", v); 803if((k = intrfunct(v->b_name.varname))) 804 v->b_name.vardesc.varno = k; 805else 806 dclerr("unknown intrinsic function", v); 807} 808 809 810void 811setext(v) 812register struct bigblock * v; 813{ 814if(v->vclass == CLUNKNOWN) 815 v->vclass = CLPROC; 816else if(v->vclass != CLPROC) 817 dclerr("invalid external declaration", v); 818 819if(v->b_name.vprocclass == PUNKNOWN) 820 v->b_name.vprocclass = PEXTERNAL; 821else if(v->b_name.vprocclass != PEXTERNAL) 822 dclerr("invalid external declaration", v); 823} 824 825 826 827 828/* create dimensions block for array variable */ 829void 830setbound(v, nd, dims) 831register struct bigblock * v; 832int nd; 833struct uux dims[ ]; 834{ 835register bigptr q, t; 836register struct dimblock *p; 837int i; 838 839if(v->vclass == CLUNKNOWN) 840 v->vclass = CLVAR; 841else if(v->vclass != CLVAR) 842 { 843 dclerr("only variables may be arrays", v); 844 return; 845 } 846 847v->b_name.vdim = p = (struct dimblock *) ckalloc( sizeof(int) + (3+2*nd)*sizeof(bigptr) ); 848p->ndim = nd; 849p->nelt = MKICON(1); 850 851for(i=0 ; i<nd ; ++i) 852 { 853 if( (q = dims[i].ub) == NULL) 854 { 855 if(i == nd-1) 856 { 857 frexpr(p->nelt); 858 p->nelt = NULL; 859 } 860 else 861 err("only last bound may be asterisk"); 862 p->dims[i].dimsize = MKICON(1);; 863 p->dims[i].dimexpr = NULL; 864 } 865 else 866 { 867 if(dims[i].lb) 868 { 869 q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); 870 q = mkexpr(OPPLUS, q, MKICON(1) ); 871 } 872 if( ISCONST(q) ) 873 { 874 p->dims[i].dimsize = q; 875 p->dims[i].dimexpr = NULL; 876 } 877 else { 878 p->dims[i].dimsize = autovar(1, tyint, NULL); 879 p->dims[i].dimexpr = q; 880 } 881 if(p->nelt) 882 p->nelt = mkexpr(OPSTAR, p->nelt, cpexpr(p->dims[i].dimsize)); 883 } 884 } 885 886q = dims[nd-1].lb; 887if(q == NULL) 888 q = MKICON(1); 889 890for(i = nd-2 ; i>=0 ; --i) 891 { 892 t = dims[i].lb; 893 if(t == NULL) 894 t = MKICON(1); 895 if(p->dims[i].dimsize) 896 q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) ); 897 } 898 899if( ISCONST(q) ) 900 { 901 p->baseoffset = q; 902 p->basexpr = NULL; 903 } 904else 905 { 906 p->baseoffset = autovar(1, tyint, NULL); 907 p->basexpr = q; 908 } 909} 910