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