compilers/pcc/pcc-1.0.0/f77/fcom/expr.c

   1 /*      $Id: expr.c,v 1.20 2008/05/11 15:28:03 ragge Exp $      */
   2 /*
   3  * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
   4  *
   5  * Redistribution and use in source and binary forms, with or without
   6  * modification, are permitted provided that the following conditions
   7  * are met:
   8  *
   9  * Redistributions of source code and documentation must retain the above
  10  * copyright notice, this list of conditions and the following disclaimer.
  11  * Redistributions in binary form must reproduce the above copyright
  12  * notice, this list of conditionsand the following disclaimer in the
  13  * documentation and/or other materials provided with the distribution.
  14  * All advertising materials mentioning features or use of this software
  15  * must display the following acknowledgement:
  16  *      This product includes software developed or owned by Caldera
  17  *      International, Inc.
  18  * Neither the name of Caldera International, Inc. nor the names of other
  19  * contributors may be used to endorse or promote products derived from
  20  * this software without specific prior written permission.
  21  *
  22  * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
  23  * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
  24  * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  25  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  26  * DISCLAIMED.  IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
  27  * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  28  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  29  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  30  * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
  31  * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
  32  * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  33  * POSSIBILITY OF SUCH DAMAGE.
  34  */
  35 #include <string.h>
  36
  37 #include "defines.h"
  38 #include "defs.h"
  39
  40 /* little routines to create constant blocks */
  41 LOCAL int letter(int c);
  42 LOCAL void conspower(union constant *, struct bigblock *, ftnint);
  43 LOCAL void consbinop(int, int, union constant *, union constant *,
  44         union constant *);
  45 LOCAL void zdiv(struct dcomplex *, struct dcomplex *, struct dcomplex *);
  46 LOCAL struct bigblock *stfcall(struct bigblock *, struct bigblock *);
  47 LOCAL bigptr mkpower(struct bigblock *p);
  48 LOCAL bigptr fold(struct bigblock *e);
  49 LOCAL bigptr subcheck(struct bigblock *, bigptr);
  50
  51 struct bigblock *mkconst(t)
  52 register int t;
  53 {
  54 register struct bigblock *p;
  55
  56 p = BALLO();
  57 p->tag = TCONST;
  58 p->vtype = t;
  59 return(p);
  60 }
  61
  62
  63 struct bigblock *mklogcon(l)
  64 register int l;
  65 {
  66 register struct bigblock * p;
  67
  68 p = mkconst(TYLOGICAL);
  69 p->b_const.fconst.ci = l;
  70 return(p);
  71 }
  72
  73
  74
  75 struct bigblock *mkintcon(l)
  76 ftnint l;
  77 {
  78 register struct bigblock *p;
  79
  80 p = mkconst(TYLONG);
  81 p->b_const.fconst.ci = l;
  82 #ifdef MAXSHORT
  83         if(l >= -MAXSHORT   &&   l <= MAXSHORT)
  84                 p->vtype = TYSHORT;
  85 #endif
  86 return(p);
  87 }
  88
  89
  90
  91 struct bigblock *mkaddcon(l)
  92 register int l;
  93 {
  94 register struct bigblock *p;
  95
  96 p = mkconst(TYADDR);
  97 p->b_const.fconst.ci = l;
  98 return(p);
  99 }
 100
 101
 102
 103 struct bigblock *mkrealcon(t, d)
 104 register int t;
 105 double d;
 106 {
 107 register struct bigblock *p;
 108
 109 p = mkconst(t);
 110 p->b_const.fconst.cd[0] = d;
 111 return(p);
 112 }
 113
 114
 115 struct bigblock *mkbitcon(shift, leng, s)
 116 int shift;
 117 int leng;
 118 char *s;
 119 {
 120 register struct bigblock *p;
 121
 122 p = mkconst(TYUNKNOWN);
 123 p->b_const.fconst.ci = 0;
 124 while(--leng >= 0)
 125         if(*s != ' ')
 126                 p->b_const.fconst.ci = (p->b_const.fconst.ci << shift) | hextoi(*s++);
 127 return(p);
 128 }
 129
 130
 131
 132
 133
 134 struct bigblock *mkstrcon(l,v)
 135 int l;
 136 register char *v;
 137 {
 138 register struct bigblock *p;
 139 register char *s;
 140
 141 p = mkconst(TYCHAR);
 142 p->vleng = MKICON(l);
 143 p->b_const.fconst.ccp = s = (char *) ckalloc(l);
 144 while(--l >= 0)
 145         *s++ = *v++;
 146 return(p);
 147 }
 148
 149
 150 struct bigblock *mkcxcon(realp,imagp)
 151 register bigptr realp, imagp;
 152 {
 153 int rtype, itype;
 154 register struct bigblock *p;
 155
 156 rtype = realp->vtype;
 157 itype = imagp->vtype;
 158
 159 if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
 160         {
 161         p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX );
 162         if( ISINT(rtype) )
 163                 p->b_const.fconst.cd[0] = realp->b_const.fconst.ci;
 164         else    p->b_const.fconst.cd[0] = realp->b_const.fconst.cd[0];
 165         if( ISINT(itype) )
 166                 p->b_const.fconst.cd[1] = imagp->b_const.fconst.ci;
 167         else    p->b_const.fconst.cd[1] = imagp->b_const.fconst.cd[0];
 168         }
 169 else
 170         {
 171         err("invalid complex constant");
 172         p = errnode();
 173         }
 174
 175 frexpr(realp);
 176 frexpr(imagp);
 177 return(p);
 178 }
 179
 180
 181 struct bigblock *errnode()
 182 {
 183 struct bigblock *p;
 184 p = BALLO();
 185 p->tag = TERROR;
 186 p->vtype = TYERROR;
 187 return(p);
 188 }
 189
 190
 191
 192
 193
 194 bigptr mkconv(t, p)
 195 register int t;
 196 register bigptr p;
 197 {
 198 register bigptr q;
 199
 200 if(t==TYUNKNOWN || t==TYERROR)
 201         fatal1("mkconv of impossible type %d", t);
 202 if(t == p->vtype)
 203         return(p);
 204
 205 else if( ISCONST(p) && p->vtype!=TYADDR)
 206         {
 207         q = mkconst(t);
 208         consconv(t, &(q->b_const.fconst), p->vtype, &(p->b_const.fconst));
 209         frexpr(p);
 210         }
 211 else
 212         {
 213         q = mkexpr(OPCONV, p, 0);
 214         q->vtype = t;
 215         }
 216 return(q);
 217 }
 218
 219
 220
 221 struct bigblock *addrof(p)
 222 bigptr p;
 223 {
 224 return( mkexpr(OPADDR, p, NULL) );
 225 }
 226
 227
 228
 229 bigptr
 230 cpexpr(p)
 231 register bigptr p;
 232 {
 233 register bigptr e;
 234 int tag;
 235 register chainp ep, pp;
 236
 237 #if 0
 238 static int blksize[ ] = { 0, sizeof(struct nameblock), sizeof(struct constblock),
 239                  sizeof(struct exprblock), sizeof(struct addrblock),
 240                  sizeof(struct primblock), sizeof(struct listblock),
 241                  sizeof(struct errorblock)
 242         };
 243 #endif
 244
 245 if(p == NULL)
 246         return(NULL);
 247
 248 if( (tag = p->tag) == TNAME)
 249         return(p);
 250
 251 #if 0
 252 e = cpblock( blksize[p->tag] , p);
 253 #else
 254 e = cpblock( sizeof(struct bigblock) , p);
 255 #endif
 256
 257 switch(tag)
 258         {
 259         case TCONST:
 260                 if(e->vtype == TYCHAR)
 261                         {
 262                         e->b_const.fconst.ccp = copyn(1+strlen(e->b_const.fconst.ccp), e->b_const.fconst.ccp);
 263                         e->vleng = cpexpr(e->vleng);
 264                         }
 265         case TERROR:
 266                 break;
 267
 268         case TEXPR:
 269                 e->b_expr.leftp = cpexpr(p->b_expr.leftp);
 270                 e->b_expr.rightp = cpexpr(p->b_expr.rightp);
 271                 break;
 272
 273         case TLIST:
 274                 if((pp = p->b_list.listp))
 275                         {
 276                         ep = e->b_list.listp = mkchain( cpexpr(pp->chain.datap), NULL);
 277                         for(pp = pp->chain.nextp ; pp ; pp = pp->chain.nextp)
 278                                 ep = ep->chain.nextp = mkchain( cpexpr(pp->chain.datap), NULL);
 279                         }
 280                 break;
 281
 282         case TADDR:
 283                 e->vleng = cpexpr(e->vleng);
 284                 e->b_addr.memoffset = cpexpr(e->b_addr.memoffset);
 285                 e->b_addr.istemp = NO;
 286                 break;
 287
 288         case TPRIM:
 289                 e->b_prim.argsp = cpexpr(e->b_prim.argsp);
 290                 e->b_prim.fcharp = cpexpr(e->b_prim.fcharp);
 291                 e->b_prim.lcharp = cpexpr(e->b_prim.lcharp);
 292                 break;
 293
 294         default:
 295                 fatal1("cpexpr: impossible tag %d", tag);
 296         }
 297
 298 return(e);
 299 }
 300
 301 void
 302 frexpr(p)
 303 register bigptr p;
 304 {
 305 register chainp q;
 306
 307 if(p == NULL)
 308         return;
 309
 310 switch(p->tag)
 311         {
 312         case TCONST:
 313                 if( ISCHAR(p) )
 314                         {
 315                         ckfree(p->b_const.fconst.ccp);
 316                         frexpr(p->vleng);
 317                         }
 318                 break;
 319
 320         case TADDR:
 321                 if(p->b_addr.istemp)
 322                         {
 323                         frtemp(p);
 324                         return;
 325                         }
 326                 frexpr(p->vleng);
 327                 frexpr(p->b_addr.memoffset);
 328                 break;
 329
 330         case TERROR:
 331                 break;
 332
 333         case TNAME:
 334                 return;
 335
 336         case TPRIM:
 337                 frexpr(p->b_prim.argsp);
 338                 frexpr(p->b_prim.fcharp);
 339                 frexpr(p->b_prim.lcharp);
 340                 break;
 341
 342         case TEXPR:
 343                 frexpr(p->b_expr.leftp);
 344                 if(p->b_expr.rightp)
 345                         frexpr(p->b_expr.rightp);
 346                 break;
 347
 348         case TLIST:
 349                 for(q = p->b_list.listp ; q ; q = q->chain.nextp)
 350                         frexpr(q->chain.datap);
 351                 frchain( &(p->b_list.listp) );
 352                 break;
 353
 354         default:
 355                 fatal1("frexpr: impossible tag %d", p->tag);
 356         }
 357
 358 ckfree(p);
 359 }
 360 \f
 361 /* fix up types in expression; replace subtrees and convert
 362    names to address blocks */
 363
 364 bigptr fixtype(p)
 365 register bigptr p;
 366 {
 367
 368 if(p == 0)
 369         return(0);
 370
 371 switch(p->tag)
 372         {
 373         case TCONST:
 374                 if( ! ONEOF(p->vtype, MSKINT|MSKLOGICAL|MSKADDR) )
 375                         p = putconst(p);
 376                 return(p);
 377
 378         case TADDR:
 379                 p->b_addr.memoffset = fixtype(p->b_addr.memoffset);
 380                 return(p);
 381
 382         case TERROR:
 383                 return(p);
 384
 385         default:
 386                 fatal1("fixtype: impossible tag %d", p->tag);
 387
 388         case TEXPR:
 389                 return( fixexpr(p) );
 390
 391         case TLIST:
 392                 return( p );
 393
 394         case TPRIM:
 395                 if(p->b_prim.argsp && p->b_prim.namep->vclass!=CLVAR)
 396                         return( mkfunct(p) );
 397                 else    return( mklhs(p) );
 398         }
 399 }
 400
 401
 402
 403
 404
 405 /* special case tree transformations and cleanups of expression trees */
 406
 407 bigptr fixexpr(p)
 408 register struct bigblock *p;
 409 {
 410 bigptr lp;
 411 register bigptr rp;
 412 register bigptr q;
 413 int opcode, ltype, rtype, ptype, mtype;
 414
 415 if(p->tag == TERROR)
 416         return(p);
 417 else if(p->tag != TEXPR)
 418         fatal1("fixexpr: invalid tag %d", p->tag);
 419 opcode = p->b_expr.opcode;
 420 lp = p->b_expr.leftp = fixtype(p->b_expr.leftp);
 421 ltype = lp->vtype;
 422 if(opcode==OPASSIGN && lp->tag!=TADDR)
 423         {
 424         err("left side of assignment must be variable");
 425         frexpr(p);
 426         return( errnode() );
 427         }
 428
 429 if(p->b_expr.rightp)
 430         {
 431         rp = p->b_expr.rightp = fixtype(p->b_expr.rightp);
 432         rtype = rp->vtype;
 433         }
 434 else
 435         {
 436         rp = NULL;
 437         rtype = 0;
 438         }
 439
 440 /* force folding if possible */
 441 if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
 442         {
 443         q = mkexpr(opcode, lp, rp);
 444         if( ISCONST(q) )
 445                 return(q);
 446         ckfree(q);      /* constants did not fold */
 447         }
 448
 449 if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
 450         {
 451         frexpr(p);
 452         return( errnode() );
 453         }
 454
 455 switch(opcode)
 456         {
 457         case OPCONCAT:
 458                 if(p->vleng == NULL)
 459                         p->vleng = mkexpr(OPPLUS, cpexpr(lp->vleng),
 460                                 cpexpr(rp->vleng) );
 461                 break;
 462
 463         case OPASSIGN:
 464                 if(ltype == rtype)
 465                         break;
 466                 if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
 467                         break;
 468                 if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
 469                         break;
 470                 if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
 471                     && typesize[ltype]>=typesize[rtype] )
 472                         break;
 473                 p->b_expr.rightp = fixtype( mkconv(ptype, rp) );
 474                 break;
 475
 476         case OPSLASH:
 477                 if( ISCOMPLEX(rtype) )
 478                         {
 479                         p = call2(ptype, ptype==TYCOMPLEX? "c_div" : "z_div",
 480                                 mkconv(ptype, lp), mkconv(ptype, rp) );
 481                         break;
 482                         }
 483         case OPPLUS:
 484         case OPMINUS:
 485         case OPSTAR:
 486         case OPMOD:
 487                 if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
 488                     (rtype==TYREAL && ! ISCONST(rp) ) ))
 489                         break;
 490                 if( ISCOMPLEX(ptype) )
 491                         break;
 492                 if(ltype != ptype)
 493                         p->b_expr.leftp = fixtype(mkconv(ptype,lp));
 494                 if(rtype != ptype)
 495                         p->b_expr.rightp = fixtype(mkconv(ptype,rp));
 496                 break;
 497
 498         case OPPOWER:
 499                 return( mkpower(p) );
 500
 501         case OPLT:
 502         case OPLE:
 503         case OPGT:
 504         case OPGE:
 505         case OPEQ:
 506         case OPNE:
 507                 if(ltype == rtype)
 508                         break;
 509                 mtype = cktype(OPMINUS, ltype, rtype);
 510                 if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
 511                     (rtype==TYREAL && ! ISCONST(rp)) ))
 512                         break;
 513                 if( ISCOMPLEX(mtype) )
 514                         break;
 515                 if(ltype != mtype)
 516                         p->b_expr.leftp = fixtype(mkconv(mtype,lp));
 517                 if(rtype != mtype)
 518                         p->b_expr.rightp = fixtype(mkconv(mtype,rp));
 519                 break;
 520
 521
 522         case OPCONV:
 523                 ptype = cktype(OPCONV, p->vtype, ltype);
 524                 if(lp->tag==TEXPR && lp->b_expr.opcode==OPCOMMA)
 525                         {
 526                         lp->b_expr.rightp = fixtype( mkconv(ptype, lp->b_expr.rightp) );
 527                         ckfree(p);
 528                         p = lp;
 529                         }
 530                 break;
 531
 532         case OPADDR:
 533                 if(lp->tag==TEXPR && lp->b_expr.opcode==OPADDR)
 534                         fatal("addr of addr");
 535                 break;
 536
 537         case OPCOMMA:
 538                 break;
 539
 540         case OPMIN:
 541         case OPMAX:
 542                 ptype = p->vtype;
 543                 break;
 544
 545         default:
 546                 break;
 547         }
 548
 549 p->vtype = ptype;
 550 return(p);
 551 }
 552 \f
 553 #if SZINT < SZLONG
 554 /*
 555    for efficient subscripting, replace long ints by shorts
 556    in easy places
 557 */
 558
 559 bigptr shorten(p)
 560 register bigptr p;
 561 {
 562 register bigptr q;
 563
 564 if(p->vtype != TYLONG)
 565         return(p);
 566
 567 switch(p->tag)
 568         {
 569         case TERROR:
 570         case TLIST:
 571                 return(p);
 572
 573         case TCONST:
 574         case TADDR:
 575                 return( mkconv(TYINT,p) );
 576
 577         case TEXPR:
 578                 break;
 579
 580         default:
 581                 fatal1("shorten: invalid tag %d", p->tag);
 582         }
 583
 584 switch(p->opcode)
 585         {
 586         case OPPLUS:
 587         case OPMINUS:
 588         case OPSTAR:
 589                 q = shorten( cpexpr(p->rightp) );
 590                 if(q->vtype == TYINT)
 591                         {
 592                         p->leftp = shorten(p->leftp);
 593                         if(p->leftp->vtype == TYLONG)
 594                                 frexpr(q);
 595                         else
 596                                 {
 597                                 frexpr(p->rightp);
 598                                 p->rightp = q;
 599                                 p->vtype = TYINT;
 600                                 }
 601                         }
 602                 break;
 603
 604         case OPNEG:
 605                 p->leftp = shorten(p->leftp);
 606                 if(p->leftp->vtype == TYINT)
 607                         p->vtype = TYINT;
 608                 break;
 609
 610         case OPCALL:
 611         case OPCCALL:
 612                 p = mkconv(TYINT,p);
 613                 break;
 614         default:
 615                 break;
 616         }
 617
 618 return(p);
 619 }
 620 #endif
 621
 622 int
 623 fixargs(doput, p0)
 624 int doput;
 625 struct bigblock *p0;
 626 {
 627 register chainp p;
 628 register bigptr q, t;
 629 register int qtag;
 630 int nargs;
 631
 632 nargs = 0;
 633 if(p0)
 634     for(p = p0->b_list.listp ; p ; p = p->chain.nextp)
 635         {
 636         ++nargs;
 637         q = p->chain.datap;
 638         qtag = q->tag;
 639         if(qtag == TCONST)
 640                 {
 641                 if(q->vtype == TYSHORT)
 642                         q = mkconv(tyint, q);
 643                 if(doput)
 644                         p->chain.datap = putconst(q);
 645                 else
 646                         p->chain.datap = q;
 647                 }
 648         else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->vclass==CLPROC)
 649                 p->chain.datap = mkaddr(q->b_prim.namep);
 650         else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->b_name.vdim!=NULL)
 651                 p->chain.datap = mkscalar(q->b_prim.namep);
 652         else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->b_name.vdovar &&
 653                 (t = memversion(q->b_prim.namep)) )
 654                         p->chain.datap = fixtype(t);
 655         else    p->chain.datap = fixtype(q);
 656         }
 657 return(nargs);
 658 }
 659
 660 struct bigblock *
 661 mkscalar(np)
 662 register struct bigblock *np;
 663 {
 664 register struct bigblock *ap;
 665
 666 vardcl(np);
 667 ap = mkaddr(np);
 668
 669 #ifdef __vax__
 670         /* on the VAX, prolog causes array arguments
 671            to point at the (0,...,0) element, except when
 672            subscript checking is on
 673         */
 674         if( !checksubs && np->vstg==STGARG)
 675                 {
 676                 register struct dimblock *dp;
 677                 dp = np->vdim;
 678                 frexpr(ap->memoffset);
 679                 ap->memoffset = mkexpr(OPSTAR, MKICON(typesize[np->vtype]),
 680                                         cpexpr(dp->baseoffset) );
 681                 }
 682 #endif
 683 return(ap);
 684 }
 685
 686
 687
 688
 689
 690 bigptr mkfunct(p)
 691 register struct bigblock * p;
 692 {
 693 chainp ep;
 694 struct bigblock *ap;
 695 struct extsym *extp;
 696 register struct bigblock *np;
 697 register struct bigblock *q;
 698 int k, nargs;
 699 int class;
 700
 701 np = p->b_prim.namep;
 702 class = np->vclass;
 703
 704 if(class == CLUNKNOWN)
 705         {
 706         np->vclass = class = CLPROC;
 707         if(np->vstg == STGUNKNOWN)
 708                 {
 709                 if((k = intrfunct(np->b_name.varname)))
 710                         {
 711                         np->vstg = STGINTR;
 712                         np->b_name.vardesc.varno = k;
 713                         np->b_name.vprocclass = PINTRINSIC;
 714                         }
 715                 else
 716                         {
 717                         extp = mkext( varunder(VL,np->b_name.varname) );
 718                         extp->extstg = STGEXT;
 719                         np->vstg = STGEXT;
 720                         np->b_name.vardesc.varno = extp - extsymtab;
 721                         np->b_name.vprocclass = PEXTERNAL;
 722                         }
 723                 }
 724         else if(np->vstg==STGARG)
 725                 {
 726                 if(np->vtype!=TYCHAR && !ftn66flag)
 727                     warn("Dummy procedure not declared EXTERNAL. Code may be wrong.");
 728                 np->b_name.vprocclass = PEXTERNAL;
 729                 }
 730         }
 731
 732 if(class != CLPROC)
 733         fatal1("invalid class code for function", class);
 734 if(p->b_prim.fcharp || p->b_prim.lcharp)
 735         {
 736         err("no substring of function call");
 737         goto error;
 738         }
 739 impldcl(np);
 740 nargs = fixargs( np->b_name.vprocclass!=PINTRINSIC,  p->b_prim.argsp);
 741
 742 switch(np->b_name.vprocclass)
 743         {
 744         case PEXTERNAL:
 745                 ap = mkaddr(np);
 746         call:
 747                 q = mkexpr(OPCALL, ap, p->b_prim.argsp);
 748                 q->vtype = np->vtype;
 749                 if(np->vleng)
 750                         q->vleng = cpexpr(np->vleng);
 751                 break;
 752
 753         case PINTRINSIC:
 754                 q = intrcall(np, p->b_prim.argsp, nargs);
 755                 break;
 756
 757         case PSTFUNCT:
 758                 q = stfcall(np, p->b_prim.argsp);
 759                 break;
 760
 761         case PTHISPROC:
 762                 warn("recursive call");
 763                 for(ep = entries ; ep ; ep = ep->entrypoint.nextp)
 764                         if(ep->entrypoint.enamep == np)
 765                                 break;
 766                 if(ep == NULL)
 767                         fatal("mkfunct: impossible recursion");
 768                 ap = builtin(np->vtype, varstr(XL, ep->entrypoint.entryname->extname) );
 769                 goto call;
 770
 771         default:
 772                 fatal1("mkfunct: impossible vprocclass %d", np->b_name.vprocclass);
 773                 q = 0; /* XXX gcc */
 774         }
 775 ckfree(p);
 776 return(q);
 777
 778 error:
 779         frexpr(p);
 780         return( errnode() );
 781 }
 782
 783
 784
 785 LOCAL struct bigblock *
 786 stfcall(struct bigblock *np, struct bigblock *actlist)
 787 {
 788         register chainp actuals;
 789         int nargs;
 790         chainp oactp, formals;
 791         int type;
 792         struct bigblock *q, *rhs;
 793         bigptr ap;
 794         register chainp rp;
 795         chainp tlist;
 796
 797         if(actlist) {
 798                 actuals = actlist->b_list.listp;
 799                 ckfree(actlist);
 800         } else
 801                 actuals = NULL;
 802         oactp = actuals;
 803
 804         nargs = 0;
 805         tlist = NULL;
 806         type = np->vtype;
 807
 808         formals = (chainp)np->b_name.vardesc.vstfdesc->chain.datap;
 809         rhs = (bigptr)np->b_name.vardesc.vstfdesc->chain.nextp;
 810
 811         /* copy actual arguments into temporaries */
 812         while(actuals!=NULL && formals!=NULL) {
 813                 rp = ALLOC(rplblock);
 814                 rp->rplblock.rplnp = q = formals->chain.datap;
 815                 ap = fixtype(actuals->chain.datap);
 816                 if(q->vtype==ap->vtype && q->vtype!=TYCHAR
 817                    && (ap->tag==TCONST || ap->tag==TADDR) ) {
 818                         rp->rplblock.rplvp = ap;
 819                         rp->rplblock.rplxp = NULL;
 820                         rp->rplblock.rpltag = ap->tag;
 821                 } else  {
 822                         rp->rplblock.rplvp = fmktemp(q->vtype, q->vleng);
 823                         rp->rplblock.rplxp = fixtype( mkexpr(OPASSIGN,
 824                             cpexpr(rp->rplblock.rplvp), ap) );
 825                         if( (rp->rplblock.rpltag =
 826                             rp->rplblock.rplxp->tag) == TERROR)
 827                                 err("disagreement of argument types in statement function call");
 828                 }
 829                 rp->rplblock.nextp = tlist;
 830                 tlist = rp;
 831                 actuals = actuals->chain.nextp;
 832                 formals = formals->chain.nextp;
 833                 ++nargs;
 834         }
 835
 836         if(actuals!=NULL || formals!=NULL)
 837                 err("statement function definition and argument list differ");
 838
 839         /*
 840            now push down names involved in formal argument list, then
 841            evaluate rhs of statement function definition in this environment
 842         */
 843         rpllist = hookup(tlist, rpllist);
 844         q = mkconv(type, fixtype(cpexpr(rhs)) );
 845
 846         /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
 847         while(--nargs >= 0) {
 848                 if(rpllist->rplblock.rplxp)
 849                         q = mkexpr(OPCOMMA, rpllist->rplblock.rplxp, q);
 850                 rp = rpllist->rplblock.nextp;
 851                 frexpr(rpllist->rplblock.rplvp);
 852                 ckfree(rpllist);
 853                 rpllist = rp;
 854         }
 855
 856         frchain( &oactp );
 857         return(q);
 858 }
 859
 860
 861
 862
 863 struct bigblock *
 864 mklhs(struct bigblock *p)
 865 {
 866         struct bigblock *s;
 867         struct bigblock *np;
 868         chainp rp;
 869         int regn;
 870
 871         /* first fixup name */
 872
 873         if(p->tag != TPRIM)
 874                 return(p);
 875
 876         np = p->b_prim.namep;
 877
 878         /* is name on the replace list? */
 879
 880         for(rp = rpllist ; rp ; rp = rp->rplblock.nextp) {
 881                 if(np == rp->rplblock.rplnp) {
 882                         if(rp->rplblock.rpltag == TNAME) {
 883                                 np = p->b_prim.namep = rp->rplblock.rplvp;
 884                                 break;
 885                         } else
 886                                 return( cpexpr(rp->rplblock.rplvp) );
 887                 }
 888         }
 889
 890         /* is variable a DO index in a register ? */
 891
 892         if(np->b_name.vdovar && ( (regn = inregister(np)) >= 0) ) {
 893                 if(np->vtype == TYERROR)
 894                         return( errnode() );
 895                 else {
 896                         s = BALLO();
 897                         s->tag = TADDR;
 898                         s->vstg = STGREG;
 899                         s->vtype = TYIREG;
 900                         s->b_addr.memno = regn;
 901                         s->b_addr.memoffset = MKICON(0);
 902                         return(s);
 903                 }
 904         }
 905
 906         vardcl(np);
 907         s = mkaddr(np);
 908         s->b_addr.memoffset = mkexpr(OPPLUS, s->b_addr.memoffset, suboffset(p) );
 909         frexpr(p->b_prim.argsp);
 910         p->b_prim.argsp = NULL;
 911
 912         /* now do substring part */
 913
 914         if(p->b_prim.fcharp || p->b_prim.lcharp) {
 915                 if(np->vtype != TYCHAR)
 916                         err1("substring of noncharacter %s",
 917                             varstr(VL,np->b_name.varname));
 918                 else    {
 919                         if(p->b_prim.lcharp == NULL)
 920                                 p->b_prim.lcharp = cpexpr(s->vleng);
 921                         if(p->b_prim.fcharp)
 922                                 s->vleng = mkexpr(OPMINUS, p->b_prim.lcharp,
 923                                         mkexpr(OPMINUS, p->b_prim.fcharp, MKICON(1) ));
 924                         else    {
 925                                 frexpr(s->vleng);
 926                                 s->vleng = p->b_prim.lcharp;
 927                         }
 928                 }
 929         }
 930
 931         s->vleng = fixtype( s->vleng );
 932         s->b_addr.memoffset = fixtype( s->b_addr.memoffset );
 933         ckfree(p);
 934         return(s);
 935 }
 936
 937
 938
 939
 940 void
 941 deregister(np)
 942 struct bigblock *np;
 943 {
 944 }
 945
 946
 947
 948
 949 struct bigblock *memversion(np)
 950 register struct bigblock *np;
 951 {
 952 register struct bigblock *s;
 953
 954 if(np->b_name.vdovar==NO || (inregister(np)<0) )
 955         return(NULL);
 956 np->b_name.vdovar = NO;
 957 s = mklhs( mkprim(np, 0,0,0) );
 958 np->b_name.vdovar = YES;
 959 return(s);
 960 }
 961
 962
 963 int
 964 inregister(np)
 965 register struct bigblock *np;
 966 {
 967 return(-1);
 968 }
 969
 970
 971
 972 int
 973 enregister(np)
 974 struct bigblock *np;
 975 {
 976         return(NO);
 977 }
 978
 979
 980
 981
 982 bigptr suboffset(p)
 983 register struct bigblock *p;
 984 {
 985 int n;
 986 bigptr size;
 987 chainp cp;
 988 bigptr offp, prod;
 989 struct dimblock *dimp;
 990 bigptr sub[8];
 991 register struct bigblock *np;
 992
 993 np = p->b_prim.namep;
 994 offp = MKICON(0);
 995 n = 0;
 996 if(p->b_prim.argsp)
 997         for(cp = p->b_prim.argsp->b_list.listp ; cp ; cp = cp->chain.nextp)
 998                 {
 999                 sub[n++] = fixtype(cpexpr(cp->chain.datap));
1000                 if(n > 7)
1001                         {
1002                         err("more than 7 subscripts");
1003                         break;
1004                         }
1005                 }
1006
1007 dimp = np->b_name.vdim;
1008 if(n>0 && dimp==NULL)
1009         err("subscripts on scalar variable");
1010 else if(dimp && dimp->ndim!=n)
1011         err1("wrong number of subscripts on %s",
1012                 varstr(VL, np->b_name.varname) );
1013 else if(n > 0)
1014         {
1015         prod = sub[--n];
1016         while( --n >= 0)
1017                 prod = mkexpr(OPPLUS, sub[n],
1018                         mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
1019 #ifdef __vax__
1020         if(checksubs || np->vstg!=STGARG)
1021                 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1022 #else
1023         prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1024 #endif
1025         if(checksubs)
1026                 prod = subcheck(np, prod);
1027         if(np->vtype == TYCHAR)
1028                 size = cpexpr(np->vleng);
1029         else    size = MKICON( typesize[np->vtype] );
1030         prod = mkexpr(OPSTAR, prod, size);
1031         offp = mkexpr(OPPLUS, offp, prod);
1032         }
1033
1034 if(p->b_prim.fcharp && np->vtype==TYCHAR)
1035         offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->b_prim.fcharp), MKICON(1) ));
1036
1037 return(offp);
1038 }
1039
1040
1041 /*
1042  * Check if an array is addressed out of bounds.
1043  */
1044 bigptr
1045 subcheck(struct bigblock *np, bigptr p)
1046 {
1047         struct dimblock *dimp;
1048         bigptr t, badcall;
1049         int l1, l2;
1050
1051         dimp = np->b_name.vdim;
1052         if(dimp->nelt == NULL)
1053                 return(p);      /* don't check arrays with * bounds */
1054         if( ISICON(p) ) {
1055                 if(p->b_const.fconst.ci < 0)
1056                         goto badsub;
1057                 if( ISICON(dimp->nelt) ) {
1058                         if(p->b_const.fconst.ci < dimp->nelt->b_const.fconst.ci)
1059                                 return(p);
1060                         else
1061                                 goto badsub;
1062                 }
1063         }
1064
1065         if (p->tag==TADDR && p->vstg==STGREG) {
1066                 t = p;
1067         } else {
1068                 t = fmktemp(p->vtype, NULL);
1069                 putexpr(mkexpr(OPASSIGN, cpexpr(t), p));
1070         }
1071         /* t now cotains evaluated expression */
1072
1073         l1 = newlabel();
1074         l2 = newlabel();
1075         putif(mkexpr(OPLT, cpexpr(t), cpexpr(dimp->nelt)), l1);
1076         putif(mkexpr(OPGE, cpexpr(t), MKICON(0)), l1);
1077         putgoto(l2);
1078         putlabel(l1);
1079
1080         badcall = call4(t->vtype, "s_rnge", mkstrcon(VL, np->b_name.varname),
1081                 mkconv(TYLONG,  cpexpr(t)),
1082                 mkstrcon(XL, procname), MKICON(lineno));
1083         badcall->b_expr.opcode = OPCCALL;
1084
1085         putexpr(badcall);
1086         putlabel(l2);
1087         return t;
1088
1089 badsub:
1090         frexpr(p);
1091         err1("subscript on variable %s out of range",
1092             varstr(VL,np->b_name.varname));
1093         return ( MKICON(0) );
1094 }
1095
1096
1097
1098
1099 struct bigblock *mkaddr(p)
1100 register struct bigblock *p;
1101 {
1102 struct extsym *extp;
1103 register struct bigblock *t;
1104
1105 switch( p->vstg)
1106         {
1107         case STGUNKNOWN:
1108                 if(p->vclass != CLPROC)
1109                         break;
1110                 extp = mkext( varunder(VL, p->b_name.varname) );
1111                 extp->extstg = STGEXT;
1112                 p->vstg = STGEXT;
1113                 p->b_name.vardesc.varno = extp - extsymtab;
1114                 p->b_name.vprocclass = PEXTERNAL;
1115
1116         case STGCOMMON:
1117         case STGEXT:
1118         case STGBSS:
1119         case STGINIT:
1120         case STGEQUIV:
1121         case STGARG:
1122         case STGLENG:
1123         case STGAUTO:
1124                 t = BALLO();
1125                 t->tag = TADDR;
1126                 t->vclass = p->vclass;
1127                 t->vtype = p->vtype;
1128                 t->vstg = p->vstg;
1129                 t->b_addr.memno = p->b_name.vardesc.varno;
1130                 t->b_addr.memoffset = MKICON(p->b_name.voffset);
1131                 if(p->vleng)
1132                         t->vleng = cpexpr(p->vleng);
1133                 return(t);
1134
1135         case STGINTR:
1136                 return( intraddr(p) );
1137
1138         }
1139 /*debug*/ fprintf(diagfile, "mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass);
1140 fatal1("mkaddr: impossible storage tag %d", p->vstg);
1141 /* NOTREACHED */
1142 return 0; /* XXX gcc */
1143 }
1144
1145
1146
1147 struct bigblock *
1148 mkarg(type, argno)
1149 int type, argno;
1150 {
1151 register struct bigblock *p;
1152
1153 p = BALLO();
1154 p->tag = TADDR;
1155 p->vtype = type;
1156 p->vclass = CLVAR;
1157 p->vstg = (type==TYLENG ? STGLENG : STGARG);
1158 p->b_addr.memno = argno;
1159 return(p);
1160 }
1161
1162
1163
1164
1165 bigptr mkprim(v, args, lstr, rstr)
1166 register bigptr v;
1167 struct bigblock *args;
1168 bigptr lstr, rstr;
1169 {
1170 register struct bigblock *p;
1171
1172 if(v->vclass == CLPARAM)
1173         {
1174         if(args || lstr || rstr)
1175                 {
1176                 err1("no qualifiers on parameter name", varstr(VL,v->b_name.varname));
1177                 frexpr(args);
1178                 frexpr(lstr);
1179                 frexpr(rstr);
1180                 frexpr(v);
1181                 return( errnode() );
1182                 }
1183         return( cpexpr(v->b_param.paramval) );
1184         }
1185
1186 p = BALLO();
1187 p->tag = TPRIM;
1188 p->vtype = v->vtype;
1189 p->b_prim.namep = v;
1190 p->b_prim.argsp = args;
1191 p->b_prim.fcharp = lstr;
1192 p->b_prim.lcharp = rstr;
1193 return(p);
1194 }
1195
1196
1197 void
1198 vardcl(v)
1199 register struct bigblock *v;
1200 {
1201 int nelt;
1202 struct dimblock *t;
1203 struct bigblock *p;
1204 bigptr neltp;
1205
1206 if(v->b_name.vdcldone) return;
1207
1208 if(v->vtype == TYUNKNOWN)
1209         impldcl(v);
1210 if(v->vclass == CLUNKNOWN)
1211         v->vclass = CLVAR;
1212 else if(v->vclass!=CLVAR && v->b_name.vprocclass!=PTHISPROC)
1213         {
1214         dclerr("used as variable", v);
1215         return;
1216         }
1217 if(v->vstg==STGUNKNOWN)
1218         v->vstg = implstg[ letter(v->b_name.varname[0]) ];
1219
1220 switch(v->vstg)
1221         {
1222         case STGBSS:
1223                 v->b_name.vardesc.varno = ++lastvarno;
1224                 break;
1225         case STGAUTO:
1226                 if(v->vclass==CLPROC && v->b_name.vprocclass==PTHISPROC)
1227                         break;
1228                 nelt = 1;
1229                 if((t = v->b_name.vdim)) {
1230                         if( (neltp = t->nelt) && ISCONST(neltp) )
1231                                 nelt = neltp->b_const.fconst.ci;
1232                         else
1233                                 dclerr("adjustable automatic array", v);
1234                 }
1235                 p = autovar(nelt, v->vtype, v->vleng);
1236                 v->b_name.voffset = p->b_addr.memoffset->b_const.fconst.ci;
1237                 frexpr(p);
1238                 break;
1239
1240         default:
1241                 break;
1242         }
1243 v->b_name.vdcldone = YES;
1244 }
1245
1246
1247
1248 void
1249 impldcl(p)
1250 register struct bigblock *p;
1251 {
1252 register int k;
1253 int type, leng;
1254
1255 if(p->b_name.vdcldone || (p->vclass==CLPROC && p->b_name.vprocclass==PINTRINSIC) )
1256         return;
1257 if(p->vtype == TYUNKNOWN)
1258         {
1259         k = letter(p->b_name.varname[0]);
1260         type = impltype[ k ];
1261         leng = implleng[ k ];
1262         if(type == TYUNKNOWN)
1263                 {
1264                 if(p->vclass == CLPROC)
1265                         return;
1266                 dclerr("attempt to use undefined variable", p);
1267                 type = TYERROR;
1268                 leng = 1;
1269                 }
1270         settype(p, type, leng);
1271         }
1272 }
1273
1274
1275
1276
1277 LOCAL int
1278 letter(c)
1279 register int c;
1280 {
1281 if( isupper(c) )
1282         c = tolower(c);
1283 return(c - 'a');
1284 }
1285 \f
1286 #define ICONEQ(z, c)  (ISICON(z) && z->b_const.fconst.ci==c)
1287 #define COMMUTE { e = lp;  lp = rp;  rp = e; }
1288
1289
1290 struct bigblock *
1291 mkexpr(opcode, lp, rp)
1292 int opcode;
1293 register bigptr lp, rp;
1294 {
1295 register struct bigblock *e, *e1;
1296 int etype;
1297 int ltype, rtype;
1298 int ltag, rtag;
1299
1300 ltype = lp->vtype;
1301 ltag = lp->tag;
1302 if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1303         {
1304         rtype = rp->vtype;
1305         rtag = rp->tag;
1306         }
1307 else  rtype = rtag = 0;
1308
1309 etype = cktype(opcode, ltype, rtype);
1310 if(etype == TYERROR)
1311         goto error;
1312
1313 switch(opcode)
1314         {
1315         /* check for multiplication by 0 and 1 and addition to 0 */
1316
1317         case OPSTAR:
1318                 if( ISCONST(lp) )
1319                         COMMUTE
1320
1321                 if( ISICON(rp) )
1322                         {
1323                         if(rp->b_const.fconst.ci == 0)
1324                                 goto retright;
1325                         goto mulop;
1326                         }
1327                 break;
1328
1329         case OPSLASH:
1330         case OPMOD:
1331                 if( ICONEQ(rp, 0) )
1332                         {
1333                         err("attempted division by zero");
1334                         rp = MKICON(1);
1335                         break;
1336                         }
1337                 if(opcode == OPMOD)
1338                         break;
1339
1340
1341         mulop:
1342                 if( ISICON(rp) )
1343                         {
1344                         if(rp->b_const.fconst.ci == 1)
1345                                 goto retleft;
1346
1347                         if(rp->b_const.fconst.ci == -1)
1348                                 {
1349                                 frexpr(rp);
1350                                 return( mkexpr(OPNEG, lp, 0) );
1351                                 }
1352                         }
1353
1354                 if( ISSTAROP(lp) && ISICON(lp->b_expr.rightp) )
1355                         {
1356                         if(opcode == OPSTAR)
1357                                 e = mkexpr(OPSTAR, lp->b_expr.rightp, rp);
1358                         else  if(ISICON(rp) && lp->b_expr.rightp->b_const.fconst.ci % rp->b_const.fconst.ci == 0)
1359                                 e = mkexpr(OPSLASH, lp->b_expr.rightp, rp);
1360                         else    break;
1361
1362                         e1 = lp->b_expr.leftp;
1363                         ckfree(lp);
1364                         return( mkexpr(OPSTAR, e1, e) );
1365                         }
1366                 break;
1367
1368
1369         case OPPLUS:
1370                 if( ISCONST(lp) )
1371                         COMMUTE
1372                 goto addop;
1373
1374         case OPMINUS:
1375                 if( ICONEQ(lp, 0) )
1376                         {
1377                         frexpr(lp);
1378                         return( mkexpr(OPNEG, rp, 0) );
1379                         }
1380
1381                 if( ISCONST(rp) )
1382                         {
1383                         opcode = OPPLUS;
1384                         consnegop(rp);
1385                         }
1386
1387         addop:
1388                 if( ISICON(rp) )
1389                         {
1390                         if(rp->b_const.fconst.ci == 0)
1391                                 goto retleft;
1392                         if( ISPLUSOP(lp) && ISICON(lp->b_expr.rightp) )
1393                                 {
1394                                 e = mkexpr(OPPLUS, lp->b_expr.rightp, rp);
1395                                 e1 = lp->b_expr.leftp;
1396                                 ckfree(lp);
1397                                 return( mkexpr(OPPLUS, e1, e) );
1398                                 }
1399                         }
1400                 break;
1401
1402
1403         case OPPOWER:
1404                 break;
1405
1406         case OPNEG:
1407                 if(ltag==TEXPR && lp->b_expr.opcode==OPNEG)
1408                         {
1409                         e = lp->b_expr.leftp;
1410                         ckfree(lp);
1411                         return(e);
1412                         }
1413                 break;
1414
1415         case OPNOT:
1416                 if(ltag==TEXPR && lp->b_expr.opcode==OPNOT)
1417                         {
1418                         e = lp->b_expr.leftp;
1419                         ckfree(lp);
1420                         return(e);
1421                         }
1422                 break;
1423
1424         case OPCALL:
1425         case OPCCALL:
1426                 etype = ltype;
1427                 if(rp!=NULL && rp->b_list.listp==NULL)
1428                         {
1429                         ckfree(rp);
1430                         rp = NULL;
1431                         }
1432                 break;
1433
1434         case OPAND:
1435         case OPOR:
1436                 if( ISCONST(lp) )
1437                         COMMUTE
1438
1439                 if( ISCONST(rp) )
1440                         {
1441                         if(rp->b_const.fconst.ci == 0)
1442                                 if(opcode == OPOR)
1443                                         goto retleft;
1444                                 else
1445                                         goto retright;
1446                         else if(opcode == OPOR)
1447                                 goto retright;
1448                         else
1449                                 goto retleft;
1450                         }
1451         case OPEQV:
1452         case OPNEQV:
1453
1454         case OPBITAND:
1455         case OPBITOR:
1456         case OPBITXOR:
1457         case OPBITNOT:
1458         case OPLSHIFT:
1459         case OPRSHIFT:
1460
1461         case OPLT:
1462         case OPGT:
1463         case OPLE:
1464         case OPGE:
1465         case OPEQ:
1466         case OPNE:
1467
1468         case OPCONCAT:
1469                 break;
1470         case OPMIN:
1471         case OPMAX:
1472
1473         case OPASSIGN:
1474
1475         case OPCONV:
1476         case OPADDR:
1477
1478         case OPCOMMA:
1479                 break;
1480
1481         default:
1482                 fatal1("mkexpr: impossible opcode %d", opcode);
1483         }
1484
1485 e = BALLO();
1486 e->tag = TEXPR;
1487 e->b_expr.opcode = opcode;
1488 e->vtype = etype;
1489 e->b_expr.leftp = lp;
1490 e->b_expr.rightp = rp;
1491 if(ltag==TCONST && (rp==0 || rtag==TCONST) )
1492         e = fold(e);
1493 return(e);
1494
1495 retleft:
1496         frexpr(rp);
1497         return(lp);
1498
1499 retright:
1500         frexpr(lp);
1501         return(rp);
1502
1503 error:
1504         frexpr(lp);
1505         if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1506                 frexpr(rp);
1507         return( errnode() );
1508 }
1509 \f
1510 #define ERR(s)   { errs = s; goto error; }
1511
1512 int
1513 cktype(op, lt, rt)
1514 register int op, lt, rt;
1515 {
1516 char *errs = NULL; /* XXX gcc */
1517
1518 if(lt==TYERROR || rt==TYERROR)
1519         goto error1;
1520
1521 if(lt==TYUNKNOWN)
1522         return(TYUNKNOWN);
1523 if(rt==TYUNKNOWN)
1524         if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR)
1525                 return(TYUNKNOWN);
1526
1527 switch(op)
1528         {
1529         case OPPLUS:
1530         case OPMINUS:
1531         case OPSTAR:
1532         case OPSLASH:
1533         case OPPOWER:
1534         case OPMOD:
1535                 if( ISNUMERIC(lt) && ISNUMERIC(rt) )
1536                         return( maxtype(lt, rt) );
1537                 ERR("nonarithmetic operand of arithmetic operator")
1538
1539         case OPNEG:
1540                 if( ISNUMERIC(lt) )
1541                         return(lt);
1542                 ERR("nonarithmetic operand of negation")
1543
1544         case OPNOT:
1545                 if(lt == TYLOGICAL)
1546                         return(TYLOGICAL);
1547                 ERR("NOT of nonlogical")
1548
1549         case OPAND:
1550         case OPOR:
1551         case OPEQV:
1552         case OPNEQV:
1553                 if(lt==TYLOGICAL && rt==TYLOGICAL)
1554                         return(TYLOGICAL);
1555                 ERR("nonlogical operand of logical operator")
1556
1557         case OPLT:
1558         case OPGT:
1559         case OPLE:
1560         case OPGE:
1561         case OPEQ:
1562         case OPNE:
1563                 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1564                         {
1565                         if(lt != rt)
1566                                 ERR("illegal comparison")
1567                         }
1568
1569                 else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
1570                         {
1571                         if(op!=OPEQ && op!=OPNE)
1572                                 ERR("order comparison of complex data")
1573                         }
1574
1575                 else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
1576                         ERR("comparison of nonarithmetic data")
1577                 return(TYLOGICAL);
1578
1579         case OPCONCAT:
1580                 if(lt==TYCHAR && rt==TYCHAR)
1581                         return(TYCHAR);
1582                 ERR("concatenation of nonchar data")
1583
1584         case OPCALL:
1585         case OPCCALL:
1586                 return(lt);
1587
1588         case OPADDR:
1589                 return(TYADDR);
1590
1591         case OPCONV:
1592                 if(rt == 0)
1593                         return(0);
1594         case OPASSIGN:
1595                 if( ISINT(lt) && rt==TYCHAR)
1596                         return(lt);
1597                 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1598                         if(op!=OPASSIGN || lt!=rt)
1599                                 {
1600 /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
1601 /* debug fatal("impossible conversion.  possible compiler bug"); */
1602                                 ERR("impossible conversion")
1603                                 }
1604                 return(lt);
1605
1606         case OPMIN:
1607         case OPMAX:
1608         case OPBITOR:
1609         case OPBITAND:
1610         case OPBITXOR:
1611         case OPBITNOT:
1612         case OPLSHIFT:
1613         case OPRSHIFT:
1614                 return(lt);
1615
1616         case OPCOMMA:
1617                 return(rt);
1618
1619         default:
1620                 fatal1("cktype: impossible opcode %d", op);
1621         }
1622 error:  err(errs);
1623 error1: return(TYERROR);
1624 }
1625 \f
1626 LOCAL bigptr fold(e)
1627 register struct bigblock *e;
1628 {
1629 struct bigblock *p;
1630 register bigptr lp, rp;
1631 int etype, mtype, ltype, rtype, opcode;
1632 int i, ll, lr;
1633 char *q, *s;
1634 union constant lcon, rcon;
1635
1636 opcode = e->b_expr.opcode;
1637 etype = e->vtype;
1638
1639 lp = e->b_expr.leftp;
1640 ltype = lp->vtype;
1641 rp = e->b_expr.rightp;
1642
1643 if(rp == 0)
1644         switch(opcode)
1645                 {
1646                 case OPNOT:
1647                         lp->b_const.fconst.ci = ! lp->b_const.fconst.ci;
1648                         return(lp);
1649
1650                 case OPBITNOT:
1651                         lp->b_const.fconst.ci = ~ lp->b_const.fconst.ci;
1652                         return(lp);
1653
1654                 case OPNEG:
1655                         consnegop(lp);
1656                         return(lp);
1657
1658                 case OPCONV:
1659                 case OPADDR:
1660                         return(e);
1661
1662                 default:
1663                         fatal1("fold: invalid unary operator %d", opcode);
1664                 }
1665
1666 rtype = rp->vtype;
1667
1668 p = BALLO();
1669 p->tag = TCONST;
1670 p->vtype = etype;
1671 p->vleng = e->vleng;
1672
1673 switch(opcode)
1674         {
1675         case OPCOMMA:
1676                 return(e);
1677
1678         case OPAND:
1679                 p->b_const.fconst.ci = lp->b_const.fconst.ci && rp->b_const.fconst.ci;
1680                 break;
1681
1682         case OPOR:
1683                 p->b_const.fconst.ci = lp->b_const.fconst.ci || rp->b_const.fconst.ci;
1684                 break;
1685
1686         case OPEQV:
1687                 p->b_const.fconst.ci = lp->b_const.fconst.ci == rp->b_const.fconst.ci;
1688                 break;
1689
1690         case OPNEQV:
1691                 p->b_const.fconst.ci = lp->b_const.fconst.ci != rp->b_const.fconst.ci;
1692                 break;
1693
1694         case OPBITAND:
1695                 p->b_const.fconst.ci = lp->b_const.fconst.ci & rp->b_const.fconst.ci;
1696                 break;
1697
1698         case OPBITOR:
1699                 p->b_const.fconst.ci = lp->b_const.fconst.ci | rp->b_const.fconst.ci;
1700                 break;
1701
1702         case OPBITXOR:
1703                 p->b_const.fconst.ci = lp->b_const.fconst.ci ^ rp->b_const.fconst.ci;
1704                 break;
1705
1706         case OPLSHIFT:
1707                 p->b_const.fconst.ci = lp->b_const.fconst.ci << rp->b_const.fconst.ci;
1708                 break;
1709
1710         case OPRSHIFT:
1711                 p->b_const.fconst.ci = lp->b_const.fconst.ci >> rp->b_const.fconst.ci;
1712                 break;
1713
1714         case OPCONCAT:
1715                 ll = lp->vleng->b_const.fconst.ci;
1716                 lr = rp->vleng->b_const.fconst.ci;
1717                 p->b_const.fconst.ccp = q = (char *) ckalloc(ll+lr);
1718                 p->vleng = MKICON(ll+lr);
1719                 s = lp->b_const.fconst.ccp;
1720                 for(i = 0 ; i < ll ; ++i)
1721                         *q++ = *s++;
1722                 s = rp->b_const.fconst.ccp;
1723                 for(i = 0; i < lr; ++i)
1724                         *q++ = *s++;
1725                 break;
1726
1727
1728         case OPPOWER:
1729                 if( ! ISINT(rtype) )
1730                         return(e);
1731                 conspower(&(p->b_const.fconst), lp, rp->b_const.fconst.ci);
1732                 break;
1733
1734
1735         default:
1736                 if(ltype == TYCHAR)
1737                         {
1738                         lcon.ci = cmpstr(lp->b_const.fconst.ccp, rp->b_const.fconst.ccp,
1739                                         lp->vleng->b_const.fconst.ci, rp->vleng->b_const.fconst.ci);
1740                         rcon.ci = 0;
1741                         mtype = tyint;
1742                         }
1743                 else    {
1744                         mtype = maxtype(ltype, rtype);
1745                         consconv(mtype, &lcon, ltype, &(lp->b_const.fconst) );
1746                         consconv(mtype, &rcon, rtype, &(rp->b_const.fconst) );
1747                         }
1748                 consbinop(opcode, mtype, &(p->b_const.fconst), &lcon, &rcon);
1749                 break;
1750         }
1751
1752 frexpr(e);
1753 return(p);
1754 }
1755
1756
1757
1758 /* assign constant l = r , doing coercion */
1759 void
1760 consconv(lt, lv, rt, rv)
1761 int lt, rt;
1762 register union constant *lv, *rv;
1763 {
1764 switch(lt)
1765         {
1766         case TYSHORT:
1767         case TYLONG:
1768                 if( ISINT(rt) )
1769                         lv->ci = rv->ci;
1770                 else    lv->ci = rv->cd[0];
1771                 break;
1772
1773         case TYCOMPLEX:
1774         case TYDCOMPLEX:
1775                 switch(rt)
1776                         {
1777                         case TYSHORT:
1778                         case TYLONG:
1779                                 /* fall through and do real assignment of
1780                                    first element
1781                                 */
1782                         case TYREAL:
1783                         case TYDREAL:
1784                                 lv->cd[1] = 0; break;
1785                         case TYCOMPLEX:
1786                         case TYDCOMPLEX:
1787                                 lv->cd[1] = rv->cd[1]; break;
1788                         }
1789
1790         case TYREAL:
1791         case TYDREAL:
1792                 if( ISINT(rt) )
1793                         lv->cd[0] = rv->ci;
1794                 else    lv->cd[0] = rv->cd[0];
1795                 break;
1796
1797         case TYLOGICAL:
1798                 lv->ci = rv->ci;
1799                 break;
1800         }
1801 }
1802
1803
1804 void
1805 consnegop(p)
1806 register struct bigblock *p;
1807 {
1808 switch(p->vtype)
1809         {
1810         case TYSHORT:
1811         case TYLONG:
1812                 p->b_const.fconst.ci = - p->b_const.fconst.ci;
1813                 break;
1814
1815         case TYCOMPLEX:
1816         case TYDCOMPLEX:
1817                 p->b_const.fconst.cd[1] = - p->b_const.fconst.cd[1];
1818                 /* fall through and do the real parts */
1819         case TYREAL:
1820         case TYDREAL:
1821                 p->b_const.fconst.cd[0] = - p->b_const.fconst.cd[0];
1822                 break;
1823         default:
1824                 fatal1("consnegop: impossible type %d", p->vtype);
1825         }
1826 }
1827
1828
1829
1830 LOCAL void
1831 conspower(powp, ap, n)
1832 register union constant *powp;
1833 struct bigblock *ap;
1834 ftnint n;
1835 {
1836 register int type;
1837 union constant x;
1838
1839 switch(type = ap->vtype)        /* pow = 1 */
1840         {
1841         case TYSHORT:
1842         case TYLONG:
1843                 powp->ci = 1;
1844                 break;
1845         case TYCOMPLEX:
1846         case TYDCOMPLEX:
1847                 powp->cd[1] = 0;
1848         case TYREAL:
1849         case TYDREAL:
1850                 powp->cd[0] = 1;
1851                 break;
1852         default:
1853                 fatal1("conspower: invalid type %d", type);
1854         }
1855
1856 if(n == 0)
1857         return;
1858 if(n < 0)
1859         {
1860         if( ISINT(type) )
1861                 {
1862                 err("integer ** negative power ");
1863                 return;
1864                 }
1865         n = - n;
1866         consbinop(OPSLASH, type, &x, powp, &(ap->b_const.fconst));
1867         }
1868 else
1869         consbinop(OPSTAR, type, &x, powp, &(ap->b_const.fconst));
1870
1871 for( ; ; )
1872         {
1873         if(n & 01)
1874                 consbinop(OPSTAR, type, powp, powp, &x);
1875         if(n >>= 1)
1876                 consbinop(OPSTAR, type, &x, &x, &x);
1877         else
1878                 break;
1879         }
1880 }
1881
1882
1883
1884 /* do constant operation cp = a op b */
1885
1886
1887 LOCAL void
1888 consbinop(opcode, type, cp, ap, bp)
1889 int opcode, type;
1890 register union constant *ap, *bp, *cp;
1891 {
1892 int k;
1893 double temp;
1894
1895 switch(opcode)
1896         {
1897         case OPPLUS:
1898                 switch(type)
1899                         {
1900                         case TYSHORT:
1901                         case TYLONG:
1902                                 cp->ci = ap->ci + bp->ci;
1903                                 break;
1904                         case TYCOMPLEX:
1905                         case TYDCOMPLEX:
1906                                 cp->cd[1] = ap->cd[1] + bp->cd[1];
1907                         case TYREAL:
1908                         case TYDREAL:
1909                                 cp->cd[0] = ap->cd[0] + bp->cd[0];
1910                                 break;
1911                         }
1912                 break;
1913
1914         case OPMINUS:
1915                 switch(type)
1916                         {
1917                         case TYSHORT:
1918                         case TYLONG:
1919                                 cp->ci = ap->ci - bp->ci;
1920                                 break;
1921                         case TYCOMPLEX:
1922                         case TYDCOMPLEX:
1923                                 cp->cd[1] = ap->cd[1] - bp->cd[1];
1924                         case TYREAL:
1925                         case TYDREAL:
1926                                 cp->cd[0] = ap->cd[0] - bp->cd[0];
1927                                 break;
1928                         }
1929                 break;
1930
1931         case OPSTAR:
1932                 switch(type)
1933                         {
1934                         case TYSHORT:
1935                         case TYLONG:
1936                                 cp->ci = ap->ci * bp->ci;
1937                                 break;
1938                         case TYREAL:
1939                         case TYDREAL:
1940                                 cp->cd[0] = ap->cd[0] * bp->cd[0];
1941                                 break;
1942                         case TYCOMPLEX:
1943                         case TYDCOMPLEX:
1944                                 temp = ap->cd[0] * bp->cd[0] -
1945                                             ap->cd[1] * bp->cd[1] ;
1946                                 cp->cd[1] = ap->cd[0] * bp->cd[1] +
1947                                             ap->cd[1] * bp->cd[0] ;
1948                                 cp->cd[0] = temp;
1949                                 break;
1950                         }
1951                 break;
1952         case OPSLASH:
1953                 switch(type)
1954                         {
1955                         case TYSHORT:
1956                         case TYLONG:
1957                                 cp->ci = ap->ci / bp->ci;
1958                                 break;
1959                         case TYREAL:
1960                         case TYDREAL:
1961                                 cp->cd[0] = ap->cd[0] / bp->cd[0];
1962                                 break;
1963                         case TYCOMPLEX:
1964                         case TYDCOMPLEX:
1965                                 zdiv(&cp->dc, &ap->dc, &bp->dc);
1966                                 break;
1967                         }
1968                 break;
1969
1970         case OPMOD:
1971                 if( ISINT(type) )
1972                         {
1973                         cp->ci = ap->ci % bp->ci;
1974                         break;
1975                         }
1976                 else
1977                         fatal("inline mod of noninteger");
1978
1979         default:          /* relational ops */
1980                 switch(type)
1981                         {
1982                         case TYSHORT:
1983                         case TYLONG:
1984                                 if(ap->ci < bp->ci)
1985                                         k = -1;
1986                                 else if(ap->ci == bp->ci)
1987                                         k = 0;
1988                                 else    k = 1;
1989                                 break;
1990                         case TYREAL:
1991                         case TYDREAL:
1992                                 if(ap->cd[0] < bp->cd[0])
1993                                         k = -1;
1994                                 else if(ap->cd[0] == bp->cd[0])
1995                                         k = 0;
1996                                 else    k = 1;
1997                                 break;
1998                         case TYCOMPLEX:
1999                         case TYDCOMPLEX:
2000                                 if(ap->cd[0] == bp->cd[0] &&
2001                                    ap->cd[1] == bp->cd[1] )
2002                                         k = 0;
2003                                 else    k = 1;
2004                                 break;
2005                         default: /* XXX gcc */
2006                                 k = 0;
2007                                 break;
2008                         }
2009
2010                 switch(opcode)
2011                         {
2012                         case OPEQ:
2013                                 cp->ci = (k == 0);
2014                                 break;
2015                         case OPNE:
2016                                 cp->ci = (k != 0);
2017                                 break;
2018                         case OPGT:
2019                                 cp->ci = (k == 1);
2020                                 break;
2021                         case OPLT:
2022                                 cp->ci = (k == -1);
2023                                 break;
2024                         case OPGE:
2025                                 cp->ci = (k >= 0);
2026                                 break;
2027                         case OPLE:
2028                                 cp->ci = (k <= 0);
2029                                 break;
2030                         }
2031                 break;
2032         }
2033 }
2034
2035
2036
2037 int
2038 conssgn(p)
2039 register bigptr p;
2040 {
2041 if( ! ISCONST(p) )
2042         fatal( "sgn(nonconstant)" );
2043
2044 switch(p->vtype)
2045         {
2046         case TYSHORT:
2047         case TYLONG:
2048                 if(p->b_const.fconst.ci > 0) return(1);
2049                 if(p->b_const.fconst.ci < 0) return(-1);
2050                 return(0);
2051
2052         case TYREAL:
2053         case TYDREAL:
2054                 if(p->b_const.fconst.cd[0] > 0) return(1);
2055                 if(p->b_const.fconst.cd[0] < 0) return(-1);
2056                 return(0);
2057
2058         case TYCOMPLEX:
2059         case TYDCOMPLEX:
2060                 return(p->b_const.fconst.cd[0]!=0 || p->b_const.fconst.cd[1]!=0);
2061
2062         default:
2063                 fatal1( "conssgn(type %d)", p->vtype);
2064         }
2065 /* NOTREACHED */
2066 return 0; /* XXX gcc */
2067 }
2068 \f
2069 char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
2070
2071
2072 LOCAL bigptr mkpower(p)
2073 register struct bigblock *p;
2074 {
2075 register bigptr q, lp, rp;
2076 int ltype, rtype, mtype;
2077
2078 lp = p->b_expr.leftp;
2079 rp = p->b_expr.rightp;
2080 ltype = lp->vtype;
2081 rtype = rp->vtype;
2082
2083 if(ISICON(rp))
2084         {
2085         if(rp->b_const.fconst.ci == 0)
2086                 {
2087                 frexpr(p);
2088                 if( ISINT(ltype) )
2089                         return( MKICON(1) );
2090                 else
2091                         return( putconst( mkconv(ltype, MKICON(1))) );
2092                 }
2093         if(rp->b_const.fconst.ci < 0)
2094                 {
2095                 if( ISINT(ltype) )
2096                         {
2097                         frexpr(p);
2098                         err("integer**negative");
2099                         return( errnode() );
2100                         }
2101                 rp->b_const.fconst.ci = - rp->b_const.fconst.ci;
2102                 p->b_expr.leftp = lp = fixexpr(mkexpr(OPSLASH, MKICON(1), lp));
2103                 }
2104         if(rp->b_const.fconst.ci == 1)
2105                 {
2106                 frexpr(rp);
2107                 ckfree(p);
2108                 return(lp);
2109                 }
2110
2111         if( ONEOF(ltype, MSKINT|MSKREAL) )
2112                 {
2113                 p->vtype = ltype;
2114                 return(p);
2115                 }
2116         }
2117 if( ISINT(rtype) )
2118         {
2119         if(ltype==TYSHORT && rtype==TYSHORT)
2120                 q = call2(TYSHORT, "pow_hh", lp, rp);
2121         else    {
2122                 if(ltype == TYSHORT)
2123                         {
2124                         ltype = TYLONG;
2125                         lp = mkconv(TYLONG,lp);
2126                         }
2127                 q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
2128                 }
2129         }
2130 else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
2131         q = call2(mtype, "pow_dd",
2132                 mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
2133 else    {
2134         q = call2(TYDCOMPLEX, "pow_zz",
2135                 mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
2136         if(mtype == TYCOMPLEX)
2137                 q = mkconv(TYCOMPLEX, q);
2138         }
2139 ckfree(p);
2140 return(q);
2141 }
2142 \f
2143
2144
2145 /* Complex Division.  Same code as in Runtime Library
2146 */
2147
2148
2149
2150 LOCAL void
2151 zdiv(c, a, b)
2152 register struct dcomplex *a, *b, *c;
2153 {
2154 double ratio, den;
2155 double abr, abi;
2156
2157 if( (abr = b->dreal) < 0.)
2158         abr = - abr;
2159 if( (abi = b->dimag) < 0.)
2160         abi = - abi;
2161 if( abr <= abi )
2162         {
2163         if(abi == 0)
2164                 fatal("complex division by zero");
2165         ratio = b->dreal / b->dimag ;
2166         den = b->dimag * (1 + ratio*ratio);
2167         c->dreal = (a->dreal*ratio + a->dimag) / den;
2168         c->dimag = (a->dimag*ratio - a->dreal) / den;
2169         }
2170
2171 else
2172         {
2173         ratio = b->dimag / b->dreal ;
2174         den = b->dreal * (1 + ratio*ratio);
2175         c->dreal = (a->dreal + a->dimag*ratio) / den;
2176         c->dimag = (a->dimag - a->dreal*ratio) / den;
2177         }
2178
2179 }