00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024 #include "defs.h"
00025 #include "output.h"
00026 #include "names.h"
00027
00028 typedef struct { double dreal, dimag; } dcomplex;
00029
00030 static void consbinop Argdcl((int, int, Constp, Constp, Constp));
00031 static void conspower Argdcl((Constp, Constp, long int));
00032 static void zdiv Argdcl((dcomplex*, dcomplex*, dcomplex*));
00033 static tagptr mkpower Argdcl((tagptr));
00034 static tagptr stfcall Argdcl((Namep, struct Listblock*));
00035
00036 extern char dflttype[26];
00037 extern int htype;
00038
00039
00040
00041 Constp
00042 #ifdef KR_headers
00043 mkconst(t)
00044 register int t;
00045 #else
00046 mkconst(register int t)
00047 #endif
00048 {
00049 register Constp p;
00050
00051 p = ALLOC(Constblock);
00052 p->tag = TCONST;
00053 p->vtype = t;
00054 return(p);
00055 }
00056
00057
00058
00059
00060 expptr
00061 #ifdef KR_headers
00062 mklogcon(l)
00063 register int l;
00064 #else
00065 mklogcon(register int l)
00066 #endif
00067 {
00068 register Constp p;
00069
00070 p = mkconst(tylog);
00071 p->Const.ci = l;
00072 return( (expptr) p );
00073 }
00074
00075
00076
00077
00078
00079 expptr
00080 #ifdef KR_headers
00081 mkintcon(l)
00082 ftnint l;
00083 #else
00084 mkintcon(ftnint l)
00085 #endif
00086 {
00087 register Constp p;
00088
00089 p = mkconst(tyint);
00090 p->Const.ci = l;
00091 return( (expptr) p );
00092 }
00093
00094
00095
00096
00097
00098
00099 expptr
00100 #ifdef KR_headers
00101 mkaddcon(l)
00102 register long l;
00103 #else
00104 mkaddcon(register long l)
00105 #endif
00106 {
00107 register Constp p;
00108
00109 p = mkconst(TYADDR);
00110 p->Const.ci = l;
00111 return( (expptr) p );
00112 }
00113
00114
00115
00116
00117
00118
00119 expptr
00120 #ifdef KR_headers
00121 mkrealcon(t, d)
00122 register int t;
00123 char *d;
00124 #else
00125 mkrealcon(register int t, char *d)
00126 #endif
00127 {
00128 register Constp p;
00129
00130 p = mkconst(t);
00131 p->Const.cds[0] = cds(d,CNULL);
00132 p->vstg = 1;
00133 return( (expptr) p );
00134 }
00135
00136
00137
00138
00139
00140
00141
00142
00143 expptr
00144 #ifdef KR_headers
00145 mkbitcon(shift, leng, s)
00146 int shift;
00147 int leng;
00148 char *s;
00149 #else
00150 mkbitcon(int shift, int leng, char *s)
00151 #endif
00152 {
00153 register Constp p;
00154 register long x, y, z;
00155 int len;
00156 char buff[100], *fmt, *s0 = s;
00157 static char *kind[3] = { "Binary", "Hex", "Octal" };
00158
00159 p = mkconst(TYLONG);
00160 x = y = 0;
00161 while(--leng >= 0)
00162 if(*s != ' ') {
00163 z = x;
00164 x = (x << shift) | hextoi(*s++);
00165 y |= (((unsigned long)x) >> shift) - z;
00166 }
00167
00168
00169
00170
00171 p->Const.ci = x;
00172 if (y) {
00173 if (--shift == 3)
00174 shift = 1;
00175 if ((len = (int)leng) > 60)
00176 sprintf(buff, "%s constant '%.60s' truncated.",
00177 kind[shift], s0);
00178 else
00179 sprintf(buff, "%s constant '%.*s' truncated.",
00180 kind[shift], len, s0);
00181 err(buff);
00182 }
00183 return( (expptr) p );
00184 }
00185
00186
00187
00188
00189
00190
00191
00192
00193 expptr
00194 #ifdef KR_headers
00195 mkstrcon(l, v)
00196 int l;
00197 register char *v;
00198 #else
00199 mkstrcon(int l, register char *v)
00200 #endif
00201 {
00202 register Constp p;
00203 register char *s;
00204
00205 p = mkconst(TYCHAR);
00206 p->vleng = ICON(l);
00207 p->Const.ccp = s = (char *) ckalloc(l+1);
00208 p->Const.ccp1.blanks = 0;
00209 while(--l >= 0)
00210 *s++ = *v++;
00211 *s = '\0';
00212 return( (expptr) p );
00213 }
00214
00215
00216
00217
00218
00219
00220 expptr
00221 #ifdef KR_headers
00222 mkcxcon(realp, imagp)
00223 register expptr realp;
00224 register expptr imagp;
00225 #else
00226 mkcxcon(register expptr realp, register expptr imagp)
00227 #endif
00228 {
00229 int rtype, itype;
00230 register Constp p;
00231
00232 rtype = realp->headblock.vtype;
00233 itype = imagp->headblock.vtype;
00234
00235 if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
00236 {
00237 p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
00238 ? TYDCOMPLEX : tycomplex);
00239 if (realp->constblock.vstg || imagp->constblock.vstg) {
00240 p->vstg = 1;
00241 p->Const.cds[0] = ISINT(rtype)
00242 ? string_num("", realp->constblock.Const.ci)
00243 : realp->constblock.vstg
00244 ? realp->constblock.Const.cds[0]
00245 : dtos(realp->constblock.Const.cd[0]);
00246 p->Const.cds[1] = ISINT(itype)
00247 ? string_num("", imagp->constblock.Const.ci)
00248 : imagp->constblock.vstg
00249 ? imagp->constblock.Const.cds[0]
00250 : dtos(imagp->constblock.Const.cd[0]);
00251 }
00252 else {
00253 p->Const.cd[0] = ISINT(rtype)
00254 ? realp->constblock.Const.ci
00255 : realp->constblock.Const.cd[0];
00256 p->Const.cd[1] = ISINT(itype)
00257 ? imagp->constblock.Const.ci
00258 : imagp->constblock.Const.cd[0];
00259 }
00260 }
00261 else
00262 {
00263 err("invalid complex constant");
00264 p = (Constp)errnode();
00265 }
00266
00267 frexpr(realp);
00268 frexpr(imagp);
00269 return( (expptr) p );
00270 }
00271
00272
00273
00274
00275 expptr
00276 errnode(Void)
00277 {
00278 struct Errorblock *p;
00279 p = ALLOC(Errorblock);
00280 p->tag = TERROR;
00281 p->vtype = TYERROR;
00282 return( (expptr) p );
00283 }
00284
00285
00286
00287
00288
00289
00290
00291
00292
00293 expptr
00294 #ifdef KR_headers
00295 mkconv(t, p)
00296 register int t;
00297 register expptr p;
00298 #else
00299 mkconv(register int t, register expptr p)
00300 #endif
00301 {
00302 register expptr q;
00303 register int pt, charwarn = 1;
00304
00305 if (t >= 100) {
00306 t -= 100;
00307 charwarn = 0;
00308 }
00309 if(t==TYUNKNOWN || t==TYERROR)
00310 badtype("mkconv", t);
00311 pt = p->headblock.vtype;
00312
00313
00314
00315 if(t == pt)
00316 return(p);
00317
00318
00319
00320 else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR
00321 || p->tag == TADDR && p->addrblock.uname_tag == UNAM_CONST)
00322 {
00323 if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
00324
00325 p->headblock.vtype = t;
00326 return p;
00327 }
00328 q = (expptr) mkconst(t);
00329 consconv(t, &q->constblock, &p->constblock );
00330 if (p->tag == TADDR)
00331 q->constblock.vstg = p->addrblock.user.kludge.vstg1;
00332 frexpr(p);
00333 }
00334 else {
00335 if (pt == TYCHAR && t != TYADDR && charwarn
00336 && (!halign || p->tag != TADDR
00337 || p->addrblock.uname_tag != UNAM_CONST))
00338 warn(
00339 "ichar([first char. of] char. string) assumed for conversion to numeric");
00340 q = opconv(p, t);
00341 }
00342
00343 if(t == TYCHAR)
00344 q->constblock.vleng = ICON(1);
00345 return(q);
00346 }
00347
00348
00349
00350
00351
00352
00353 expptr
00354 #ifdef KR_headers
00355 opconv(p, t)
00356 expptr p;
00357 int t;
00358 #else
00359 opconv(expptr p, int t)
00360 #endif
00361 {
00362 register expptr q;
00363
00364 if (t == TYSUBR)
00365 err("illegal use of subroutine name");
00366 q = mkexpr(OPCONV, p, ENULL);
00367 q->headblock.vtype = t;
00368 return(q);
00369 }
00370
00371
00372
00373
00374
00375 expptr
00376 #ifdef KR_headers
00377 addrof(p)
00378 expptr p;
00379 #else
00380 addrof(expptr p)
00381 #endif
00382 {
00383 return( mkexpr(OPADDR, p, ENULL) );
00384 }
00385
00386
00387
00388
00389
00390 tagptr
00391 #ifdef KR_headers
00392 cpexpr(p)
00393 register tagptr p;
00394 #else
00395 cpexpr(register tagptr p)
00396 #endif
00397 {
00398 register tagptr e;
00399 int tag;
00400 register chainp ep, pp;
00401
00402
00403
00404 static int blksize[ ] =
00405 {
00406 0,
00407 sizeof(struct Nameblock),
00408 sizeof(struct Constblock),
00409 sizeof(struct Exprblock),
00410 sizeof(struct Addrblock),
00411 sizeof(struct Primblock),
00412 sizeof(struct Listblock),
00413 sizeof(struct Impldoblock),
00414 sizeof(struct Errorblock)
00415 };
00416
00417 if(p == NULL)
00418 return(NULL);
00419
00420
00421
00422
00423 if( (tag = p->tag) == TNAME)
00424 return(p);
00425
00426 e = cpblock(blksize[p->tag], (char *)p);
00427
00428 switch(tag)
00429 {
00430 case TCONST:
00431 if(e->constblock.vtype == TYCHAR)
00432 {
00433 e->constblock.Const.ccp =
00434 copyn((int)e->constblock.vleng->constblock.Const.ci+1,
00435 e->constblock.Const.ccp);
00436 e->constblock.vleng =
00437 (expptr) cpexpr(e->constblock.vleng);
00438 }
00439 case TERROR:
00440 break;
00441
00442 case TEXPR:
00443 e->exprblock.leftp = (expptr) cpexpr(p->exprblock.leftp);
00444 e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
00445 break;
00446
00447 case TLIST:
00448 if(pp = p->listblock.listp)
00449 {
00450 ep = e->listblock.listp =
00451 mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
00452 for(pp = pp->nextp ; pp ; pp = pp->nextp)
00453 ep = ep->nextp =
00454 mkchain((char *)cpexpr((tagptr)pp->datap),
00455 CHNULL);
00456 }
00457 break;
00458
00459 case TADDR:
00460 e->addrblock.vleng = (expptr) cpexpr(e->addrblock.vleng);
00461 e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
00462 e->addrblock.istemp = NO;
00463 break;
00464
00465 case TPRIM:
00466 e->primblock.argsp = (struct Listblock *)
00467 cpexpr((expptr)e->primblock.argsp);
00468 e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
00469 e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
00470 break;
00471
00472 default:
00473 badtag("cpexpr", tag);
00474 }
00475
00476 return(e);
00477 }
00478
00479
00480
00481 void
00482 #ifdef KR_headers
00483 frexpr(p)
00484 register tagptr p;
00485 #else
00486 frexpr(register tagptr p)
00487 #endif
00488 {
00489 register chainp q;
00490
00491 if(p == NULL)
00492 return;
00493
00494 switch(p->tag)
00495 {
00496 case TCONST:
00497 if( ISCHAR(p) )
00498 {
00499 free( (charptr) (p->constblock.Const.ccp) );
00500 frexpr(p->constblock.vleng);
00501 }
00502 break;
00503
00504 case TADDR:
00505 if (p->addrblock.vtype > TYERROR)
00506 break;
00507 frexpr(p->addrblock.vleng);
00508 frexpr(p->addrblock.memoffset);
00509 break;
00510
00511 case TERROR:
00512 break;
00513
00514
00515
00516
00517 case TNAME:
00518 return;
00519
00520 case TPRIM:
00521 frexpr((expptr)p->primblock.argsp);
00522 frexpr(p->primblock.fcharp);
00523 frexpr(p->primblock.lcharp);
00524 break;
00525
00526 case TEXPR:
00527 frexpr(p->exprblock.leftp);
00528 if(p->exprblock.rightp)
00529 frexpr(p->exprblock.rightp);
00530 break;
00531
00532 case TLIST:
00533 for(q = p->listblock.listp ; q ; q = q->nextp)
00534 frexpr((tagptr)q->datap);
00535 frchain( &(p->listblock.listp) );
00536 break;
00537
00538 default:
00539 badtag("frexpr", p->tag);
00540 }
00541
00542 free( (charptr) p );
00543 }
00544
00545 void
00546 #ifdef KR_headers
00547 wronginf(np)
00548 Namep np;
00549 #else
00550 wronginf(Namep np)
00551 #endif
00552 {
00553 int c, k;
00554 warn1("fixing wrong type inferred for %.65s", np->fvarname);
00555 np->vinftype = 0;
00556 c = letter(np->fvarname[0]);
00557 if ((np->vtype = impltype[c]) == TYCHAR
00558 && (k = implleng[c]))
00559 np->vleng = ICON(k);
00560 }
00561
00562
00563
00564
00565 expptr
00566 #ifdef KR_headers
00567 fixtype(p)
00568 register tagptr p;
00569 #else
00570 fixtype(register tagptr p)
00571 #endif
00572 {
00573
00574 if(p == 0)
00575 return(0);
00576
00577 switch(p->tag)
00578 {
00579 case TCONST:
00580 if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
00581 MSKREAL) )
00582 return( (expptr) p);
00583
00584 return( (expptr) putconst((Constp)p) );
00585
00586 case TADDR:
00587 p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
00588 return( (expptr) p);
00589
00590 case TERROR:
00591 return( (expptr) p);
00592
00593 default:
00594 badtag("fixtype", p->tag);
00595
00596
00597
00598
00599 case TEXPR:
00600 if (((Exprp)p)->typefixed)
00601 return (expptr)p;
00602 return( fixexpr((Exprp)p) );
00603
00604 case TLIST:
00605 return( (expptr) p );
00606
00607 case TPRIM:
00608 if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
00609 {
00610 if(p->primblock.namep->vtype == TYSUBR)
00611 {
00612 err("function invocation of subroutine");
00613 return( errnode() );
00614 }
00615 else {
00616 if (p->primblock.namep->vinftype)
00617 wronginf(p->primblock.namep);
00618 return( mkfunct(p) );
00619 }
00620 }
00621
00622
00623
00624
00625 else return mklhs((struct Primblock *) p, keepsubs);
00626 }
00627 }
00628
00629
00630 int
00631 #ifdef KR_headers
00632 badchleng(p)
00633 register expptr p;
00634 #else
00635 badchleng(register expptr p)
00636 #endif
00637 {
00638 if (!p->headblock.vleng) {
00639 if (p->headblock.tag == TADDR
00640 && p->addrblock.uname_tag == UNAM_NAME)
00641 errstr("bad use of character*(*) variable %.60s",
00642 p->addrblock.user.name->fvarname);
00643 else
00644 err("Bad use of character*(*)");
00645 return 1;
00646 }
00647 return 0;
00648 }
00649
00650
00651 static expptr
00652 #ifdef KR_headers
00653 cplenexpr(p)
00654 expptr p;
00655 #else
00656 cplenexpr(expptr p)
00657 #endif
00658 {
00659 expptr rv;
00660
00661 if (badchleng(p))
00662 return ICON(1);
00663 rv = cpexpr(p->headblock.vleng);
00664 if (ISCONST(p) && p->constblock.vtype == TYCHAR)
00665 rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks;
00666 return rv;
00667 }
00668
00669
00670
00671
00672
00673
00674 expptr
00675 #ifdef KR_headers
00676 fixexpr(p)
00677 register Exprp p;
00678 #else
00679 fixexpr(register Exprp p)
00680 #endif
00681 {
00682 expptr lp;
00683 register expptr rp;
00684 register expptr q;
00685 char *hsave;
00686 int opcode, ltype, rtype, ptype, mtype;
00687
00688 if( ISERROR(p) || p->typefixed )
00689 return( (expptr) p );
00690 else if(p->tag != TEXPR)
00691 badtag("fixexpr", p->tag);
00692 opcode = p->opcode;
00693
00694
00695
00696 lp = p->leftp;
00697 if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR)
00698 lp = p->leftp = fixtype(lp);
00699 ltype = lp->headblock.vtype;
00700
00701 if(opcode==OPASSIGN && lp->tag!=TADDR)
00702 {
00703 err("left side of assignment must be variable");
00704 eret:
00705 frexpr((expptr)p);
00706 return( errnode() );
00707 }
00708
00709 if(rp = p->rightp)
00710 {
00711 if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR)
00712 rp = p->rightp = fixtype(rp);
00713 rtype = rp->headblock.vtype;
00714 }
00715 else
00716 rtype = 0;
00717
00718 if(ltype==TYERROR || rtype==TYERROR)
00719 goto eret;
00720
00721
00722
00723
00724
00725 if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
00726 {
00727 q = opcode == OPCONV && lp->constblock.vtype == p->vtype
00728 ? lp : mkexpr(opcode, lp, rp);
00729
00730
00731
00732 if( ISCONST(q) ) {
00733 p->leftp = p->rightp = 0;
00734 frexpr((expptr)p);
00735 return(q);
00736 }
00737 free( (charptr) q );
00738 }
00739
00740 if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
00741 goto eret;
00742
00743 if (ltype == TYCHAR && ISCONST(lp)) {
00744 if (opcode == OPCONV) {
00745 hsave = halign;
00746 halign = 0;
00747 lp = (expptr)putconst((Constp)lp);
00748 halign = hsave;
00749 }
00750 else
00751 lp = (expptr)putconst((Constp)lp);
00752 p->leftp = lp;
00753 }
00754 if (rtype == TYCHAR && ISCONST(rp))
00755 p->rightp = rp = (expptr)putconst((Constp)rp);
00756
00757 switch(opcode)
00758 {
00759 case OPCONCAT:
00760 if(p->vleng == NULL)
00761 p->vleng = mkexpr(OPPLUS, cplenexpr(lp),
00762 cplenexpr(rp) );
00763 break;
00764
00765 case OPASSIGN:
00766 if (rtype == TYREAL || ISLOGICAL(ptype)
00767 || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp))
00768 break;
00769 case OPPLUSEQ:
00770 case OPSTAREQ:
00771 if(ltype == rtype)
00772 break;
00773 if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
00774 break;
00775 if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
00776 break;
00777 if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
00778 && typesize[ltype]>=typesize[rtype] )
00779 break;
00780
00781
00782
00783 p->rightp = fixtype( mkconv(ptype, rp) );
00784 break;
00785
00786 case OPSLASH:
00787 if( ISCOMPLEX(rtype) )
00788 {
00789 p = (Exprp) call2(ptype,
00790
00791
00792
00793 ptype == TYCOMPLEX ? "c_div" : "z_div",
00794 mkconv(ptype, lp), mkconv(ptype, rp) );
00795 break;
00796 }
00797 case OPPLUS:
00798 case OPMINUS:
00799 case OPSTAR:
00800 case OPMOD:
00801 if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
00802 (rtype==TYREAL && ! ISCONST(rp) ) ))
00803 break;
00804 if( ISCOMPLEX(ptype) )
00805 break;
00806
00807
00808
00809
00810 if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL))
00811 p->leftp = fixtype(mkconv(ptype,lp));
00812 if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL))
00813 p->rightp = fixtype(mkconv(ptype,rp));
00814 break;
00815
00816 case OPPOWER:
00817 rp = mkpower((expptr)p);
00818 if (rp->tag == TEXPR)
00819 rp->exprblock.typefixed = 1;
00820 return rp;
00821
00822 case OPLT:
00823 case OPLE:
00824 case OPGT:
00825 case OPGE:
00826 case OPEQ:
00827 case OPNE:
00828 if(ltype == rtype)
00829 break;
00830 if (htype) {
00831 if (ltype == TYCHAR) {
00832 p->leftp = fixtype(mkconv(rtype,lp));
00833 break;
00834 }
00835 if (rtype == TYCHAR) {
00836 p->rightp = fixtype(mkconv(ltype,rp));
00837 break;
00838 }
00839 }
00840 mtype = cktype(OPMINUS, ltype, rtype);
00841 if(mtype==TYDREAL && (ltype==TYREAL || rtype==TYREAL))
00842 break;
00843 if( ISCOMPLEX(mtype) )
00844 break;
00845 if(ltype != mtype)
00846 p->leftp = fixtype(mkconv(mtype,lp));
00847 if(rtype != mtype)
00848 p->rightp = fixtype(mkconv(mtype,rp));
00849 break;
00850
00851 case OPCONV:
00852 ptype = cktype(OPCONV, p->vtype, ltype);
00853 if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA
00854 && !ISCOMPLEX(ptype))
00855 {
00856 lp->exprblock.rightp =
00857 fixtype( mkconv(ptype, lp->exprblock.rightp) );
00858 free( (charptr) p );
00859 p = (Exprp) lp;
00860 }
00861 break;
00862
00863 case OPADDR:
00864 if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
00865 Fatal("addr of addr");
00866 break;
00867
00868 case OPCOMMA:
00869 case OPQUEST:
00870 case OPCOLON:
00871 break;
00872
00873 case OPMIN:
00874 case OPMAX:
00875 case OPMIN2:
00876 case OPMAX2:
00877 case OPDMIN:
00878 case OPDMAX:
00879 case OPABS:
00880 case OPDABS:
00881 ptype = p->vtype;
00882 break;
00883
00884 default:
00885 break;
00886 }
00887
00888 p->vtype = ptype;
00889 p->typefixed = 1;
00890 return((expptr) p);
00891 }
00892
00893
00894
00895
00896 int
00897 #ifdef KR_headers
00898 fixargs(doput, p0)
00899 int doput;
00900 struct Listblock *p0;
00901 #else
00902 fixargs(int doput, struct Listblock *p0)
00903 #endif
00904
00905 {
00906 register chainp p;
00907 register tagptr q, t;
00908 register int qtag;
00909 int nargs;
00910
00911 nargs = 0;
00912 if(p0)
00913 for(p = p0->listp ; p ; p = p->nextp)
00914 {
00915 ++nargs;
00916 q = (tagptr)p->datap;
00917 qtag = q->tag;
00918 if(qtag == TCONST)
00919 {
00920
00921
00922
00923
00924
00925 p->datap = doput ? (char *)putconst((Constp)q)
00926 : (char *)q;
00927 continue;
00928 }
00929
00930
00931
00932
00933 if (qtag == TPRIM && q->primblock.argsp == 0) {
00934 if (q->primblock.namep->vclass==CLPROC
00935 && q->primblock.namep->vprocclass != PTHISPROC) {
00936 p->datap = (char *)mkaddr(q->primblock.namep);
00937 continue;
00938 }
00939
00940 if (q->primblock.namep->vdim != NULL) {
00941 p->datap = (char *)mkscalar(q->primblock.namep);
00942 if ((q->primblock.fcharp||q->primblock.lcharp)
00943 && (q->primblock.namep->vtype != TYCHAR
00944 || q->primblock.namep->vdim))
00945 sserr(q->primblock.namep);
00946 continue;
00947 }
00948
00949 if (q->primblock.namep->vdovar
00950 && (t = (tagptr) memversion(q->primblock.namep))) {
00951 p->datap = (char *)fixtype(t);
00952 continue;
00953 }
00954 }
00955 p->datap = (char *)fixtype(q);
00956 }
00957 return(nargs);
00958 }
00959
00960
00961
00962
00963
00964
00965 Addrp
00966 #ifdef KR_headers
00967 mkscalar(np)
00968 register Namep np;
00969 #else
00970 mkscalar(register Namep np)
00971 #endif
00972 {
00973 register Addrp ap;
00974
00975 vardcl(np);
00976 ap = mkaddr(np);
00977
00978
00979
00980
00981 if( !checksubs && np->vstg==STGARG)
00982 {
00983 register struct Dimblock *dp;
00984 dp = np->vdim;
00985 frexpr(ap->memoffset);
00986 ap->memoffset = mkexpr(OPSTAR,
00987 (np->vtype==TYCHAR ?
00988 cpexpr(np->vleng) :
00989 (tagptr)ICON(typesize[np->vtype]) ),
00990 cpexpr(dp->baseoffset) );
00991 }
00992 return(ap);
00993 }
00994
00995
00996 static void
00997 #ifdef KR_headers
00998 adjust_arginfo(np)
00999 register Namep np;
01000 #else
01001 adjust_arginfo(register Namep np)
01002 #endif
01003
01004
01005
01006 {
01007 struct Entrypoint *ep;
01008 register chainp args;
01009 Argtypes *at;
01010
01011 for(ep = entries; ep; ep = ep->entnextp)
01012 for(args = ep->arglist; args; args = args->nextp)
01013 if (np == (Namep)args->datap
01014 && (at = ep->entryname->arginfo))
01015 --at->nargs;
01016 }
01017
01018
01019 expptr
01020 #ifdef KR_headers
01021 mkfunct(p0)
01022 expptr p0;
01023 #else
01024 mkfunct(expptr p0)
01025 #endif
01026 {
01027 register struct Primblock *p = (struct Primblock *)p0;
01028 struct Entrypoint *ep;
01029 Addrp ap;
01030 Extsym *extp;
01031 register Namep np;
01032 register expptr q;
01033 extern chainp new_procs;
01034 int k, nargs;
01035 int classKRH;
01036
01037 if(p->tag != TPRIM)
01038 return( errnode() );
01039
01040 np = p->namep;
01041 classKRH = np->vclass;
01042
01043
01044 if(classKRH == CLUNKNOWN)
01045 {
01046 np->vclass = classKRH = CLPROC;
01047 if(np->vstg == STGUNKNOWN)
01048 {
01049 if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
01050 && (zflag || !(*(struct Intrpacked *)&k).f4
01051 || dcomplex_seen))
01052 {
01053 np->vstg = STGINTR;
01054 np->vardesc.varno = k;
01055 np->vprocclass = PINTRINSIC;
01056 }
01057 else
01058 {
01059 extp = mkext(np->fvarname,
01060 addunder(np->cvarname));
01061 extp->extstg = STGEXT;
01062 np->vstg = STGEXT;
01063 np->vardesc.varno = extp - extsymtab;
01064 np->vprocclass = PEXTERNAL;
01065 }
01066 }
01067 else if(np->vstg==STGARG)
01068 {
01069 if(np->vtype == TYCHAR) {
01070 adjust_arginfo(np);
01071 if (np->vpassed) {
01072 char wbuf[160], *who;
01073 who = np->fvarname;
01074 sprintf(wbuf, "%s%s%s\n\t%s%s%s",
01075 "Character-valued dummy procedure ",
01076 who, " not declared EXTERNAL.",
01077 "Code may be wrong for previous function calls having ",
01078 who, " as a parameter.");
01079 warn(wbuf);
01080 }
01081 }
01082 np->vprocclass = PEXTERNAL;
01083 }
01084 }
01085
01086 if(classKRH != CLPROC) {
01087 if (np->vstg == STGCOMMON)
01088 fatalstr(
01089 "Cannot invoke common variable %.50s as a function.",
01090 np->fvarname);
01091 errstr("%.80s cannot be called.", np->fvarname);
01092 goto error;
01093 }
01094
01095
01096
01097 if(p->fcharp || p->lcharp)
01098 {
01099 err("no substring of function call");
01100 goto error;
01101 }
01102 impldcl(np);
01103 np->vimpltype = 0;
01104 np->vcalled = 1;
01105 nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp);
01106
01107 switch(np->vprocclass)
01108 {
01109 case PEXTERNAL:
01110 if(np->vtype == TYUNKNOWN)
01111 {
01112 dclerr("attempt to use untyped function", np);
01113 np->vtype = dflttype[letter(np->fvarname[0])];
01114 }
01115 ap = mkaddr(np);
01116 if (!extsymtab[np->vardesc.varno].extseen) {
01117 new_procs = mkchain((char *)np, new_procs);
01118 extsymtab[np->vardesc.varno].extseen = 1;
01119 }
01120 call:
01121 q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
01122 q->exprblock.vtype = np->vtype;
01123 if(np->vleng)
01124 q->exprblock.vleng = (expptr) cpexpr(np->vleng);
01125 break;
01126
01127 case PINTRINSIC:
01128 q = intrcall(np, p->argsp, nargs);
01129 break;
01130
01131 case PSTFUNCT:
01132 q = stfcall(np, p->argsp);
01133 break;
01134
01135 case PTHISPROC:
01136 warn("recursive call");
01137
01138
01139
01140 for(ep = entries ; ep ; ep = ep->entnextp)
01141 if(ep->enamep == np)
01142 break;
01143 if(ep == NULL)
01144 Fatal("mkfunct: impossible recursion");
01145
01146 ap = builtin(np->vtype, ep->entryname->cextname, -2);
01147
01148
01149 goto call;
01150
01151 default:
01152 fatali("mkfunct: impossible vprocclass %d",
01153 (int) (np->vprocclass) );
01154 }
01155 free( (charptr) p );
01156 return(q);
01157
01158 error:
01159 frexpr((expptr)p);
01160 return( errnode() );
01161 }
01162
01163
01164
01165 static expptr
01166 #ifdef KR_headers
01167 stfcall(np, actlist)
01168 Namep np;
01169 struct Listblock *actlist;
01170 #else
01171 stfcall(Namep np, struct Listblock *actlist)
01172 #endif
01173 {
01174 register chainp actuals;
01175 int nargs;
01176 chainp oactp, formals;
01177 int type;
01178 expptr Ln, Lq, q, q1, rhs, ap;
01179 Namep tnp;
01180 register struct Rplblock *rp;
01181 struct Rplblock *tlist;
01182
01183 if (np->arginfo) {
01184 errstr("statement function %.66s calls itself.",
01185 np->fvarname);
01186 return ICON(0);
01187 }
01188 np->arginfo = (Argtypes *)np;
01189 if(actlist)
01190 {
01191 actuals = actlist->listp;
01192 free( (charptr) actlist);
01193 }
01194 else
01195 actuals = NULL;
01196 oactp = actuals;
01197
01198 nargs = 0;
01199 tlist = NULL;
01200 if( (type = np->vtype) == TYUNKNOWN)
01201 {
01202 dclerr("attempt to use untyped statement function", np);
01203 type = np->vtype = dflttype[letter(np->fvarname[0])];
01204 }
01205 formals = (chainp) np->varxptr.vstfdesc->datap;
01206 rhs = (expptr) (np->varxptr.vstfdesc->nextp);
01207
01208
01209 while(actuals!=NULL && formals!=NULL)
01210 {
01211 if (!(tnp = (Namep) formals->datap)) {
01212
01213 q = ICON(1);
01214 goto done;
01215 }
01216 rp = ALLOC(Rplblock);
01217 rp->rplnp = tnp;
01218 ap = fixtype((tagptr)actuals->datap);
01219 if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
01220 && (ap->tag==TCONST || ap->tag==TADDR) )
01221 {
01222
01223
01224 rp->rplvp = (expptr) ap;
01225 rp->rplxp = NULL;
01226 rp->rpltag = ap->tag;
01227 }
01228 else {
01229 rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng);
01230 rp -> rplxp = NULL;
01231 putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
01232 if((rp->rpltag = rp->rplvp->tag) == TERROR)
01233 err("disagreement of argument types in statement function call");
01234 }
01235 rp->rplnextp = tlist;
01236 tlist = rp;
01237 actuals = actuals->nextp;
01238 formals = formals->nextp;
01239 ++nargs;
01240 }
01241
01242 if(actuals!=NULL || formals!=NULL)
01243 err("statement function definition and argument list differ");
01244
01245
01246
01247
01248
01249
01250 if(tlist)
01251 {
01252 for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
01253 ;
01254 rp->rplnextp = rpllist;
01255 rpllist = tlist;
01256 }
01257
01258
01259
01260
01261 q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
01262
01263
01264 if (type == TYCHAR
01265 && (Ln = np->vleng)
01266 && q->tag != TERROR
01267 && (Lq = q->exprblock.vleng)
01268 && (Lq->tag != TCONST
01269 || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) {
01270 q1 = (expptr) mktmp(type, Ln);
01271 putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q));
01272 q = q1;
01273 }
01274
01275
01276 while(--nargs >= 0)
01277 {
01278 if(rpllist->rplxp)
01279 q = mkexpr(OPCOMMA, rpllist->rplxp, q);
01280 rp = rpllist->rplnextp;
01281 frexpr(rpllist->rplvp);
01282 free((char *)rpllist);
01283 rpllist = rp;
01284 }
01285 done:
01286 frchain( &oactp );
01287 np->arginfo = 0;
01288 return(q);
01289 }
01290
01291
01292 static int replaced;
01293
01294
01295
01296
01297 Addrp
01298 #ifdef KR_headers
01299 mkplace(np)
01300 register Namep np;
01301 #else
01302 mkplace(register Namep np)
01303 #endif
01304 {
01305 register Addrp s;
01306 register struct Rplblock *rp;
01307 int regn;
01308
01309
01310
01311 for(rp = rpllist ; rp ; rp = rp->rplnextp)
01312 {
01313 if(np == rp->rplnp)
01314 {
01315 replaced = 1;
01316 if(rp->rpltag == TNAME)
01317 {
01318 np = (Namep) (rp->rplvp);
01319 break;
01320 }
01321 else return( (Addrp) cpexpr(rp->rplvp) );
01322 }
01323 }
01324
01325
01326
01327 if(np->vdovar && ( (regn = inregister(np)) >= 0) )
01328 if(np->vtype == TYERROR)
01329 return((Addrp) errnode() );
01330 else
01331 {
01332 s = ALLOC(Addrblock);
01333 s->tag = TADDR;
01334 s->vstg = STGREG;
01335 s->vtype = TYIREG;
01336 s->memno = regn;
01337 s->memoffset = ICON(0);
01338 s -> uname_tag = UNAM_NAME;
01339 s -> user.name = np;
01340 return(s);
01341 }
01342
01343 if (np->vclass == CLPROC && np->vprocclass != PTHISPROC)
01344 errstr("external %.60s used as a variable", np->fvarname);
01345 vardcl(np);
01346 return(mkaddr(np));
01347 }
01348
01349 static expptr
01350 #ifdef KR_headers
01351 subskept(p, a)
01352 struct Primblock *p;
01353 Addrp a;
01354 #else
01355 subskept(struct Primblock *p, Addrp a)
01356 #endif
01357 {
01358 expptr ep;
01359 struct Listblock *Lb;
01360 chainp cp;
01361
01362 if (a->uname_tag != UNAM_NAME)
01363 erri("subskept: uname_tag %d", a->uname_tag);
01364 a->user.name->vrefused = 1;
01365 a->user.name->visused = 1;
01366 a->uname_tag = UNAM_REF;
01367 Lb = (struct Listblock *)cpexpr((tagptr)p->argsp);
01368 for(cp = Lb->listp; cp; cp = cp->nextp)
01369 cp->datap = (char *)putx(fixtype((tagptr)cp->datap));
01370 if (a->vtype == TYCHAR) {
01371 ep = p->fcharp ? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1))
01372 : ICON(0);
01373 Lb->listp = mkchain((char *)ep, Lb->listp);
01374 }
01375 return (expptr)Lb;
01376 }
01377
01378 static int doing_vleng;
01379
01380
01381
01382
01383
01384 expptr
01385 #ifdef KR_headers
01386 mklhs(p, subkeep)
01387 register struct Primblock *p;
01388 int subkeep;
01389 #else
01390 mklhs(register struct Primblock *p, int subkeep)
01391 #endif
01392 {
01393 register Addrp s;
01394 Namep np;
01395
01396 if(p->tag != TPRIM)
01397 return( (expptr) p );
01398 np = p->namep;
01399
01400 replaced = 0;
01401 s = mkplace(np);
01402 if(s->tag!=TADDR || s->vstg==STGREG)
01403 {
01404 free( (charptr) p );
01405 return( (expptr) s );
01406 }
01407 s->parenused = p->parenused;
01408
01409
01410
01411 if (!replaced)
01412 s->memoffset = (subkeep && np->vdim
01413 && (np->vdim->ndim > 1 || np->vtype == TYCHAR
01414 && (!ISCONST(np->vleng)
01415 || np->vleng->constblock.Const.ci != 1)))
01416 ? subskept(p,s)
01417 : mkexpr(OPPLUS, s->memoffset, suboffset(p) );
01418 frexpr((expptr)p->argsp);
01419 p->argsp = NULL;
01420
01421
01422
01423 if(p->fcharp || p->lcharp)
01424 {
01425 if(np->vtype != TYCHAR)
01426 sserr(np);
01427 else {
01428 if(p->lcharp == NULL)
01429 p->lcharp = (expptr)(
01430
01431 s->vleng ? cpexpr(s->vleng) : ICON(1));
01432 if(p->fcharp) {
01433 doing_vleng = 1;
01434 s->vleng = fixtype(mkexpr(OPMINUS,
01435 p->lcharp,
01436 mkexpr(OPMINUS, p->fcharp, ICON(1) )));
01437 doing_vleng = 0;
01438 }
01439 else {
01440 frexpr(s->vleng);
01441 s->vleng = p->lcharp;
01442 }
01443 }
01444 }
01445
01446 s->vleng = fixtype( s->vleng );
01447 s->memoffset = fixtype( s->memoffset );
01448 free( (charptr) p );
01449 return( (expptr) s );
01450 }
01451
01452
01453
01454
01455
01456
01457
01458
01459 void
01460 #ifdef KR_headers
01461 deregister(np)
01462 Namep np;
01463 #else
01464 deregister(Namep np)
01465 #endif
01466 {
01467 if(nregvar>0 && regnamep[nregvar-1]==np)
01468 {
01469 --nregvar;
01470 }
01471 }
01472
01473
01474
01475
01476
01477
01478
01479 Addrp
01480 #ifdef KR_headers
01481 memversion(np)
01482 register Namep np;
01483 #else
01484 memversion(register Namep np)
01485 #endif
01486 {
01487 register Addrp s;
01488
01489 if(np->vdovar==NO || (inregister(np)<0) )
01490 return(NULL);
01491 np->vdovar = NO;
01492 s = mkplace(np);
01493 np->vdovar = YES;
01494 return(s);
01495 }
01496
01497
01498
01499
01500
01501 int
01502 #ifdef KR_headers
01503 inregister(np)
01504 register Namep np;
01505 #else
01506 inregister(register Namep np)
01507 #endif
01508 {
01509 register int i;
01510
01511 for(i = 0 ; i < nregvar ; ++i)
01512 if(regnamep[i] == np)
01513 return( regnum[i] );
01514 return(-1);
01515 }
01516
01517
01518
01519
01520
01521
01522 expptr
01523 #ifdef KR_headers
01524 suboffset(p)
01525 register struct Primblock *p;
01526 #else
01527 suboffset(register struct Primblock *p)
01528 #endif
01529 {
01530 int n;
01531 expptr si, size;
01532 chainp cp;
01533 expptr e, e1, offp, prod;
01534 struct Dimblock *dimp;
01535 expptr sub[MAXDIM+1];
01536 register Namep np;
01537
01538 np = p->namep;
01539 offp = ICON(0);
01540 n = 0;
01541 if(p->argsp)
01542 for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
01543 {
01544 si = fixtype(cpexpr((tagptr)cp->datap));
01545 if (!ISINT(si->headblock.vtype)) {
01546 NOEXT("non-integer subscript");
01547 si = mkconv(TYLONG, si);
01548 }
01549 sub[n++] = si;
01550 if(n > maxdim)
01551 {
01552 erri("more than %d subscripts", maxdim);
01553 break;
01554 }
01555 }
01556
01557 dimp = np->vdim;
01558 if(n>0 && dimp==NULL)
01559 errstr("subscripts on scalar variable %.68s", np->fvarname);
01560 else if(dimp && dimp->ndim!=n)
01561 errstr("wrong number of subscripts on %.68s", np->fvarname);
01562 else if(n > 0)
01563 {
01564 prod = sub[--n];
01565 while( --n >= 0)
01566 prod = mkexpr(OPPLUS, sub[n],
01567 mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
01568 if(checksubs || np->vstg!=STGARG)
01569 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
01570
01571
01572
01573 if(checksubs)
01574 prod = subcheck(np, prod);
01575 size = np->vtype == TYCHAR ?
01576 (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
01577 prod = mkexpr(OPSTAR, prod, size);
01578 offp = mkexpr(OPPLUS, offp, prod);
01579 }
01580
01581
01582
01583 if(p->fcharp && np->vtype==TYCHAR) {
01584 e = p->fcharp;
01585 e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1));
01586 if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) {
01587 e = (expptr)mktmp(TYLONG, ENULL);
01588 putout(putassign(cpexpr(e), e1));
01589 p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1));
01590 e1 = e;
01591 }
01592 offp = mkexpr(OPPLUS, offp, e1);
01593 }
01594 return(offp);
01595 }
01596
01597
01598
01599
01600 expptr
01601 #ifdef KR_headers
01602 subcheck(np, p)
01603 Namep np;
01604 register expptr p;
01605 #else
01606 subcheck(Namep np, register expptr p)
01607 #endif
01608 {
01609 struct Dimblock *dimp;
01610 expptr t, checkvar, checkcond, badcall;
01611
01612 dimp = np->vdim;
01613 if(dimp->nelt == NULL)
01614 return(p);
01615 np->vlastdim = 0;
01616 if( ISICON(p) )
01617 {
01618
01619
01620
01621 if(p->constblock.Const.ci < 0)
01622 goto badsub;
01623 if( ISICON(dimp->nelt) )
01624
01625
01626
01627 if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
01628 return(p);
01629 else
01630 goto badsub;
01631 }
01632
01633
01634
01635
01636 if(p->tag==TADDR && p->addrblock.vstg==STGREG)
01637 {
01638 checkvar = (expptr) cpexpr(p);
01639 t = p;
01640 }
01641 else {
01642 checkvar = (expptr) mktmp(p->headblock.vtype, ENULL);
01643 t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
01644 }
01645 checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
01646 if( ! ISICON(p) )
01647 checkcond = mkexpr(OPAND, checkcond,
01648 mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
01649
01650
01651
01652 badcall = call4(p->headblock.vtype, "s_rnge",
01653 mkstrcon(strlen(np->fvarname), np->fvarname),
01654 mkconv(TYLONG, cpexpr(checkvar)),
01655 mkstrcon(strlen(procname), procname),
01656 ICON(lineno) );
01657 badcall->exprblock.opcode = OPCCALL;
01658 p = mkexpr(OPQUEST, checkcond,
01659 mkexpr(OPCOLON, checkvar, badcall));
01660
01661 return(p);
01662
01663 badsub:
01664 frexpr(p);
01665 errstr("subscript on variable %s out of range", np->fvarname);
01666 return ( ICON(0) );
01667 }
01668
01669
01670
01671
01672 Addrp
01673 #ifdef KR_headers
01674 mkaddr(p)
01675 register Namep p;
01676 #else
01677 mkaddr(register Namep p)
01678 #endif
01679 {
01680 Extsym *extp;
01681 register Addrp t;
01682 int k;
01683
01684 switch( p->vstg)
01685 {
01686 case STGAUTO:
01687 if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
01688 return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
01689 goto other;
01690
01691 case STGUNKNOWN:
01692 if(p->vclass != CLPROC)
01693 break;
01694 extp = mkext(p->fvarname, addunder(p->cvarname));
01695 extp->extstg = STGEXT;
01696 p->vstg = STGEXT;
01697 p->vardesc.varno = extp - extsymtab;
01698 p->vprocclass = PEXTERNAL;
01699 if ((extp->exproto || infertypes)
01700 && (p->vtype == TYUNKNOWN || p->vimpltype)
01701 && (k = extp->extype))
01702 inferdcl(p, k);
01703
01704
01705 case STGCOMMON:
01706 case STGEXT:
01707 case STGBSS:
01708 case STGINIT:
01709 case STGEQUIV:
01710 case STGARG:
01711 case STGLENG:
01712 other:
01713 t = ALLOC(Addrblock);
01714 t->tag = TADDR;
01715
01716 t->vclass = p->vclass;
01717 t->vtype = p->vtype;
01718 t->vstg = p->vstg;
01719 t->memno = p->vardesc.varno;
01720 t->memoffset = ICON(p->voffset);
01721 if (p->vdim)
01722 t->isarray = 1;
01723 if(p->vleng)
01724 {
01725 t->vleng = (expptr) cpexpr(p->vleng);
01726 if( ISICON(t->vleng) )
01727 t->varleng = t->vleng->constblock.Const.ci;
01728 }
01729
01730
01731
01732 t -> uname_tag = UNAM_NAME;
01733 t -> user.name = p;
01734 return(t);
01735
01736 case STGINTR:
01737
01738 return ( intraddr (p));
01739
01740 case STGSTFUNCT:
01741
01742 errstr("invalid use of statement function %.64s.", p->fvarname);
01743 return putconst((Constp)ICON(0));
01744 }
01745 badstg("mkaddr", p->vstg);
01746 return 0;
01747 }
01748
01749
01750
01751
01752
01753
01754
01755
01756 Addrp
01757 #ifdef KR_headers
01758 mkarg(type, argno)
01759 int type;
01760 int argno;
01761 #else
01762 mkarg(int type, int argno)
01763 #endif
01764 {
01765 register Addrp p;
01766
01767 p = ALLOC(Addrblock);
01768 p->tag = TADDR;
01769 p->vtype = type;
01770 p->vclass = CLVAR;
01771
01772
01773
01774 p->vstg = (type==TYLENG ? STGLENG : STGARG);
01775 p->memno = argno;
01776 return(p);
01777 }
01778
01779
01780
01781
01782
01783
01784
01785
01786
01787
01788 expptr
01789 #ifdef KR_headers
01790 mkprim(v0, args, substr)
01791 Namep v0;
01792 struct Listblock *args;
01793 chainp substr;
01794 #else
01795 mkprim(Namep v0, struct Listblock *args, chainp substr)
01796 #endif
01797 {
01798 typedef union {
01799 struct Paramblock paramblock;
01800 struct Nameblock nameblock;
01801 struct Headblock headblock;
01802 } *Primu;
01803 register Primu v = (Primu)v0;
01804 register struct Primblock *p;
01805
01806 if(v->headblock.vclass == CLPARAM)
01807 {
01808
01809
01810
01811 if(args || substr)
01812 {
01813 errstr("no qualifiers on parameter name %s",
01814 v->paramblock.fvarname);
01815 frexpr((expptr)args);
01816 if(substr)
01817 {
01818 frexpr((tagptr)substr->datap);
01819 frexpr((tagptr)substr->nextp->datap);
01820 frchain(&substr);
01821 }
01822 frexpr((expptr)v);
01823 return( errnode() );
01824 }
01825 return( (expptr) cpexpr(v->paramblock.paramval) );
01826 }
01827
01828 p = ALLOC(Primblock);
01829 p->tag = TPRIM;
01830 p->vtype = v->nameblock.vtype;
01831
01832
01833
01834 p->namep = (Namep) v;
01835 p->argsp = args;
01836 if(substr)
01837 {
01838 p->fcharp = (expptr) substr->datap;
01839 p->lcharp = (expptr) substr->nextp->datap;
01840 frchain(&substr);
01841 }
01842 return( (expptr) p);
01843 }
01844
01845
01846
01847
01848
01849
01850
01851 void
01852 #ifdef KR_headers
01853 vardcl(v)
01854 register Namep v;
01855 #else
01856 vardcl(register Namep v)
01857 #endif
01858 {
01859 struct Dimblock *t;
01860 expptr neltp;
01861 extern int doing_stmtfcn;
01862
01863 if(v->vclass == CLUNKNOWN) {
01864 v->vclass = CLVAR;
01865 if (v->vinftype) {
01866 v->vtype = TYUNKNOWN;
01867 if (v->vdcldone) {
01868 v->vdcldone = 0;
01869 impldcl(v);
01870 }
01871 }
01872 }
01873 if(v->vdcldone)
01874 return;
01875 if(v->vclass == CLNAMELIST)
01876 return;
01877
01878 if(v->vtype == TYUNKNOWN)
01879 impldcl(v);
01880 else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
01881 {
01882 dclerr("used as variable", v);
01883 return;
01884 }
01885 if(v->vstg==STGUNKNOWN) {
01886 if (doing_stmtfcn) {
01887
01888
01889
01890 v->vimpldovar = 1;
01891 return;
01892 }
01893 v->vstg = implstg[ letter(v->fvarname[0]) ];
01894 v->vimplstg = 1;
01895 }
01896
01897
01898
01899
01900 switch(v->vstg)
01901 {
01902 case STGBSS:
01903 v->vardesc.varno = ++lastvarno;
01904 break;
01905 case STGAUTO:
01906 if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
01907 break;
01908 if(t = v->vdim)
01909 if( (neltp = t->nelt) && ISCONST(neltp) ) ;
01910 else
01911 dclerr("adjustable automatic array", v);
01912 break;
01913
01914 default:
01915 break;
01916 }
01917 v->vdcldone = YES;
01918 }
01919
01920
01921
01922
01923
01924
01925 void
01926 #ifdef KR_headers
01927 impldcl(p)
01928 register Namep p;
01929 #else
01930 impldcl(register Namep p)
01931 #endif
01932 {
01933 register int k;
01934 int type;
01935 ftnint leng;
01936
01937 if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
01938 return;
01939 if(p->vtype == TYUNKNOWN)
01940 {
01941 k = letter(p->fvarname[0]);
01942 type = impltype[ k ];
01943 leng = implleng[ k ];
01944 if(type == TYUNKNOWN)
01945 {
01946 if(p->vclass == CLPROC)
01947 return;
01948 dclerr("attempt to use undefined variable", p);
01949 type = dflttype[k];
01950 leng = 0;
01951 }
01952 settype(p, type, leng);
01953 p->vimpltype = 1;
01954 }
01955 }
01956
01957 void
01958 #ifdef KR_headers
01959 inferdcl(np, type)
01960 Namep np;
01961 int type;
01962 #else
01963 inferdcl(Namep np, int type)
01964 #endif
01965 {
01966 int k = impltype[letter(np->fvarname[0])];
01967 if (k != type) {
01968 np->vinftype = 1;
01969 np->vtype = type;
01970 frexpr(np->vleng);
01971 np->vleng = 0;
01972 }
01973 np->vimpltype = 0;
01974 np->vinfproc = 1;
01975 }
01976
01977 LOCAL int
01978 #ifdef KR_headers
01979 zeroconst(e)
01980 expptr e;
01981 #else
01982 zeroconst(expptr e)
01983 #endif
01984 {
01985 register Constp c = (Constp) e;
01986 if (c->tag == TCONST)
01987 switch(c->vtype) {
01988 case TYINT1:
01989 case TYSHORT:
01990 case TYLONG:
01991 #ifdef TYQUAD
01992 case TYQUAD:
01993 #endif
01994 return c->Const.ci == 0;
01995
01996 case TYREAL:
01997 case TYDREAL:
01998 if (c->vstg == 1)
01999 return !strcmp(c->Const.cds[0],"0.");
02000 return c->Const.cd[0] == 0.;
02001
02002 case TYCOMPLEX:
02003 case TYDCOMPLEX:
02004 if (c->vstg == 1)
02005 return !strcmp(c->Const.cds[0],"0.")
02006 && !strcmp(c->Const.cds[1],"0.");
02007 return c->Const.cd[0] == 0. && c->Const.cd[1] == 0.;
02008 }
02009 return 0;
02010 }
02011
02012
02013 #define ICONEQ(z, c) (ISICON(z) && z->constblock.Const.ci==c)
02014 #define COMMUTE { e = lp; lp = rp; rp = e; }
02015
02016
02017
02018
02019
02020 expptr
02021 #ifdef KR_headers
02022 mkexpr(opcode, lp, rp)
02023 int opcode;
02024 register expptr lp;
02025 register expptr rp;
02026 #else
02027 mkexpr(int opcode, register expptr lp, register expptr rp)
02028 #endif
02029 {
02030 register expptr e, e1;
02031 int etype;
02032 int ltype, rtype;
02033 int ltag, rtag;
02034 long L;
02035 static long divlineno;
02036
02037 ltype = lp->headblock.vtype;
02038 ltag = lp->tag;
02039 if(rp && opcode!=OPCALL && opcode!=OPCCALL)
02040 {
02041 rtype = rp->headblock.vtype;
02042 rtag = rp->tag;
02043 }
02044 else rtype = 0;
02045
02046 etype = cktype(opcode, ltype, rtype);
02047 if(etype == TYERROR)
02048 goto error;
02049
02050 switch(opcode)
02051 {
02052
02053
02054 case OPSTAR:
02055 if( ISCONST(lp) )
02056 COMMUTE
02057
02058 if( ISICON(rp) )
02059 {
02060 if(rp->constblock.Const.ci == 0)
02061 goto retright;
02062 goto mulop;
02063 }
02064 break;
02065
02066 case OPSLASH:
02067 case OPMOD:
02068 if( zeroconst(rp) && lineno != divlineno ) {
02069 warn("attempted division by zero");
02070 divlineno = lineno;
02071 }
02072 if(opcode == OPMOD)
02073 break;
02074
02075
02076
02077 mulop:
02078 if( ISICON(rp) )
02079 {
02080 if(rp->constblock.Const.ci == 1)
02081 goto retleft;
02082
02083 if(rp->constblock.Const.ci == -1)
02084 {
02085 frexpr(rp);
02086 return( mkexpr(OPNEG, lp, ENULL) );
02087 }
02088 }
02089
02090
02091
02092
02093
02094
02095
02096 if (!ISINT(etype) || lp->tag != TEXPR || !lp->exprblock.rightp
02097 || !ISICON(lp->exprblock.rightp))
02098 break;
02099
02100 if (lp->exprblock.opcode == OPLSHIFT) {
02101 L = 1 << lp->exprblock.rightp->constblock.Const.ci;
02102 if (opcode == OPSTAR || ISICON(rp) &&
02103 !(L % rp->constblock.Const.ci)) {
02104 lp->exprblock.opcode = OPSTAR;
02105 lp->exprblock.rightp->constblock.Const.ci = L;
02106 }
02107 }
02108
02109 if (lp->exprblock.opcode == OPSTAR) {
02110 if(opcode == OPSTAR)
02111 e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
02112 else if(ISICON(rp) &&
02113 (lp->exprblock.rightp->constblock.Const.ci %
02114 rp->constblock.Const.ci) == 0)
02115 e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
02116 else break;
02117
02118 e1 = lp->exprblock.leftp;
02119 free( (charptr) lp );
02120 return( mkexpr(OPSTAR, e1, e) );
02121 }
02122 break;
02123
02124
02125 case OPPLUS:
02126 if( ISCONST(lp) )
02127 COMMUTE
02128 goto addop;
02129
02130 case OPMINUS:
02131 if( ICONEQ(lp, 0) )
02132 {
02133 frexpr(lp);
02134 return( mkexpr(OPNEG, rp, ENULL) );
02135 }
02136
02137 if( ISCONST(rp) && is_negatable((Constp)rp))
02138 {
02139 opcode = OPPLUS;
02140 consnegop((Constp)rp);
02141 }
02142
02143
02144
02145
02146
02147
02148
02149 addop:
02150 if( ISICON(rp) )
02151 {
02152 if(rp->constblock.Const.ci == 0)
02153 goto retleft;
02154 if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
02155 {
02156 e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
02157 e1 = lp->exprblock.leftp;
02158 free( (charptr) lp );
02159 return( mkexpr(OPPLUS, e1, e) );
02160 }
02161 }
02162 if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
02163
02164 if (lp->tag == TPRIM)
02165 e = lp;
02166 else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
02167 && lp->exprblock.rightp->tag == TCONST) {
02168 e = lp->exprblock.leftp;
02169 if (e->tag != TPRIM)
02170 break;
02171 }
02172 else
02173 break;
02174 if (e->primblock.argsp)
02175 break;
02176 if (rp->tag == TPRIM)
02177 e1 = rp;
02178 else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
02179 && rp->exprblock.rightp->tag == TCONST) {
02180 e1 = rp->exprblock.leftp;
02181 if (e1->tag != TPRIM)
02182 break;
02183 }
02184 else
02185 break;
02186 if (e->primblock.namep != e1->primblock.namep
02187 || e1->primblock.argsp)
02188 break;
02189 L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
02190 if (e1 != rp)
02191 L -= rp->exprblock.rightp->constblock.Const.ci;
02192 frexpr(lp);
02193 frexpr(rp);
02194 return ICON(L);
02195 }
02196
02197 break;
02198
02199
02200 case OPPOWER:
02201 break;
02202
02203
02204
02205 case OPNEG:
02206 case OPNEG1:
02207 if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
02208 {
02209 e = lp->exprblock.leftp;
02210 free( (charptr) lp );
02211 return(e);
02212 }
02213 break;
02214
02215
02216
02217 case OPNOT:
02218 if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
02219 {
02220 e = lp->exprblock.leftp;
02221 free( (charptr) lp );
02222 return(e);
02223 }
02224 break;
02225
02226 case OPCALL:
02227 case OPCCALL:
02228 etype = ltype;
02229 if(rp!=NULL && rp->listblock.listp==NULL)
02230 {
02231 free( (charptr) rp );
02232 rp = NULL;
02233 }
02234 break;
02235
02236 case OPAND:
02237 case OPOR:
02238 if( ISCONST(lp) )
02239 COMMUTE
02240
02241 if( ISCONST(rp) )
02242 {
02243 if(rp->constblock.Const.ci == 0)
02244 if(opcode == OPOR)
02245 goto retleft;
02246 else
02247 goto retright;
02248 else if(opcode == OPOR)
02249 goto retright;
02250 else
02251 goto retleft;
02252 }
02253 case OPEQV:
02254 case OPNEQV:
02255
02256 case OPBITAND:
02257 case OPBITOR:
02258 case OPBITXOR:
02259 case OPBITNOT:
02260 case OPLSHIFT:
02261 case OPRSHIFT:
02262 case OPBITTEST:
02263 case OPBITCLR:
02264 case OPBITSET:
02265 #ifdef TYQUAD
02266 case OPQBITCLR:
02267 case OPQBITSET:
02268 #endif
02269
02270 case OPLT:
02271 case OPGT:
02272 case OPLE:
02273 case OPGE:
02274 case OPEQ:
02275 case OPNE:
02276
02277 case OPCONCAT:
02278 break;
02279 case OPMIN:
02280 case OPMAX:
02281 case OPMIN2:
02282 case OPMAX2:
02283 case OPDMIN:
02284 case OPDMAX:
02285
02286 case OPASSIGN:
02287 case OPASSIGNI:
02288 case OPPLUSEQ:
02289 case OPSTAREQ:
02290 case OPMINUSEQ:
02291 case OPSLASHEQ:
02292 case OPMODEQ:
02293 case OPLSHIFTEQ:
02294 case OPRSHIFTEQ:
02295 case OPBITANDEQ:
02296 case OPBITXOREQ:
02297 case OPBITOREQ:
02298
02299 case OPCONV:
02300 case OPADDR:
02301 case OPWHATSIN:
02302
02303 case OPCOMMA:
02304 case OPCOMMA_ARG:
02305 case OPQUEST:
02306 case OPCOLON:
02307 case OPDOT:
02308 case OPARROW:
02309 case OPIDENTITY:
02310 case OPCHARCAST:
02311 case OPABS:
02312 case OPDABS:
02313 break;
02314
02315 default:
02316 badop("mkexpr", opcode);
02317 }
02318
02319 e = (expptr) ALLOC(Exprblock);
02320 e->exprblock.tag = TEXPR;
02321 e->exprblock.opcode = opcode;
02322 e->exprblock.vtype = etype;
02323 e->exprblock.leftp = lp;
02324 e->exprblock.rightp = rp;
02325 if(ltag==TCONST && (rp==0 || rtag==TCONST) )
02326 e = fold(e);
02327 return(e);
02328
02329 retleft:
02330 frexpr(rp);
02331 if (lp->tag == TPRIM)
02332 lp->primblock.parenused = 1;
02333 return(lp);
02334
02335 retright:
02336 frexpr(lp);
02337 if (rp->tag == TPRIM)
02338 rp->primblock.parenused = 1;
02339 return(rp);
02340
02341 error:
02342 frexpr(lp);
02343 if(rp && opcode!=OPCALL && opcode!=OPCCALL)
02344 frexpr(rp);
02345 return( errnode() );
02346 }
02347
02348 #define ERR(s) { errs = s; goto error; }
02349
02350
02351
02352 #ifdef KR_headers
02353 cktype(op, lt, rt)
02354 register int op;
02355 register int lt;
02356 register int rt;
02357 #else
02358 cktype(register int op, register int lt, register int rt)
02359 #endif
02360 {
02361 char *errs;
02362
02363 if(lt==TYERROR || rt==TYERROR)
02364 goto error1;
02365
02366 if(lt==TYUNKNOWN)
02367 return(TYUNKNOWN);
02368 if(rt==TYUNKNOWN)
02369
02370
02371
02372 if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
02373 return(TYUNKNOWN);
02374
02375 switch(op)
02376 {
02377 case OPPLUS:
02378 case OPMINUS:
02379 case OPSTAR:
02380 case OPSLASH:
02381 case OPPOWER:
02382 case OPMOD:
02383 if( ISNUMERIC(lt) && ISNUMERIC(rt) )
02384 return( maxtype(lt, rt) );
02385 ERR("nonarithmetic operand of arithmetic operator")
02386
02387 case OPNEG:
02388 case OPNEG1:
02389 if( ISNUMERIC(lt) )
02390 return(lt);
02391 ERR("nonarithmetic operand of negation")
02392
02393 case OPNOT:
02394 if(ISLOGICAL(lt))
02395 return(lt);
02396 ERR("NOT of nonlogical")
02397
02398 case OPAND:
02399 case OPOR:
02400 case OPEQV:
02401 case OPNEQV:
02402 if(ISLOGICAL(lt) && ISLOGICAL(rt))
02403 return( maxtype(lt, rt) );
02404 ERR("nonlogical operand of logical operator")
02405
02406 case OPLT:
02407 case OPGT:
02408 case OPLE:
02409 case OPGE:
02410 case OPEQ:
02411 case OPNE:
02412 if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
02413 {
02414 if(lt != rt){
02415 if (htype
02416 && (lt == TYCHAR && ISNUMERIC(rt)
02417 || rt == TYCHAR && ISNUMERIC(lt)))
02418 return TYLOGICAL;
02419 ERR("illegal comparison")
02420 }
02421 }
02422
02423 else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
02424 {
02425 if(op!=OPEQ && op!=OPNE)
02426 ERR("order comparison of complex data")
02427 }
02428
02429 else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
02430 ERR("comparison of nonarithmetic data")
02431 case OPBITTEST:
02432 return(TYLOGICAL);
02433
02434 case OPCONCAT:
02435 if(lt==TYCHAR && rt==TYCHAR)
02436 return(TYCHAR);
02437 ERR("concatenation of nonchar data")
02438
02439 case OPCALL:
02440 case OPCCALL:
02441 case OPIDENTITY:
02442 return(lt);
02443
02444 case OPADDR:
02445 case OPCHARCAST:
02446 return(TYADDR);
02447
02448 case OPCONV:
02449 if(rt == 0)
02450 return(0);
02451 if(lt==TYCHAR && ISINT(rt) )
02452 return(TYCHAR);
02453 if (ISLOGICAL(lt) && ISLOGICAL(rt))
02454 return lt;
02455 case OPASSIGN:
02456 case OPASSIGNI:
02457 case OPMINUSEQ:
02458 case OPPLUSEQ:
02459 case OPSTAREQ:
02460 case OPSLASHEQ:
02461 case OPMODEQ:
02462 case OPLSHIFTEQ:
02463 case OPRSHIFTEQ:
02464 case OPBITANDEQ:
02465 case OPBITXOREQ:
02466 case OPBITOREQ:
02467 if( ISINT(lt) && rt==TYCHAR)
02468 return(lt);
02469 if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN)
02470 return lt;
02471 if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
02472 if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
02473 || (lt!=rt))
02474 {
02475 ERR("impossible conversion")
02476 }
02477 return(lt);
02478
02479 case OPMIN:
02480 case OPMAX:
02481 case OPDMIN:
02482 case OPDMAX:
02483 case OPMIN2:
02484 case OPMAX2:
02485 case OPBITOR:
02486 case OPBITAND:
02487 case OPBITXOR:
02488 case OPBITNOT:
02489 case OPLSHIFT:
02490 case OPRSHIFT:
02491 case OPWHATSIN:
02492 case OPABS:
02493 case OPDABS:
02494 return(lt);
02495
02496 case OPBITCLR:
02497 case OPBITSET:
02498 if (lt < TYLONG)
02499 lt = TYLONG;
02500 return(lt);
02501 #ifdef TYQUAD
02502 case OPQBITCLR:
02503 case OPQBITSET:
02504 return TYQUAD;
02505 #endif
02506
02507 case OPCOMMA:
02508 case OPCOMMA_ARG:
02509 case OPQUEST:
02510 case OPCOLON:
02511
02512
02513 return(rt);
02514
02515 case OPDOT:
02516 case OPARROW:
02517 return (lt);
02518 default:
02519 badop("cktype", op);
02520 }
02521 error:
02522 err(errs);
02523 error1:
02524 return(TYERROR);
02525 }
02526
02527 static void
02528 intovfl(Void)
02529 { err("overflow simplifying integer constants."); }
02530
02531
02532
02533
02534 expptr
02535 #ifdef KR_headers
02536 fold(e)
02537 register expptr e;
02538 #else
02539 fold(register expptr e)
02540 #endif
02541 {
02542 Constp p;
02543 register expptr lp, rp;
02544 int etype, mtype, ltype, rtype, opcode;
02545 int i, bl, ll, lr;
02546 char *q, *s;
02547 struct Constblock lcon, rcon;
02548 ftnint L;
02549 double d;
02550
02551 opcode = e->exprblock.opcode;
02552 etype = e->exprblock.vtype;
02553
02554 lp = e->exprblock.leftp;
02555 ltype = lp->headblock.vtype;
02556 rp = e->exprblock.rightp;
02557
02558 if(rp == 0)
02559 switch(opcode)
02560 {
02561 case OPNOT:
02562 lp->constblock.Const.ci = ! lp->constblock.Const.ci;
02563 retlp:
02564 e->exprblock.leftp = 0;
02565 frexpr(e);
02566 return(lp);
02567
02568 case OPBITNOT:
02569 lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
02570 goto retlp;
02571
02572 case OPNEG:
02573 case OPNEG1:
02574 consnegop((Constp)lp);
02575 goto retlp;
02576
02577 case OPCONV:
02578 case OPADDR:
02579 return(e);
02580
02581 case OPABS:
02582 case OPDABS:
02583 switch(ltype) {
02584 case TYINT1:
02585 case TYSHORT:
02586 case TYLONG:
02587 #ifdef TYQUAD
02588 case TYQUAD:
02589 #endif
02590 if ((L = lp->constblock.Const.ci) < 0) {
02591 lp->constblock.Const.ci = -L;
02592 if (L != -lp->constblock.Const.ci)
02593 intovfl();
02594 }
02595 goto retlp;
02596 case TYREAL:
02597 case TYDREAL:
02598 if (lp->constblock.vstg) {
02599 s = lp->constblock.Const.cds[0];
02600 if (*s == '-')
02601 lp->constblock.Const.cds[0] = s + 1;
02602 goto retlp;
02603 }
02604 if ((d = lp->constblock.Const.cd[0]) < 0.)
02605 lp->constblock.Const.cd[0] = -d;
02606 case TYCOMPLEX:
02607 case TYDCOMPLEX:
02608 return e;
02609 }
02610 default:
02611 badop("fold", opcode);
02612 }
02613
02614 rtype = rp->headblock.vtype;
02615
02616 p = ALLOC(Constblock);
02617 p->tag = TCONST;
02618 p->vtype = etype;
02619 p->vleng = e->exprblock.vleng;
02620
02621 switch(opcode)
02622 {
02623 case OPCOMMA:
02624 case OPCOMMA_ARG:
02625 case OPQUEST:
02626 case OPCOLON:
02627 goto ereturn;
02628
02629 case OPAND:
02630 p->Const.ci = lp->constblock.Const.ci &&
02631 rp->constblock.Const.ci;
02632 break;
02633
02634 case OPOR:
02635 p->Const.ci = lp->constblock.Const.ci ||
02636 rp->constblock.Const.ci;
02637 break;
02638
02639 case OPEQV:
02640 p->Const.ci = lp->constblock.Const.ci ==
02641 rp->constblock.Const.ci;
02642 break;
02643
02644 case OPNEQV:
02645 p->Const.ci = lp->constblock.Const.ci !=
02646 rp->constblock.Const.ci;
02647 break;
02648
02649 case OPBITAND:
02650 p->Const.ci = lp->constblock.Const.ci &
02651 rp->constblock.Const.ci;
02652 break;
02653
02654 case OPBITOR:
02655 p->Const.ci = lp->constblock.Const.ci |
02656 rp->constblock.Const.ci;
02657 break;
02658
02659 case OPBITXOR:
02660 p->Const.ci = lp->constblock.Const.ci ^
02661 rp->constblock.Const.ci;
02662 break;
02663
02664 case OPLSHIFT:
02665 p->Const.ci = lp->constblock.Const.ci <<
02666 rp->constblock.Const.ci;
02667 if ((((unsigned long)p->Const.ci) >> rp->constblock.Const.ci)
02668 != lp->constblock.Const.ci)
02669 intovfl();
02670 break;
02671
02672 case OPRSHIFT:
02673 p->Const.ci = (unsigned long)lp->constblock.Const.ci >>
02674 rp->constblock.Const.ci;
02675 break;
02676
02677 case OPBITTEST:
02678 p->Const.ci = (lp->constblock.Const.ci &
02679 1L << rp->constblock.Const.ci) != 0;
02680 break;
02681
02682 case OPBITCLR:
02683 p->Const.ci = lp->constblock.Const.ci &
02684 ~(1L << rp->constblock.Const.ci);
02685 break;
02686
02687 case OPBITSET:
02688 p->Const.ci = lp->constblock.Const.ci |
02689 1L << rp->constblock.Const.ci;
02690 break;
02691
02692 case OPCONCAT:
02693 ll = lp->constblock.vleng->constblock.Const.ci;
02694 lr = rp->constblock.vleng->constblock.Const.ci;
02695 bl = lp->constblock.Const.ccp1.blanks;
02696 p->Const.ccp = q = (char *) ckalloc(ll+lr+bl);
02697 p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks;
02698 p->vleng = ICON(ll+lr+bl);
02699 s = lp->constblock.Const.ccp;
02700 for(i = 0 ; i < ll ; ++i)
02701 *q++ = *s++;
02702 for(i = 0 ; i < bl ; i++)
02703 *q++ = ' ';
02704 s = rp->constblock.Const.ccp;
02705 for(i = 0; i < lr; ++i)
02706 *q++ = *s++;
02707 break;
02708
02709
02710 case OPPOWER:
02711 if( !ISINT(rtype)
02712 || rp->constblock.Const.ci < 0 && zeroconst(lp))
02713 goto ereturn;
02714 conspower(p, (Constp)lp, rp->constblock.Const.ci);
02715 break;
02716
02717 case OPSLASH:
02718 if (zeroconst(rp))
02719 goto ereturn;
02720
02721
02722 default:
02723 if(ltype == TYCHAR)
02724 {
02725 lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
02726 rp->constblock.Const.ccp,
02727 lp->constblock.vleng->constblock.Const.ci,
02728 rp->constblock.vleng->constblock.Const.ci);
02729 rcon.Const.ci = 0;
02730 mtype = tyint;
02731 }
02732 else {
02733 mtype = maxtype(ltype, rtype);
02734 consconv(mtype, &lcon, &lp->constblock);
02735 consconv(mtype, &rcon, &rp->constblock);
02736 }
02737 consbinop(opcode, mtype, p, &lcon, &rcon);
02738 break;
02739 }
02740
02741 frexpr(e);
02742 return( (expptr) p );
02743 ereturn:
02744 free((char *)p);
02745 return e;
02746 }
02747
02748
02749
02750
02751
02752 void
02753 #ifdef KR_headers
02754 consconv(lt, lc, rc)
02755 int lt;
02756 register Constp lc;
02757 register Constp rc;
02758 #else
02759 consconv(int lt, register Constp lc, register Constp rc)
02760 #endif
02761 {
02762 int rt = rc->vtype;
02763 register union Constant *lv = &lc->Const, *rv = &rc->Const;
02764
02765 lc->vtype = lt;
02766 if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
02767 memcpy((char *)lv, (char *)rv, sizeof(union Constant));
02768 lc->vstg = rc->vstg;
02769 if (ISCOMPLEX(lt) && ISREAL(rt)) {
02770 if (rc->vstg)
02771 lv->cds[1] = cds("0",CNULL);
02772 else
02773 lv->cd[1] = 0.;
02774 }
02775 return;
02776 }
02777 lc->vstg = 0;
02778
02779 switch(lt)
02780 {
02781
02782
02783
02784
02785 case TYCHAR:
02786 *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
02787 lv->ccp1.blanks = 0;
02788 break;
02789
02790 case TYINT1:
02791 case TYSHORT:
02792 case TYLONG:
02793 #ifdef TYQUAD
02794 case TYQUAD:
02795 #endif
02796 if(rt == TYCHAR)
02797 lv->ci = rv->ccp[0];
02798 else if( ISINT(rt) )
02799 lv->ci = rv->ci;
02800 else lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];
02801
02802 break;
02803
02804 case TYCOMPLEX:
02805 case TYDCOMPLEX:
02806 lv->cd[1] = 0.;
02807 lv->cd[0] = rv->ci;
02808 break;
02809
02810 case TYREAL:
02811 case TYDREAL:
02812 lv->cd[0] = rv->ci;
02813 break;
02814
02815 case TYLOGICAL:
02816 case TYLOGICAL1:
02817 case TYLOGICAL2:
02818 lv->ci = rv->ci;
02819 break;
02820 }
02821 }
02822
02823
02824
02825
02826
02827 void
02828 #ifdef KR_headers
02829 consnegop(p)
02830 register Constp p;
02831 #else
02832 consnegop(register Constp p)
02833 #endif
02834 {
02835 register char *s;
02836 ftnint L;
02837
02838 if (p->vstg) {
02839 if (ISCOMPLEX(p->vtype)) {
02840 s = p->Const.cds[1];
02841 p->Const.cds[1] = *s == '-' ? s+1
02842 : *s == '0' ? s : s-1;
02843 }
02844 s = p->Const.cds[0];
02845 p->Const.cds[0] = *s == '-' ? s+1
02846 : *s == '0' ? s : s-1;
02847 return;
02848 }
02849 switch(p->vtype)
02850 {
02851 case TYINT1:
02852 case TYSHORT:
02853 case TYLONG:
02854 #ifdef TYQUAD
02855 case TYQUAD:
02856 #endif
02857 p->Const.ci = -(L = p->Const.ci);
02858 if (L != -p->Const.ci)
02859 intovfl();
02860 break;
02861
02862 case TYCOMPLEX:
02863 case TYDCOMPLEX:
02864 p->Const.cd[1] = - p->Const.cd[1];
02865
02866 case TYREAL:
02867 case TYDREAL:
02868 p->Const.cd[0] = - p->Const.cd[0];
02869 break;
02870 default:
02871 badtype("consnegop", p->vtype);
02872 }
02873 }
02874
02875
02876
02877
02878
02879 LOCAL void
02880 #ifdef KR_headers
02881 conspower(p, ap, n)
02882 Constp p;
02883 Constp ap;
02884 ftnint n;
02885 #else
02886 conspower(Constp p, Constp ap, ftnint n)
02887 #endif
02888 {
02889 register union Constant *powp = &p->Const;
02890 register int type;
02891 struct Constblock x, x0;
02892
02893 if (n == 1) {
02894 memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
02895 return;
02896 }
02897
02898 switch(type = ap->vtype)
02899 {
02900 case TYINT1:
02901 case TYSHORT:
02902 case TYLONG:
02903 #ifdef TYQUAD
02904 case TYQUAD:
02905 #endif
02906 powp->ci = 1;
02907 break;
02908 case TYCOMPLEX:
02909 case TYDCOMPLEX:
02910 powp->cd[1] = 0;
02911 case TYREAL:
02912 case TYDREAL:
02913 powp->cd[0] = 1;
02914 break;
02915 default:
02916 badtype("conspower", type);
02917 }
02918
02919 if(n == 0)
02920 return;
02921 switch(type)
02922 {
02923 case TYINT1:
02924 case TYSHORT:
02925 case TYLONG:
02926 #ifdef TYQUAD
02927 case TYQUAD:
02928 #endif
02929 x0.Const.ci = ap->Const.ci;
02930 break;
02931 case TYCOMPLEX:
02932 case TYDCOMPLEX:
02933 x0.Const.cd[1] =
02934 ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
02935 case TYREAL:
02936 case TYDREAL:
02937 x0.Const.cd[0] =
02938 ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
02939 break;
02940 }
02941 x0.vtype = type;
02942 x0.vstg = 0;
02943 if(n < 0)
02944 {
02945 n = -n;
02946 if( ISINT(type) )
02947 {
02948 switch(ap->Const.ci) {
02949 case 0:
02950 err("0 ** negative number");
02951 return;
02952 case 1:
02953 case -1:
02954 goto mult;
02955 }
02956 err("integer ** negative number");
02957 return;
02958 }
02959 else if (!x0.Const.cd[0]
02960 && (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
02961 err("0.0 ** negative number");
02962 return;
02963 }
02964 consbinop(OPSLASH, type, &x, p, &x0);
02965 }
02966 else
02967 mult: consbinop(OPSTAR, type, &x, p, &x0);
02968
02969 for( ; ; )
02970 {
02971 if(n & 01)
02972 consbinop(OPSTAR, type, p, p, &x);
02973 if(n >>= 1)
02974 consbinop(OPSTAR, type, &x, &x, &x);
02975 else
02976 break;
02977 }
02978 }
02979
02980
02981
02982
02983
02984
02985 LOCAL void
02986 #ifdef KR_headers
02987 consbinop(opcode, type, cpp, app, bpp)
02988 int opcode;
02989 int type;
02990 Constp cpp;
02991 Constp app;
02992 Constp bpp;
02993 #else
02994 consbinop(int opcode, int type, Constp cpp, Constp app, Constp bpp)
02995 #endif
02996 {
02997 register union Constant *ap = &app->Const,
02998 *bp = &bpp->Const,
02999 *cp = &cpp->Const;
03000 int k;
03001 double ad[2], bd[2], temp;
03002 ftnint a, b;
03003
03004 cpp->vstg = 0;
03005
03006 if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
03007 ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
03008 bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
03009 if (ISCOMPLEX(type)) {
03010 ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
03011 bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
03012 }
03013 }
03014 switch(opcode)
03015 {
03016 case OPPLUS:
03017 switch(type)
03018 {
03019 case TYINT1:
03020 case TYSHORT:
03021 case TYLONG:
03022 #ifdef TYQUAD
03023 case TYQUAD:
03024 #endif
03025 cp->ci = ap->ci + bp->ci;
03026 if (ap->ci != cp->ci - bp->ci)
03027 intovfl();
03028 break;
03029 case TYCOMPLEX:
03030 case TYDCOMPLEX:
03031 cp->cd[1] = ad[1] + bd[1];
03032 case TYREAL:
03033 case TYDREAL:
03034 cp->cd[0] = ad[0] + bd[0];
03035 break;
03036 }
03037 break;
03038
03039 case OPMINUS:
03040 switch(type)
03041 {
03042 case TYINT1:
03043 case TYSHORT:
03044 case TYLONG:
03045 #ifdef TYQUAD
03046 case TYQUAD:
03047 #endif
03048 cp->ci = ap->ci - bp->ci;
03049 if (ap->ci != bp->ci + cp->ci)
03050 intovfl();
03051 break;
03052 case TYCOMPLEX:
03053 case TYDCOMPLEX:
03054 cp->cd[1] = ad[1] - bd[1];
03055 case TYREAL:
03056 case TYDREAL:
03057 cp->cd[0] = ad[0] - bd[0];
03058 break;
03059 }
03060 break;
03061
03062 case OPSTAR:
03063 switch(type)
03064 {
03065 case TYINT1:
03066 case TYSHORT:
03067 case TYLONG:
03068 #ifdef TYQUAD
03069 case TYQUAD:
03070 #endif
03071 cp->ci = (a = ap->ci) * (b = bp->ci);
03072 if (a && cp->ci / a != b)
03073 intovfl();
03074 break;
03075 case TYREAL:
03076 case TYDREAL:
03077 cp->cd[0] = ad[0] * bd[0];
03078 break;
03079 case TYCOMPLEX:
03080 case TYDCOMPLEX:
03081 temp = ad[0] * bd[0] - ad[1] * bd[1] ;
03082 cp->cd[1] = ad[0] * bd[1] + ad[1] * bd[0] ;
03083 cp->cd[0] = temp;
03084 break;
03085 }
03086 break;
03087 case OPSLASH:
03088 switch(type)
03089 {
03090 case TYINT1:
03091 case TYSHORT:
03092 case TYLONG:
03093 #ifdef TYQUAD
03094 case TYQUAD:
03095 #endif
03096 cp->ci = ap->ci / bp->ci;
03097 break;
03098 case TYREAL:
03099 case TYDREAL:
03100 cp->cd[0] = ad[0] / bd[0];
03101 break;
03102 case TYCOMPLEX:
03103 case TYDCOMPLEX:
03104 zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
03105 break;
03106 }
03107 break;
03108
03109 case OPMOD:
03110 if( ISINT(type) )
03111 {
03112 cp->ci = ap->ci % bp->ci;
03113 break;
03114 }
03115 else
03116 Fatal("inline mod of noninteger");
03117
03118 case OPMIN2:
03119 case OPDMIN:
03120 switch(type)
03121 {
03122 case TYINT1:
03123 case TYSHORT:
03124 case TYLONG:
03125 #ifdef TYQUAD
03126 case TYQUAD:
03127 #endif
03128 cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
03129 break;
03130 case TYREAL:
03131 case TYDREAL:
03132 cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
03133 break;
03134 default:
03135 Fatal("inline min of exected type");
03136 }
03137 break;
03138
03139 case OPMAX2:
03140 case OPDMAX:
03141 switch(type)
03142 {
03143 case TYINT1:
03144 case TYSHORT:
03145 case TYLONG:
03146 #ifdef TYQUAD
03147 case TYQUAD:
03148 #endif
03149 cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
03150 break;
03151 case TYREAL:
03152 case TYDREAL:
03153 cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
03154 break;
03155 default:
03156 Fatal("inline max of exected type");
03157 }
03158 break;
03159
03160 default:
03161 switch(type)
03162 {
03163 case TYINT1:
03164 case TYSHORT:
03165 case TYLONG:
03166 #ifdef TYQUAD
03167 case TYQUAD:
03168 #endif
03169 if(ap->ci < bp->ci)
03170 k = -1;
03171 else if(ap->ci == bp->ci)
03172 k = 0;
03173 else k = 1;
03174 break;
03175 case TYREAL:
03176 case TYDREAL:
03177 if(ad[0] < bd[0])
03178 k = -1;
03179 else if(ad[0] == bd[0])
03180 k = 0;
03181 else k = 1;
03182 break;
03183 case TYCOMPLEX:
03184 case TYDCOMPLEX:
03185 if(ad[0] == bd[0] &&
03186 ad[1] == bd[1] )
03187 k = 0;
03188 else k = 1;
03189 break;
03190 case TYLOGICAL:
03191 k = ap->ci - bp->ci;
03192 }
03193
03194 switch(opcode)
03195 {
03196 case OPEQ:
03197 cp->ci = (k == 0);
03198 break;
03199 case OPNE:
03200 cp->ci = (k != 0);
03201 break;
03202 case OPGT:
03203 cp->ci = (k == 1);
03204 break;
03205 case OPLT:
03206 cp->ci = (k == -1);
03207 break;
03208 case OPGE:
03209 cp->ci = (k >= 0);
03210 break;
03211 case OPLE:
03212 cp->ci = (k <= 0);
03213 break;
03214 }
03215 break;
03216 }
03217 }
03218
03219
03220
03221
03222
03223 #ifdef KR_headers
03224 conssgn(p)
03225 register expptr p;
03226 #else
03227 conssgn(register expptr p)
03228 #endif
03229 {
03230 register char *s;
03231
03232 if( ! ISCONST(p) )
03233 Fatal( "sgn(nonconstant)" );
03234
03235 switch(p->headblock.vtype)
03236 {
03237 case TYINT1:
03238 case TYSHORT:
03239 case TYLONG:
03240 #ifdef TYQUAD
03241 case TYQUAD:
03242 #endif
03243 if(p->constblock.Const.ci > 0) return(1);
03244 if(p->constblock.Const.ci < 0) return(-1);
03245 return(0);
03246
03247 case TYREAL:
03248 case TYDREAL:
03249 if (p->constblock.vstg) {
03250 s = p->constblock.Const.cds[0];
03251 if (*s == '-')
03252 return -1;
03253 if (*s == '0')
03254 return 0;
03255 return 1;
03256 }
03257 if(p->constblock.Const.cd[0] > 0) return(1);
03258 if(p->constblock.Const.cd[0] < 0) return(-1);
03259 return(0);
03260
03261
03262
03263
03264 case TYCOMPLEX:
03265 case TYDCOMPLEX:
03266 if (p->constblock.vstg)
03267 return *p->constblock.Const.cds[0] != '0'
03268 && *p->constblock.Const.cds[1] != '0';
03269 return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
03270
03271 default:
03272 badtype( "conssgn", p->constblock.vtype);
03273 }
03274 return 0;
03275 }
03276
03277 char *powint[ ] = {
03278 "pow_ii",
03279 #ifdef TYQUAD
03280 "pow_qq",
03281 #endif
03282 "pow_ri", "pow_di", "pow_ci", "pow_zi" };
03283
03284 LOCAL expptr
03285 #ifdef KR_headers
03286 mkpower(p)
03287 register expptr p;
03288 #else
03289 mkpower(register expptr p)
03290 #endif
03291 {
03292 register expptr q, lp, rp;
03293 int ltype, rtype, mtype, tyi;
03294
03295 lp = p->exprblock.leftp;
03296 rp = p->exprblock.rightp;
03297 ltype = lp->headblock.vtype;
03298 rtype = rp->headblock.vtype;
03299
03300 if (lp->tag == TADDR)
03301 lp->addrblock.parenused = 0;
03302
03303 if (rp->tag == TADDR)
03304 rp->addrblock.parenused = 0;
03305
03306 if(ISICON(rp))
03307 {
03308 if(rp->constblock.Const.ci == 0)
03309 {
03310 frexpr(p);
03311 if( ISINT(ltype) )
03312 return( ICON(1) );
03313 else if (ISREAL (ltype))
03314 return mkconv (ltype, ICON (1));
03315 else
03316 return( (expptr) putconst((Constp)
03317 mkconv(ltype, ICON(1))) );
03318 }
03319 if(rp->constblock.Const.ci < 0)
03320 {
03321 if( ISINT(ltype) )
03322 {
03323 frexpr(p);
03324 err("integer**negative");
03325 return( errnode() );
03326 }
03327 rp->constblock.Const.ci = - rp->constblock.Const.ci;
03328 p->exprblock.leftp = lp
03329 = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
03330 }
03331 if(rp->constblock.Const.ci == 1)
03332 {
03333 frexpr(rp);
03334 free( (charptr) p );
03335 return(lp);
03336 }
03337
03338 if( ONEOF(ltype, MSKINT|MSKREAL) ) {
03339 p->exprblock.vtype = ltype;
03340 return(p);
03341 }
03342 }
03343 if( ISINT(rtype) )
03344 {
03345 if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
03346 q = call2(TYSHORT, "pow_hh", lp, rp);
03347 else {
03348 if(ONEOF(ltype,M(TYINT1)|M(TYSHORT)))
03349 {
03350 ltype = TYLONG;
03351 lp = mkconv(TYLONG,lp);
03352 }
03353 #ifdef TYQUAD
03354 if (ltype == TYQUAD)
03355 rp = mkconv(TYQUAD,rp);
03356 else
03357 #endif
03358 rp = mkconv(TYLONG,rp);
03359 if (ISCONST(rp)) {
03360 tyi = tyint;
03361 tyint = TYLONG;
03362 rp = (expptr)putconst((Constp)rp);
03363 tyint = tyi;
03364 }
03365 q = call2(ltype, powint[ltype-TYLONG], lp, rp);
03366 }
03367 }
03368 else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
03369 extern int callk_kludge;
03370 callk_kludge = TYDREAL;
03371 q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
03372 callk_kludge = 0;
03373 }
03374 else {
03375 q = call2(TYDCOMPLEX, "pow_zz",
03376 mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
03377 if(mtype == TYCOMPLEX)
03378 q = mkconv(TYCOMPLEX, q);
03379 }
03380 free( (charptr) p );
03381 return(q);
03382 }
03383
03384
03385
03386
03387
03388
03389 LOCAL void
03390 #ifdef KR_headers
03391 zdiv(c, a, b)
03392 register dcomplex *c;
03393 register dcomplex *a;
03394 register dcomplex *b;
03395 #else
03396 zdiv(register dcomplex *c, register dcomplex *a, register dcomplex *b)
03397 #endif
03398 {
03399 double ratio, den;
03400 double abr, abi;
03401
03402 if( (abr = b->dreal) < 0.)
03403 abr = - abr;
03404 if( (abi = b->dimag) < 0.)
03405 abi = - abi;
03406 if( abr <= abi )
03407 {
03408 if(abi == 0)
03409 Fatal("complex division by zero");
03410 ratio = b->dreal / b->dimag ;
03411 den = b->dimag * (1 + ratio*ratio);
03412 c->dreal = (a->dreal*ratio + a->dimag) / den;
03413 c->dimag = (a->dimag*ratio - a->dreal) / den;
03414 }
03415
03416 else
03417 {
03418 ratio = b->dimag / b->dreal ;
03419 den = b->dreal * (1 + ratio*ratio);
03420 c->dreal = (a->dreal + a->dimag*ratio) / den;
03421 c->dimag = (a->dimag - a->dreal*ratio) / den;
03422 }
03423 }
03424
03425
03426 void
03427 #ifdef KR_headers
03428 sserr(np) Namep np;
03429 #else
03430 sserr(Namep np)
03431 #endif
03432 {
03433 errstr(np->vtype == TYCHAR
03434 ? "substring of character array %.70s"
03435 : "substring of noncharacter %.73s", np->fvarname);
03436 }
