sources/f2c/expr.c

   1 /****************************************************************
   2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
   3
   4 Permission to use, copy, modify, and distribute this software
   5 and its documentation for any purpose and without fee is hereby
   6 granted, provided that the above copyright notice appear in all
   7 copies and that both that the copyright notice and this
   8 permission notice and warranty disclaimer appear in supporting
   9 documentation, and that the names of AT&T Bell Laboratories or
  10 Bellcore or any of their entities not be used in advertising or
  11 publicity pertaining to distribution of the software without
  12 specific, written prior permission.
  13
  14 AT&T and Bellcore disclaim all warranties with regard to this
  15 software, including all implied warranties of merchantability
  16 and fitness.  In no event shall AT&T or Bellcore be liable for
  17 any special, indirect or consequential damages or any damages
  18 whatsoever resulting from loss of use, data or profits, whether
  19 in an action of contract, negligence or other tortious action,
  20 arising out of or in connection with the use or performance of
  21 this software.
  22 ****************************************************************/
  23
  24 #include "defs.h"
  25 #include "output.h"
  26 #include "names.h"
  27
  28 LOCAL void conspower(), consbinop(), zdiv();
  29 LOCAL expptr fold(), mkpower(), stfcall();
  30
  31 typedef struct { double dreal, dimag; } dcomplex;
  32
  33 extern char dflttype[26];
  34
  35 /* little routines to create constant blocks */
  36
  37 Constp mkconst(t)
  38 register int t;
  39 {
  40         register Constp p;
  41
  42         p = ALLOC(Constblock);
  43         p->tag = TCONST;
  44         p->vtype = t;
  45         return(p);
  46 }
  47
  48
  49 /* mklogcon -- Make Logical Constant */
  50
  51 expptr mklogcon(l)
  52 register int l;
  53 {
  54         register Constp  p;
  55
  56         p = mkconst(TYLOGICAL);
  57         p->Const.ci = l;
  58         return( (expptr) p );
  59 }
  60
  61
  62
  63 /* mkintcon -- Make Integer Constant */
  64
  65 expptr mkintcon(l)
  66 ftnint l;
  67 {
  68         register Constp p;
  69
  70         p = mkconst(tyint);
  71         p->Const.ci = l;
  72 #ifdef MAXSHORT
  73         if(l >= -MAXSHORT   &&   l <= MAXSHORT)
  74                 p->vtype = TYSHORT;
  75 #endif
  76         return( (expptr) p );
  77 }
  78
  79
  80
  81
  82 /* mkaddcon -- Make Address Constant, given integer value */
  83
  84 expptr mkaddcon(l)
  85 register long l;
  86 {
  87         register Constp p;
  88
  89         p = mkconst(TYADDR);
  90         p->Const.ci = l;
  91         return( (expptr) p );
  92 }
  93
  94
  95
  96 /* mkrealcon -- Make Real Constant.  The type t is assumed
  97    to be TYREAL or TYDREAL */
  98
  99 expptr mkrealcon(t, d)
 100  register int t;
 101  char *d;
 102 {
 103         register Constp p;
 104
 105         p = mkconst(t);
 106         p->Const.cds[0] = cds(d,CNULL);
 107         p->vstg = 1;
 108         return( (expptr) p );
 109 }
 110
 111
 112 /* mkbitcon -- Make bit constant.  Reads the input string, which is
 113    assumed to correctly specify a number in base 2^shift (where   shift
 114    is the input parameter).   shift   may not exceed 4, i.e. only binary,
 115    quad, octal and hex bases may be input.  Constants may not exceed 32
 116    bits, or whatever the size of (struct Constblock).ci may be. */
 117
 118 expptr mkbitcon(shift, leng, s)
 119 int shift;
 120 int leng;
 121 char *s;
 122 {
 123         register Constp p;
 124         register long x;
 125
 126         p = mkconst(TYLONG);
 127         x = 0;
 128         while(--leng >= 0)
 129                 if(*s != ' ')
 130                         x = (x << shift) | hextoi(*s++);
 131         /* mwm wanted to change the type to short for short constants,
 132          * but this is dangerous -- there is no syntax for long constants
 133          * with small values.
 134          */
 135         p->Const.ci = x;
 136         return( (expptr) p );
 137 }
 138
 139
 140
 141
 142
 143 /* mkstrcon -- Make string constant.  Allocates storage and initializes
 144    the memory for a copy of the input Fortran-string. */
 145
 146 expptr mkstrcon(l,v)
 147 int l;
 148 register char *v;
 149 {
 150         register Constp p;
 151         register char *s;
 152
 153         p = mkconst(TYCHAR);
 154         p->vleng = ICON(l);
 155         p->Const.ccp = s = (char *) ckalloc(l+1);
 156         p->Const.ccp1.blanks = 0;
 157         while(--l >= 0)
 158                 *s++ = *v++;
 159         *s = '\0';
 160         return( (expptr) p );
 161 }
 162
 163
 164
 165 /* mkcxcon -- Make complex contsant.  A complex number is a pair of
 166    values, each of which may be integer, real or double. */
 167
 168 expptr mkcxcon(realp,imagp)
 169 register expptr realp, imagp;
 170 {
 171         int rtype, itype;
 172         register Constp p;
 173         expptr errnode();
 174
 175         rtype = realp->headblock.vtype;
 176         itype = imagp->headblock.vtype;
 177
 178         if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
 179         {
 180                 p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
 181                                 ? TYDCOMPLEX : TYCOMPLEX);
 182                 if (realp->constblock.vstg || imagp->constblock.vstg) {
 183                         p->vstg = 1;
 184                         p->Const.cds[0] = ISINT(rtype)
 185                                 ? string_num("", realp->constblock.Const.ci)
 186                                 : realp->constblock.vstg
 187                                         ? realp->constblock.Const.cds[0]
 188                                         : dtos(realp->constblock.Const.cd[0]);
 189                         p->Const.cds[1] = ISINT(itype)
 190                                 ? string_num("", imagp->constblock.Const.ci)
 191                                 : imagp->constblock.vstg
 192                                         ? imagp->constblock.Const.cds[0]
 193                                         : dtos(imagp->constblock.Const.cd[0]);
 194                         }
 195                 else {
 196                         p->Const.cd[0] = ISINT(rtype)
 197                                 ? realp->constblock.Const.ci
 198                                 : realp->constblock.Const.cd[0];
 199                         p->Const.cd[1] = ISINT(itype)
 200                                 ? imagp->constblock.Const.ci
 201                                 : imagp->constblock.Const.cd[0];
 202                         }
 203         }
 204         else
 205         {
 206                 err("invalid complex constant");
 207                 p = (Constp)errnode();
 208         }
 209
 210         frexpr(realp);
 211         frexpr(imagp);
 212         return( (expptr) p );
 213 }
 214
 215
 216 /* errnode -- Allocate a new error block */
 217
 218 expptr errnode()
 219 {
 220         struct Errorblock *p;
 221         p = ALLOC(Errorblock);
 222         p->tag = TERROR;
 223         p->vtype = TYERROR;
 224         return( (expptr) p );
 225 }
 226
 227
 228
 229
 230
 231 /* mkconv -- Make type conversion.  Cast expression   p   into type   t.
 232    Note that casting to a character copies only the first sizeof(char)
 233    bytes. */
 234
 235 expptr mkconv(t, p)
 236 register int t;
 237 register expptr p;
 238 {
 239         register expptr q;
 240         register int pt;
 241         expptr opconv();
 242
 243         if(t==TYUNKNOWN || t==TYERROR)
 244                 badtype("mkconv", t);
 245         pt = p->headblock.vtype;
 246
 247 /* Casting to the same type is a no-op */
 248
 249         if(t == pt)
 250                 return(p);
 251
 252 /* If we're casting a constant which is not in the literal table ... */
 253
 254         else if( ISCONST(p) && pt!=TYADDR)
 255         {
 256                 if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
 257                         /* avoid trouble with -i2 */
 258                         p->headblock.vtype = t;
 259                         return p;
 260                         }
 261                 q = (expptr) mkconst(t);
 262                 consconv(t, &q->constblock, &p->constblock );
 263                 frexpr(p);
 264         }
 265         else
 266                 q = opconv(p, t);
 267
 268         if(t == TYCHAR)
 269                 q->constblock.vleng = ICON(1);
 270         return(q);
 271 }
 272
 273
 274
 275 /* opconv -- Convert expression   p   to type   t   using the main
 276    expression evaluator; returns an OPCONV expression, I think  14-jun-88 mwm */
 277
 278 expptr opconv(p, t)
 279 expptr p;
 280 int t;
 281 {
 282         register expptr q;
 283
 284         q = mkexpr(OPCONV, p, ENULL);
 285         q->headblock.vtype = t;
 286         return(q);
 287 }
 288
 289
 290
 291 /* addrof -- Create an ADDR expression operation */
 292
 293 expptr addrof(p)
 294 expptr p;
 295 {
 296         return( mkexpr(OPADDR, p, ENULL) );
 297 }
 298
 299
 300
 301 /* cpexpr - Returns a new copy of input expression   p   */
 302
 303 tagptr cpexpr(p)
 304 register tagptr p;
 305 {
 306         register tagptr e;
 307         int tag;
 308         register chainp ep, pp;
 309         tagptr cpblock();
 310
 311 /* This table depends on the ordering of the TY macros, e.g. TYUNKNOWN */
 312
 313         static int blksize[ ] =
 314         {
 315                 0,
 316                 sizeof(struct Nameblock),
 317                 sizeof(struct Constblock),
 318                 sizeof(struct Exprblock),
 319                 sizeof(struct Addrblock),
 320                 sizeof(struct Primblock),
 321                 sizeof(struct Listblock),
 322                 sizeof(struct Errorblock)
 323         };
 324
 325         if(p == NULL)
 326                 return(NULL);
 327
 328 /* TNAMEs are special, and don't get copied.  Each name in the current
 329    symbol table has a unique TNAME structure. */
 330
 331         if( (tag = p->tag) == TNAME)
 332                 return(p);
 333
 334         e = cpblock(blksize[p->tag], (char *)p);
 335
 336         switch(tag)
 337         {
 338         case TCONST:
 339                 if(e->constblock.vtype == TYCHAR)
 340                 {
 341                         e->constblock.Const.ccp =
 342                             copyn((int)e->constblock.vleng->constblock.Const.ci+1,
 343                                 e->constblock.Const.ccp);
 344                         e->constblock.vleng =
 345                             (expptr) cpexpr(e->constblock.vleng);
 346                 }
 347         case TERROR:
 348                 break;
 349
 350         case TEXPR:
 351                 e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
 352                 e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
 353                 break;
 354
 355         case TLIST:
 356                 if(pp = p->listblock.listp)
 357                 {
 358                         ep = e->listblock.listp =
 359                             mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
 360                         for(pp = pp->nextp ; pp ; pp = pp->nextp)
 361                                 ep = ep->nextp =
 362                                     mkchain((char *)cpexpr((tagptr)pp->datap),
 363                                                 CHNULL);
 364                 }
 365                 break;
 366
 367         case TADDR:
 368                 e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
 369                 e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
 370                 e->addrblock.istemp = NO;
 371                 break;
 372
 373         case TPRIM:
 374                 e->primblock.argsp = (struct Listblock *)
 375                     cpexpr((expptr)e->primblock.argsp);
 376                 e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
 377                 e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
 378                 break;
 379
 380         default:
 381                 badtag("cpexpr", tag);
 382         }
 383
 384         return(e);
 385 }
 386
 387 /* frexpr -- Free expression -- frees up memory used by expression   p   */
 388
 389 frexpr(p)
 390 register tagptr p;
 391 {
 392         register chainp q;
 393
 394         if(p == NULL)
 395                 return;
 396
 397         switch(p->tag)
 398         {
 399         case TCONST:
 400                 if( ISCHAR(p) )
 401                 {
 402                         free( (charptr) (p->constblock.Const.ccp) );
 403                         frexpr(p->constblock.vleng);
 404                 }
 405                 break;
 406
 407         case TADDR:
 408                 if (p->addrblock.vtype > TYERROR)       /* i/o block */
 409                         break;
 410                 frexpr(p->addrblock.vleng);
 411                 frexpr(p->addrblock.memoffset);
 412                 break;
 413
 414         case TERROR:
 415                 break;
 416
 417 /* TNAME blocks don't get free'd - probably because they're pointed to in
 418    the hash table. 14-Jun-88 -- mwm */
 419
 420         case TNAME:
 421                 return;
 422
 423         case TPRIM:
 424                 frexpr((expptr)p->primblock.argsp);
 425                 frexpr(p->primblock.fcharp);
 426                 frexpr(p->primblock.lcharp);
 427                 break;
 428
 429         case TEXPR:
 430                 frexpr(p->exprblock.leftp);
 431                 if(p->exprblock.rightp)
 432                         frexpr(p->exprblock.rightp);
 433                 break;
 434
 435         case TLIST:
 436                 for(q = p->listblock.listp ; q ; q = q->nextp)
 437                         frexpr((tagptr)q->datap);
 438                 frchain( &(p->listblock.listp) );
 439                 break;
 440
 441         default:
 442                 badtag("frexpr", p->tag);
 443         }
 444
 445         free( (charptr) p );
 446 }
 447
 448  void
 449 wronginf(np)
 450  Namep np;
 451 {
 452         int c, k;
 453         warn1("fixing wrong type inferred for %.65s", np->fvarname);
 454         np->vinftype = 0;
 455         c = letter(np->fvarname[0]);
 456         if ((np->vtype = impltype[c]) == TYCHAR
 457         && (k = implleng[c]))
 458                 np->vleng = ICON(k);
 459         }
 460
 461 /* fix up types in expression; replace subtrees and convert
 462    names to address blocks */
 463
 464 expptr fixtype(p)
 465 register tagptr p;
 466 {
 467
 468         if(p == 0)
 469                 return(0);
 470
 471         switch(p->tag)
 472         {
 473         case TCONST:
 474                 if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
 475                     MSKREAL) )
 476                         return( (expptr) p);
 477
 478                 return( (expptr) putconst((Constp)p) );
 479
 480         case TADDR:
 481                 p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
 482                 return( (expptr) p);
 483
 484         case TERROR:
 485                 return( (expptr) p);
 486
 487         default:
 488                 badtag("fixtype", p->tag);
 489
 490 /* This case means that   fixexpr   can't call   fixtype   with any expr,
 491    only a subexpr of its parameter. */
 492
 493         case TEXPR:
 494                 return( fixexpr((Exprp)p) );
 495
 496         case TLIST:
 497                 return( (expptr) p );
 498
 499         case TPRIM:
 500                 if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
 501                 {
 502                         if(p->primblock.namep->vtype == TYSUBR)
 503                         {
 504                                 err("function invocation of subroutine");
 505                                 return( errnode() );
 506                         }
 507                         else {
 508                                 if (p->primblock.namep->vinftype)
 509                                         wronginf(p->primblock.namep);
 510                                 return( mkfunct(p) );
 511                                 }
 512                 }
 513
 514 /* The lack of args makes   p   a function name, substring reference
 515    or variable name. */
 516
 517                 else    return( mklhs((struct Primblock *) p) );
 518         }
 519 }
 520
 521
 522
 523 /* special case tree transformations and cleanups of expression trees.
 524    Parameter   p   should have a TEXPR tag at its root, else an error is
 525    returned */
 526
 527 expptr fixexpr(p)
 528 register Exprp p;
 529 {
 530         expptr lp;
 531         register expptr rp;
 532         register expptr q;
 533         int opcode, ltype, rtype, ptype, mtype;
 534
 535         if( ISERROR(p) )
 536                 return( (expptr) p );
 537         else if(p->tag != TEXPR)
 538                 badtag("fixexpr", p->tag);
 539         opcode = p->opcode;
 540
 541 /* First set the types of the left and right subexpressions */
 542
 543         lp = p->leftp = fixtype(p->leftp);
 544         ltype = lp->headblock.vtype;
 545
 546         if(opcode==OPASSIGN && lp->tag!=TADDR)
 547         {
 548                 err("left side of assignment must be variable");
 549                 frexpr((expptr)p);
 550                 return( errnode() );
 551         }
 552
 553         if(p->rightp)
 554         {
 555                 rp = p->rightp = fixtype(p->rightp);
 556                 rtype = rp->headblock.vtype;
 557         }
 558         else
 559         {
 560                 rp = NULL;
 561                 rtype = 0;
 562         }
 563
 564         if(ltype==TYERROR || rtype==TYERROR)
 565         {
 566                 frexpr((expptr)p);
 567                 return( errnode() );
 568         }
 569
 570 /* Now work on the whole expression */
 571
 572         /* force folding if possible */
 573
 574         if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
 575         {
 576                 q = mkexpr(opcode, lp, rp);
 577
 578 /* mkexpr is expected to reduce constant expressions */
 579
 580                 if( ISCONST(q) )
 581                         return(q);
 582                 free( (charptr) q );    /* constants did not fold */
 583         }
 584
 585         if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
 586         {
 587                 frexpr((expptr)p);
 588                 return( errnode() );
 589         }
 590
 591         switch(opcode)
 592         {
 593         case OPCONCAT:
 594                 if(p->vleng == NULL)
 595                         p->vleng = mkexpr(OPPLUS,
 596                             cpexpr(lp->headblock.vleng),
 597                             cpexpr(rp->headblock.vleng) );
 598                 break;
 599
 600         case OPASSIGN:
 601                 if (rtype == TYREAL)
 602                         break;
 603         case OPPLUSEQ:
 604         case OPSTAREQ:
 605                 if(ltype == rtype)
 606                         break;
 607                 if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
 608                         break;
 609                 if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
 610                         break;
 611                 if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
 612                     && typesize[ltype]>=typesize[rtype] )
 613                             break;
 614
 615 /* Cast the right hand side to match the type of the expression */
 616
 617                 p->rightp = fixtype( mkconv(ptype, rp) );
 618                 break;
 619
 620         case OPSLASH:
 621                 if( ISCOMPLEX(rtype) )
 622                 {
 623                         p = (Exprp) call2(ptype,
 624
 625 /* Handle double precision complex variables */
 626
 627                             ptype == TYCOMPLEX ? "c_div" : "z_div",
 628                             mkconv(ptype, lp), mkconv(ptype, rp) );
 629                         break;
 630                 }
 631         case OPPLUS:
 632         case OPMINUS:
 633         case OPSTAR:
 634         case OPMOD:
 635                 if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
 636                     (rtype==TYREAL && ! ISCONST(rp) ) ))
 637                         break;
 638                 if( ISCOMPLEX(ptype) )
 639                         break;
 640
 641 /* Cast both sides of the expression to match the type of the whole
 642    expression.  */
 643
 644                 if(ltype != ptype && (ltype < TYSHORT || ptype > TYDREAL))
 645                         p->leftp = fixtype(mkconv(ptype,lp));
 646                 if(rtype != ptype && (rtype < TYSHORT || ptype > TYDREAL))
 647                         p->rightp = fixtype(mkconv(ptype,rp));
 648                 break;
 649
 650         case OPPOWER:
 651                 return( mkpower((expptr)p) );
 652
 653         case OPLT:
 654         case OPLE:
 655         case OPGT:
 656         case OPGE:
 657         case OPEQ:
 658         case OPNE:
 659                 if(ltype == rtype)
 660                         break;
 661                 mtype = cktype(OPMINUS, ltype, rtype);
 662                 if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
 663                     (rtype==TYREAL && ! ISCONST(rp)) ))
 664                         break;
 665                 if( ISCOMPLEX(mtype) )
 666                         break;
 667                 if(ltype != mtype)
 668                         p->leftp = fixtype(mkconv(mtype,lp));
 669                 if(rtype != mtype)
 670                         p->rightp = fixtype(mkconv(mtype,rp));
 671                 break;
 672
 673         case OPCONV:
 674                 ptype = cktype(OPCONV, p->vtype, ltype);
 675                 if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA)
 676                 {
 677                         lp->exprblock.rightp =
 678                             fixtype( mkconv(ptype, lp->exprblock.rightp) );
 679                         free( (charptr) p );
 680                         p = (Exprp) lp;
 681                 }
 682                 break;
 683
 684         case OPADDR:
 685                 if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
 686                         Fatal("addr of addr");
 687                 break;
 688
 689         case OPCOMMA:
 690         case OPQUEST:
 691         case OPCOLON:
 692                 break;
 693
 694         case OPMIN:
 695         case OPMAX:
 696         case OPMIN2:
 697         case OPMAX2:
 698         case OPDMIN:
 699         case OPDMAX:
 700         case OPABS:
 701         case OPDABS:
 702                 ptype = p->vtype;
 703                 break;
 704
 705         default:
 706                 break;
 707         }
 708
 709         p->vtype = ptype;
 710         return((expptr) p);
 711 }
 712
 713
 714 /* fix an argument list, taking due care for special first level cases */
 715
 716 fixargs(doput, p0)
 717 int doput;      /* doput is true if constants need to be passed by reference */
 718 struct Listblock *p0;
 719 {
 720         register chainp p;
 721         register tagptr q, t;
 722         register int qtag;
 723         int nargs;
 724         Addrp mkscalar();
 725
 726         nargs = 0;
 727         if(p0)
 728                 for(p = p0->listp ; p ; p = p->nextp)
 729                 {
 730                         ++nargs;
 731                         q = (tagptr)p->datap;
 732                         qtag = q->tag;
 733                         if(qtag == TCONST)
 734                         {
 735                                 if(q->constblock.vtype == TYSHORT)
 736                                         q = (tagptr) mkconv(tyint, q);
 737 /* leave constant arguments of intrinsics alone --
 738  * the expression might still simplify.
 739  */
 740
 741 /* Call putconst() to store values in a constant table.  Since even
 742    constants must be passed by reference, this can optimize on the storage
 743    required */
 744
 745                                 p->datap = doput ? (char *)putconst((Constp)q)
 746                                                  : (char *)q;
 747                         }
 748
 749 /* Take a function name and turn it into an Addr.  This only happens when
 750    nothing else has figured out the function beforehand */
 751
 752                         else if(qtag==TPRIM && q->primblock.argsp==0 &&
 753                             q->primblock.namep->vclass==CLPROC &&
 754                             q->primblock.namep->vprocclass != PTHISPROC)
 755                                 p->datap = (char *)mkaddr(q->primblock.namep);
 756
 757                         else if(qtag==TPRIM && q->primblock.argsp==0 &&
 758                             q->primblock.namep->vdim!=NULL)
 759                                 p->datap = (char *)mkscalar(q->primblock.namep);
 760
 761                         else if(qtag==TPRIM && q->primblock.argsp==0 &&
 762                             q->primblock.namep->vdovar &&
 763                             (t = (tagptr) memversion(q->primblock.namep)) )
 764                                 p->datap = (char *)fixtype(t);
 765                         else
 766                                 p->datap = (char *)fixtype(q);
 767                 }
 768         return(nargs);
 769 }
 770
 771
 772
 773 /* mkscalar -- only called by   fixargs   above, and by some routines in
 774    io.c */
 775
 776 Addrp mkscalar(np)
 777 register Namep np;
 778 {
 779         register Addrp ap;
 780
 781         vardcl(np);
 782         ap = mkaddr(np);
 783
 784         /* The prolog causes array arguments to point to the
 785          * (0,...,0) element, unless subscript checking is on.
 786          */
 787         if( !checksubs && np->vstg==STGARG)
 788         {
 789                 register struct Dimblock *dp;
 790                 dp = np->vdim;
 791                 frexpr(ap->memoffset);
 792                 ap->memoffset = mkexpr(OPSTAR,
 793                     (np->vtype==TYCHAR ?
 794                     cpexpr(np->vleng) :
 795                     (tagptr)ICON(typesize[np->vtype]) ),
 796                     cpexpr(dp->baseoffset) );
 797         }
 798         return(ap);
 799 }
 800
 801
 802  static void
 803 adjust_arginfo(np)      /* adjust arginfo to omit the length arg for the
 804                            arg that we now know to be a character-valued
 805                            function */
 806  register Namep np;
 807 {
 808         struct Entrypoint *ep;
 809         register chainp args;
 810         Argtypes *at;
 811
 812         for(ep = entries; ep; ep = ep->entnextp)
 813                 for(args = ep->arglist; args; args = args->nextp)
 814                         if (np == (Namep)args->datap
 815                         && (at = ep->entryname->arginfo))
 816                                 --at->nargs;
 817         }
 818
 819
 820
 821 expptr mkfunct(p0)
 822  expptr p0;
 823 {
 824         register struct Primblock *p = (struct Primblock *)p0;
 825         struct Entrypoint *ep;
 826         Addrp ap;
 827         Extsym *extp;
 828         register Namep np;
 829         register expptr q;
 830         expptr intrcall();
 831         extern chainp new_procs;
 832         int k, nargs;
 833         int class;
 834
 835         if(p->tag != TPRIM)
 836                 return( errnode() );
 837
 838         np = p->namep;
 839         class = np->vclass;
 840
 841
 842         if(class == CLUNKNOWN)
 843         {
 844                 np->vclass = class = CLPROC;
 845                 if(np->vstg == STGUNKNOWN)
 846                 {
 847                         if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
 848                                 && (zflag || !(*(struct Intrpacked *)&k).f4
 849                                         || dcomplex_seen))
 850                         {
 851                                 np->vstg = STGINTR;
 852                                 np->vardesc.varno = k;
 853                                 np->vprocclass = PINTRINSIC;
 854                         }
 855                         else
 856                         {
 857                                 extp = mkext(np->fvarname,
 858                                         addunder(np->cvarname));
 859                                 extp->extstg = STGEXT;
 860                                 np->vstg = STGEXT;
 861                                 np->vardesc.varno = extp - extsymtab;
 862                                 np->vprocclass = PEXTERNAL;
 863                         }
 864                 }
 865                 else if(np->vstg==STGARG)
 866                 {
 867                     if(np->vtype == TYCHAR) {
 868                         adjust_arginfo(np);
 869                         if (np->vpassed) {
 870                                 char wbuf[160], *who;
 871                                 who = np->fvarname;
 872                                 sprintf(wbuf, "%s%s%s\n\t%s%s%s",
 873                                         "Character-valued dummy procedure ",
 874                                         who, " not declared EXTERNAL.",
 875                         "Code may be wrong for previous function calls having ",
 876                                         who, " as a parameter.");
 877                                 warn(wbuf);
 878                                 }
 879                         }
 880                     np->vprocclass = PEXTERNAL;
 881                 }
 882         }
 883
 884         if(class != CLPROC)
 885                 fatali("invalid class code %d for function", class);
 886
 887 /* F77 doesn't allow subscripting of function calls */
 888
 889         if(p->fcharp || p->lcharp)
 890         {
 891                 err("no substring of function call");
 892                 goto error;
 893         }
 894         impldcl(np);
 895         np->vimpltype = 0;      /* invoking as function ==> inferred type */
 896         np->vcalled = 1;
 897         nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
 898
 899         switch(np->vprocclass)
 900         {
 901         case PEXTERNAL:
 902                 if(np->vtype == TYUNKNOWN)
 903                 {
 904                         dclerr("attempt to use untyped function", np);
 905                         np->vtype = dflttype[letter(np->fvarname[0])];
 906                 }
 907                 ap = mkaddr(np);
 908                 if (!extsymtab[np->vardesc.varno].extseen) {
 909                         new_procs = mkchain((char *)np, new_procs);
 910                         extsymtab[np->vardesc.varno].extseen = 1;
 911                         }
 912 call:
 913                 q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
 914                 q->exprblock.vtype = np->vtype;
 915                 if(np->vleng)
 916                         q->exprblock.vleng = (expptr) cpexpr(np->vleng);
 917                 break;
 918
 919         case PINTRINSIC:
 920                 q = intrcall(np, p->argsp, nargs);
 921                 break;
 922
 923         case PSTFUNCT:
 924                 q = stfcall(np, p->argsp);
 925                 break;
 926
 927         case PTHISPROC:
 928                 warn("recursive call");
 929
 930 /* entries   is the list of multiple entry points */
 931
 932                 for(ep = entries ; ep ; ep = ep->entnextp)
 933                         if(ep->enamep == np)
 934                                 break;
 935                 if(ep == NULL)
 936                         Fatal("mkfunct: impossible recursion");
 937
 938                 ap = builtin(np->vtype, ep->entryname->cextname, -2);
 939                 /* the negative last arg prevents adding */
 940                 /* this name to the list of used builtins */
 941                 goto call;
 942
 943         default:
 944                 fatali("mkfunct: impossible vprocclass %d",
 945                     (int) (np->vprocclass) );
 946         }
 947         free( (charptr) p );
 948         return(q);
 949
 950 error:
 951         frexpr((expptr)p);
 952         return( errnode() );
 953 }
 954
 955
 956
 957 LOCAL expptr stfcall(np, actlist)
 958 Namep np;
 959 struct Listblock *actlist;
 960 {
 961         register chainp actuals;
 962         int nargs;
 963         chainp oactp, formals;
 964         int type;
 965         expptr q, rhs, ap;
 966         Namep tnp;
 967         register struct Rplblock *rp;
 968         struct Rplblock *tlist;
 969
 970         if(actlist)
 971         {
 972                 actuals = actlist->listp;
 973                 free( (charptr) actlist);
 974         }
 975         else
 976                 actuals = NULL;
 977         oactp = actuals;
 978
 979         nargs = 0;
 980         tlist = NULL;
 981         if( (type = np->vtype) == TYUNKNOWN)
 982         {
 983                 dclerr("attempt to use untyped statement function", np);
 984                 type = np->vtype = dflttype[letter(np->fvarname[0])];
 985         }
 986         formals = (chainp) np->varxptr.vstfdesc->datap;
 987         rhs = (expptr) (np->varxptr.vstfdesc->nextp);
 988
 989         /* copy actual arguments into temporaries */
 990         while(actuals!=NULL && formals!=NULL)
 991         {
 992                 rp = ALLOC(Rplblock);
 993                 rp->rplnp = tnp = (Namep) formals->datap;
 994                 ap = fixtype((tagptr)actuals->datap);
 995                 if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
 996                     && (ap->tag==TCONST || ap->tag==TADDR) )
 997                 {
 998
 999 /* If actuals are constants or variable names, no temporaries are required */
1000                         rp->rplvp = (expptr) ap;
1001                         rp->rplxp = NULL;
1002                         rp->rpltag = ap->tag;
1003                 }
1004                 else    {
1005                         rp->rplvp = (expptr) Mktemp(tnp->vtype, tnp->vleng);
1006                         rp -> rplxp = NULL;
1007                         putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
1008                         if((rp->rpltag = rp->rplvp->tag) == TERROR)
1009                                 err("disagreement of argument types in statement function call");
1010                 }
1011                 rp->rplnextp = tlist;
1012                 tlist = rp;
1013                 actuals = actuals->nextp;
1014                 formals = formals->nextp;
1015                 ++nargs;
1016         }
1017
1018         if(actuals!=NULL || formals!=NULL)
1019                 err("statement function definition and argument list differ");
1020
1021         /*
1022    now push down names involved in formal argument list, then
1023    evaluate rhs of statement function definition in this environment
1024 */
1025
1026         if(tlist)       /* put tlist in front of the rpllist */
1027         {
1028                 for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
1029                         ;
1030                 rp->rplnextp = rpllist;
1031                 rpllist = tlist;
1032         }
1033
1034 /* So when the expression finally gets evaled, that evaluator must read
1035    from the globl   rpllist   14-jun-88 mwm */
1036
1037         q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
1038
1039         /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
1040         while(--nargs >= 0)
1041         {
1042                 if(rpllist->rplxp)
1043                         q = mkexpr(OPCOMMA, rpllist->rplxp, q);
1044                 rp = rpllist->rplnextp;
1045                 frexpr(rpllist->rplvp);
1046                 free((char *)rpllist);
1047                 rpllist = rp;
1048         }
1049         frchain( &oactp );
1050         return(q);
1051 }
1052
1053
1054 static int replaced;
1055
1056 /* mkplace -- Figure out the proper storage class for the input name and
1057    return an addrp with the appropriate stuff */
1058
1059 Addrp mkplace(np)
1060 register Namep np;
1061 {
1062         register Addrp s;
1063         register struct Rplblock *rp;
1064         int regn;
1065
1066         /* is name on the replace list? */
1067
1068         for(rp = rpllist ; rp ; rp = rp->rplnextp)
1069         {
1070                 if(np == rp->rplnp)
1071                 {
1072                         replaced = 1;
1073                         if(rp->rpltag == TNAME)
1074                         {
1075                                 np = (Namep) (rp->rplvp);
1076                                 break;
1077                         }
1078                         else    return( (Addrp) cpexpr(rp->rplvp) );
1079                 }
1080         }
1081
1082         /* is variable a DO index in a register ? */
1083
1084         if(np->vdovar && ( (regn = inregister(np)) >= 0) )
1085                 if(np->vtype == TYERROR)
1086                         return((Addrp) errnode() );
1087                 else
1088                 {
1089                         s = ALLOC(Addrblock);
1090                         s->tag = TADDR;
1091                         s->vstg = STGREG;
1092                         s->vtype = TYIREG;
1093                         s->memno = regn;
1094                         s->memoffset = ICON(0);
1095                         s -> uname_tag = UNAM_NAME;
1096                         s -> user.name = np;
1097                         return(s);
1098                 }
1099
1100         vardcl(np);
1101         return(mkaddr(np));
1102 }
1103
1104
1105  static int doing_vleng;
1106
1107 /* mklhs -- Compute the actual address of the given expression; account
1108    for array subscripts, stack offset, and substring offsets.  The f -> C
1109    translator will need this only to worry about the subscript stuff */
1110
1111 expptr mklhs(p)
1112 register struct Primblock *p;
1113 {
1114         expptr suboffset();
1115         register Addrp s;
1116         Namep np;
1117
1118         if(p->tag != TPRIM)
1119                 return( (expptr) p );
1120         np = p->namep;
1121
1122         replaced = 0;
1123         s = mkplace(np);
1124         if(s->tag!=TADDR || s->vstg==STGREG)
1125         {
1126                 free( (charptr) p );
1127                 return( (expptr) s );
1128         }
1129
1130         /* compute the address modified by subscripts */
1131
1132         if (!replaced)
1133                 s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
1134         frexpr((expptr)p->argsp);
1135         p->argsp = NULL;
1136
1137         /* now do substring part */
1138
1139         if(p->fcharp || p->lcharp)
1140         {
1141                 if(np->vtype != TYCHAR)
1142                         errstr("substring of noncharacter %s", np->fvarname);
1143                 else    {
1144                         if(p->lcharp == NULL)
1145                                 p->lcharp = (expptr) cpexpr(s->vleng);
1146                         if(p->fcharp) {
1147                                 doing_vleng = 1;
1148                                 s->vleng = fixtype(mkexpr(OPMINUS,
1149                                                 p->lcharp,
1150                                         mkexpr(OPMINUS, p->fcharp, ICON(1) )));
1151                                 doing_vleng = 0;
1152                                 }
1153                         else    {
1154                                 frexpr(s->vleng);
1155                                 s->vleng = p->lcharp;
1156                         }
1157                 }
1158         }
1159
1160         s->vleng = fixtype( s->vleng );
1161         s->memoffset = fixtype( s->memoffset );
1162         free( (charptr) p );
1163         return( (expptr) s );
1164 }
1165
1166
1167
1168
1169
1170 /* deregister -- remove a register allocation from the list; assumes that
1171    names are deregistered in stack order (LIFO order - Last In First Out) */
1172
1173 deregister(np)
1174 Namep np;
1175 {
1176         if(nregvar>0 && regnamep[nregvar-1]==np)
1177         {
1178                 --nregvar;
1179         }
1180 }
1181
1182
1183
1184
1185 /* memversion -- moves a DO index REGISTER into a memory location; other
1186    objects are passed through untouched */
1187
1188 Addrp memversion(np)
1189 register Namep np;
1190 {
1191         register Addrp s;
1192
1193         if(np->vdovar==NO || (inregister(np)<0) )
1194                 return(NULL);
1195         np->vdovar = NO;
1196         s = mkplace(np);
1197         np->vdovar = YES;
1198         return(s);
1199 }
1200
1201
1202
1203 /* inregister -- looks for the input name in the global list   regnamep */
1204
1205 inregister(np)
1206 register Namep np;
1207 {
1208         register int i;
1209
1210         for(i = 0 ; i < nregvar ; ++i)
1211                 if(regnamep[i] == np)
1212                         return( regnum[i] );
1213         return(-1);
1214 }
1215
1216
1217
1218 /* suboffset -- Compute the offset from the start of the array, given the
1219    subscripts as arguments */
1220
1221 expptr suboffset(p)
1222 register struct Primblock *p;
1223 {
1224         int n;
1225         expptr si, size;
1226         chainp cp;
1227         expptr offp, prod;
1228         expptr subcheck();
1229         struct Dimblock *dimp;
1230         expptr sub[MAXDIM+1];
1231         register Namep np;
1232
1233         np = p->namep;
1234         offp = ICON(0);
1235         n = 0;
1236         if(p->argsp)
1237                 for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
1238                 {
1239                         si = fixtype(cpexpr((tagptr)cp->datap));
1240                         if (!ISINT(si->headblock.vtype)) {
1241                                 NOEXT("non-integer subscript");
1242                                 si = mkconv(TYLONG, si);
1243                                 }
1244                         sub[n++] = si;
1245                         if(n > maxdim)
1246                         {
1247                                 erri("more than %d subscripts", maxdim);
1248                                 break;
1249                         }
1250                 }
1251
1252         dimp = np->vdim;
1253         if(n>0 && dimp==NULL)
1254                 err("subscripts on scalar variable");
1255         else if(dimp && dimp->ndim!=n)
1256                 errstr("wrong number of subscripts on %s", np->fvarname);
1257         else if(n > 0)
1258         {
1259                 prod = sub[--n];
1260                 while( --n >= 0)
1261                         prod = mkexpr(OPPLUS, sub[n],
1262                             mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
1263                 if(checksubs || np->vstg!=STGARG)
1264                         prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1265
1266 /* Add in the run-time bounds check */
1267
1268                 if(checksubs)
1269                         prod = subcheck(np, prod);
1270                 size = np->vtype == TYCHAR ?
1271                     (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
1272                 prod = mkexpr(OPSTAR, prod, size);
1273                 offp = mkexpr(OPPLUS, offp, prod);
1274         }
1275
1276 /* Check for substring indicator */
1277
1278         if(p->fcharp && np->vtype==TYCHAR)
1279                 offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) ));
1280
1281         return(offp);
1282 }
1283
1284
1285
1286
1287 expptr subcheck(np, p)
1288 Namep np;
1289 register expptr p;
1290 {
1291         struct Dimblock *dimp;
1292         expptr t, checkvar, checkcond, badcall;
1293
1294         dimp = np->vdim;
1295         if(dimp->nelt == NULL)
1296                 return(p);      /* don't check arrays with * bounds */
1297         np->vlastdim = 0;
1298         if( ISICON(p) )
1299         {
1300
1301 /* check for negative (constant) offset */
1302
1303                 if(p->constblock.Const.ci < 0)
1304                         goto badsub;
1305                 if( ISICON(dimp->nelt) )
1306
1307 /* see if constant offset exceeds the array declaration */
1308
1309                         if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
1310                                 return(p);
1311                         else
1312                                 goto badsub;
1313         }
1314
1315 /* We know that the subscript offset   p   or   dimp -> nelt   is not a constant.
1316    Now find a register to use for run-time bounds checking */
1317
1318         if(p->tag==TADDR && p->addrblock.vstg==STGREG)
1319         {
1320                 checkvar = (expptr) cpexpr(p);
1321                 t = p;
1322         }
1323         else    {
1324                 checkvar = (expptr) Mktemp(p->headblock.vtype, ENULL);
1325                 t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
1326         }
1327         checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
1328         if( ! ISICON(p) )
1329                 checkcond = mkexpr(OPAND, checkcond,
1330                     mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
1331
1332 /* Construct the actual test */
1333
1334         badcall = call4(p->headblock.vtype, "s_rnge",
1335             mkstrcon(strlen(np->fvarname), np->fvarname),
1336             mkconv(TYLONG,  cpexpr(checkvar)),
1337             mkstrcon(strlen(procname), procname),
1338             ICON(lineno) );
1339         badcall->exprblock.opcode = OPCCALL;
1340         p = mkexpr(OPQUEST, checkcond,
1341             mkexpr(OPCOLON, checkvar, badcall));
1342
1343         return(p);
1344
1345 badsub:
1346         frexpr(p);
1347         errstr("subscript on variable %s out of range", np->fvarname);
1348         return ( ICON(0) );
1349 }
1350
1351
1352
1353
1354 Addrp mkaddr(p)
1355 register Namep p;
1356 {
1357         Extsym *extp;
1358         register Addrp t;
1359         Addrp intraddr();
1360         int k;
1361
1362         switch( p->vstg)
1363         {
1364         case STGAUTO:
1365                 if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
1366                         return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
1367                 goto other;
1368
1369         case STGUNKNOWN:
1370                 if(p->vclass != CLPROC)
1371                         break;  /* Error */
1372                 extp = mkext(p->fvarname, addunder(p->cvarname));
1373                 extp->extstg = STGEXT;
1374                 p->vstg = STGEXT;
1375                 p->vardesc.varno = extp - extsymtab;
1376                 p->vprocclass = PEXTERNAL;
1377                 if ((extp->exproto || infertypes)
1378                 && (p->vtype == TYUNKNOWN || p->vimpltype)
1379                 && (k = extp->extype))
1380                         inferdcl(p, k);
1381
1382
1383         case STGCOMMON:
1384         case STGEXT:
1385         case STGBSS:
1386         case STGINIT:
1387         case STGEQUIV:
1388         case STGARG:
1389         case STGLENG:
1390  other:
1391                 t = ALLOC(Addrblock);
1392                 t->tag = TADDR;
1393
1394                 t->vclass = p->vclass;
1395                 t->vtype = p->vtype;
1396                 t->vstg = p->vstg;
1397                 t->memno = p->vardesc.varno;
1398                 t->memoffset = ICON(p->voffset);
1399                 if (p->vdim)
1400                     t->isarray = 1;
1401                 if(p->vleng)
1402                 {
1403                         t->vleng = (expptr) cpexpr(p->vleng);
1404                         if( ISICON(t->vleng) )
1405                                 t->varleng = t->vleng->constblock.Const.ci;
1406                 }
1407
1408 /* Keep the original name around for the C code generation */
1409
1410                 t -> uname_tag = UNAM_NAME;
1411                 t -> user.name = p;
1412                 return(t);
1413
1414         case STGINTR:
1415
1416                 return ( intraddr (p));
1417         }
1418         badstg("mkaddr", p->vstg);
1419         /* NOT REACHED */ return 0;
1420 }
1421
1422
1423
1424
1425 /* mkarg -- create storage for a new parameter.  This is called when a
1426    function returns a string (for the return value, which is the first
1427    parameter), or when a variable-length string is passed to a function. */
1428
1429 Addrp mkarg(type, argno)
1430 int type, argno;
1431 {
1432         register Addrp p;
1433
1434         p = ALLOC(Addrblock);
1435         p->tag = TADDR;
1436         p->vtype = type;
1437         p->vclass = CLVAR;
1438
1439 /* TYLENG is the type of the field holding the length of a character string */
1440
1441         p->vstg = (type==TYLENG ? STGLENG : STGARG);
1442         p->memno = argno;
1443         return(p);
1444 }
1445
1446
1447
1448
1449 /* mkprim -- Create a PRIM (primary/primitive) block consisting of a
1450    Nameblock (or Paramblock), arguments (actual params or array
1451    subscripts) and substring bounds.  Requires that   v   have lots of
1452    extra (uninitialized) storage, since it could be a paramblock or
1453    nameblock */
1454
1455 expptr mkprim(v0, args, substr)
1456  Namep v0;
1457  struct Listblock *args;
1458  chainp substr;
1459 {
1460         typedef union {
1461                 struct Paramblock paramblock;
1462                 struct Nameblock nameblock;
1463                 struct Headblock headblock;
1464                 } *Primu;
1465         register Primu v = (Primu)v0;
1466         register struct Primblock *p;
1467
1468         if(v->headblock.vclass == CLPARAM)
1469         {
1470
1471 /* v   is to be a Paramblock */
1472
1473                 if(args || substr)
1474                 {
1475                         errstr("no qualifiers on parameter name %s",
1476                             v->paramblock.fvarname);
1477                         frexpr((expptr)args);
1478                         if(substr)
1479                         {
1480                                 frexpr((tagptr)substr->datap);
1481                                 frexpr((tagptr)substr->nextp->datap);
1482                                 frchain(&substr);
1483                         }
1484                         frexpr((expptr)v);
1485                         return( errnode() );
1486                 }
1487                 return( (expptr) cpexpr(v->paramblock.paramval) );
1488         }
1489
1490         p = ALLOC(Primblock);
1491         p->tag = TPRIM;
1492         p->vtype = v->nameblock.vtype;
1493
1494 /* v   is to be a Nameblock */
1495
1496         p->namep = (Namep) v;
1497         p->argsp = args;
1498         if(substr)
1499         {
1500                 p->fcharp = (expptr) substr->datap;
1501                 p->lcharp = (expptr) substr->nextp->datap;
1502                 frchain(&substr);
1503         }
1504         return( (expptr) p);
1505 }
1506
1507
1508
1509 /* vardcl -- attempt to fill out the Name template for variable   v.
1510    This function is called on identifiers known to be variables or
1511    recursive references to the same function */
1512
1513 vardcl(v)
1514 register Namep v;
1515 {
1516         struct Dimblock *t;
1517         expptr neltp;
1518         extern int doing_stmtfcn;
1519
1520         if(v->vclass == CLUNKNOWN)
1521                 v->vclass = CLVAR;
1522         if(v->vdcldone)
1523                 return;
1524         if(v->vclass == CLNAMELIST)
1525                 return;
1526
1527         if(v->vtype == TYUNKNOWN)
1528                 impldcl(v);
1529         else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
1530         {
1531                 dclerr("used as variable", v);
1532                 return;
1533         }
1534         if(v->vstg==STGUNKNOWN) {
1535                 if (doing_stmtfcn) {
1536                         /* neither declare this variable if its only use */
1537                         /* is in defining a stmt function, nor complain  */
1538                         /* that it is never used */
1539                         v->vimpldovar = 1;
1540                         return;
1541                         }
1542                 v->vstg = implstg[ letter(v->fvarname[0]) ];
1543                 v->vimplstg = 1;
1544                 }
1545
1546 /* Compute the actual storage location, i.e. offsets from base addresses,
1547    possibly the stack pointer */
1548
1549         switch(v->vstg)
1550         {
1551         case STGBSS:
1552                 v->vardesc.varno = ++lastvarno;
1553                 break;
1554         case STGAUTO:
1555                 if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
1556                         break;
1557                 if(t = v->vdim)
1558                         if( (neltp = t->nelt) && ISCONST(neltp) ) ;
1559                         else
1560                                 dclerr("adjustable automatic array", v);
1561                 break;
1562
1563         default:
1564                 break;
1565         }
1566         v->vdcldone = YES;
1567 }
1568
1569
1570
1571 /* Set the implicit type declaration of parameter   p   based on its first
1572    letter */
1573
1574 impldcl(p)
1575 register Namep p;
1576 {
1577         register int k;
1578         int type;
1579         ftnint leng;
1580
1581         if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
1582                 return;
1583         if(p->vtype == TYUNKNOWN)
1584         {
1585                 k = letter(p->fvarname[0]);
1586                 type = impltype[ k ];
1587                 leng = implleng[ k ];
1588                 if(type == TYUNKNOWN)
1589                 {
1590                         if(p->vclass == CLPROC)
1591                                 return;
1592                         dclerr("attempt to use undefined variable", p);
1593                         type = dflttype[k];
1594                         leng = 0;
1595                 }
1596                 settype(p, type, leng);
1597                 p->vimpltype = 1;
1598         }
1599 }
1600
1601  void
1602 inferdcl(np,type)
1603  Namep np;
1604  int type;
1605 {
1606         int k = impltype[letter(np->fvarname[0])];
1607         if (k != type) {
1608                 np->vinftype = 1;
1609                 np->vtype = type;
1610                 frexpr(np->vleng);
1611                 np->vleng = 0;
1612                 }
1613         np->vimpltype = 0;
1614         np->vinfproc = 1;
1615         }
1616
1617
1618 #define ICONEQ(z, c)  (ISICON(z) && z->constblock.Const.ci==c)
1619 #define COMMUTE { e = lp;  lp = rp;  rp = e; }
1620
1621
1622
1623 /* mkexpr -- Make expression, and simplify constant subcomponents (tree
1624    order is not preserved).  Assumes that   lp   is nonempty, and uses
1625    fold()   to simplify adjacent constants */
1626
1627 expptr mkexpr(opcode, lp, rp)
1628 int opcode;
1629 register expptr lp, rp;
1630 {
1631         register expptr e, e1;
1632         int etype;
1633         int ltype, rtype;
1634         int ltag, rtag;
1635         long L;
1636
1637         ltype = lp->headblock.vtype;
1638         ltag = lp->tag;
1639         if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1640         {
1641                 rtype = rp->headblock.vtype;
1642                 rtag = rp->tag;
1643         }
1644         else rtype = 0;
1645
1646         etype = cktype(opcode, ltype, rtype);
1647         if(etype == TYERROR)
1648                 goto error;
1649
1650         switch(opcode)
1651         {
1652                 /* check for multiplication by 0 and 1 and addition to 0 */
1653
1654         case OPSTAR:
1655                 if( ISCONST(lp) )
1656                         COMMUTE
1657
1658                             if( ISICON(rp) )
1659                         {
1660                                 if(rp->constblock.Const.ci == 0)
1661                                         goto retright;
1662                                 goto mulop;
1663                         }
1664                 break;
1665
1666         case OPSLASH:
1667         case OPMOD:
1668                 if( ICONEQ(rp, 0) )
1669                 {
1670                         err("attempted division by zero");
1671                         rp = ICON(1);
1672                         break;
1673                 }
1674                 if(opcode == OPMOD)
1675                         break;
1676
1677 /* Handle multiplying or dividing by 1, -1 */
1678
1679 mulop:
1680                 if( ISICON(rp) )
1681                 {
1682                         if(rp->constblock.Const.ci == 1)
1683                                 goto retleft;
1684
1685                         if(rp->constblock.Const.ci == -1)
1686                         {
1687                                 frexpr(rp);
1688                                 return( mkexpr(OPNEG, lp, ENULL) );
1689                         }
1690                 }
1691
1692 /* Group all constants together.  In particular,
1693
1694         (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
1695         (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
1696 */
1697
1698                 if (lp->tag != TEXPR || !lp->exprblock.rightp
1699                                 || !ISICON(lp->exprblock.rightp))
1700                         break;
1701
1702                 if (lp->exprblock.opcode == OPLSHIFT) {
1703                         L = 1 << lp->exprblock.rightp->constblock.Const.ci;
1704                         if (opcode == OPSTAR || ISICON(rp) &&
1705                                         !(L % rp->constblock.Const.ci)) {
1706                                 lp->exprblock.opcode = OPSTAR;
1707                                 lp->exprblock.rightp->constblock.Const.ci = L;
1708                                 }
1709                         }
1710
1711                 if (lp->exprblock.opcode == OPSTAR) {
1712                         if(opcode == OPSTAR)
1713                                 e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
1714                         else if(ISICON(rp) &&
1715                             (lp->exprblock.rightp->constblock.Const.ci %
1716                             rp->constblock.Const.ci) == 0)
1717                                 e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
1718                         else    break;
1719
1720                         e1 = lp->exprblock.leftp;
1721                         free( (charptr) lp );
1722                         return( mkexpr(OPSTAR, e1, e) );
1723                         }
1724                 break;
1725
1726
1727         case OPPLUS:
1728                 if( ISCONST(lp) )
1729                         COMMUTE
1730                             goto addop;
1731
1732         case OPMINUS:
1733                 if( ICONEQ(lp, 0) )
1734                 {
1735                         frexpr(lp);
1736                         return( mkexpr(OPNEG, rp, ENULL) );
1737                 }
1738
1739                 if( ISCONST(rp) && is_negatable((Constp)rp))
1740                 {
1741                         opcode = OPPLUS;
1742                         consnegop((Constp)rp);
1743                 }
1744
1745 /* Group constants in an addition expression (also subtraction, since the
1746    subtracted value was negated above).  In particular,
1747
1748         (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
1749 */
1750
1751 addop:
1752                 if( ISICON(rp) )
1753                 {
1754                         if(rp->constblock.Const.ci == 0)
1755                                 goto retleft;
1756                         if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
1757                         {
1758                                 e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
1759                                 e1 = lp->exprblock.leftp;
1760                                 free( (charptr) lp );
1761                                 return( mkexpr(OPPLUS, e1, e) );
1762                         }
1763                 }
1764                 if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
1765                         /* check for (i [+const]) - (i [+const]) */
1766                         if (lp->tag == TPRIM)
1767                                 e = lp;
1768                         else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
1769                                         && lp->exprblock.rightp->tag == TCONST) {
1770                                 e = lp->exprblock.leftp;
1771                                 if (e->tag != TPRIM)
1772                                         break;
1773                                 }
1774                         else
1775                                 break;
1776                         if (e->primblock.argsp)
1777                                 break;
1778                         if (rp->tag == TPRIM)
1779                                 e1 = rp;
1780                         else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
1781                                         && rp->exprblock.rightp->tag == TCONST) {
1782                                 e1 = rp->exprblock.leftp;
1783                                 if (e1->tag != TPRIM)
1784                                         break;
1785                                 }
1786                         else
1787                                 break;
1788                         if (e->primblock.namep != e1->primblock.namep
1789                                         || e1->primblock.argsp)
1790                                 break;
1791                         L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
1792                         if (e1 != rp)
1793                                 L -= rp->exprblock.rightp->constblock.Const.ci;
1794                         frexpr(lp);
1795                         frexpr(rp);
1796                         return ICON(L);
1797                         }
1798
1799                 break;
1800
1801
1802         case OPPOWER:
1803                 break;
1804
1805 /* Eliminate outermost double negations */
1806
1807         case OPNEG:
1808         case OPNEG1:
1809                 if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
1810                 {
1811                         e = lp->exprblock.leftp;
1812                         free( (charptr) lp );
1813                         return(e);
1814                 }
1815                 break;
1816
1817 /* Eliminate outermost double NOTs */
1818
1819         case OPNOT:
1820                 if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
1821                 {
1822                         e = lp->exprblock.leftp;
1823                         free( (charptr) lp );
1824                         return(e);
1825                 }
1826                 break;
1827
1828         case OPCALL:
1829         case OPCCALL:
1830                 etype = ltype;
1831                 if(rp!=NULL && rp->listblock.listp==NULL)
1832                 {
1833                         free( (charptr) rp );
1834                         rp = NULL;
1835                 }
1836                 break;
1837
1838         case OPAND:
1839         case OPOR:
1840                 if( ISCONST(lp) )
1841                         COMMUTE
1842
1843                             if( ISCONST(rp) )
1844                         {
1845                                 if(rp->constblock.Const.ci == 0)
1846                                         if(opcode == OPOR)
1847                                                 goto retleft;
1848                                         else
1849                                                 goto retright;
1850                                 else if(opcode == OPOR)
1851                                         goto retright;
1852                                 else
1853                                         goto retleft;
1854                         }
1855         case OPEQV:
1856         case OPNEQV:
1857
1858         case OPBITAND:
1859         case OPBITOR:
1860         case OPBITXOR:
1861         case OPBITNOT:
1862         case OPLSHIFT:
1863         case OPRSHIFT:
1864
1865         case OPLT:
1866         case OPGT:
1867         case OPLE:
1868         case OPGE:
1869         case OPEQ:
1870         case OPNE:
1871
1872         case OPCONCAT:
1873                 break;
1874         case OPMIN:
1875         case OPMAX:
1876         case OPMIN2:
1877         case OPMAX2:
1878         case OPDMIN:
1879         case OPDMAX:
1880
1881         case OPASSIGN:
1882         case OPASSIGNI:
1883         case OPPLUSEQ:
1884         case OPSTAREQ:
1885         case OPMINUSEQ:
1886         case OPSLASHEQ:
1887         case OPMODEQ:
1888         case OPLSHIFTEQ:
1889         case OPRSHIFTEQ:
1890         case OPBITANDEQ:
1891         case OPBITXOREQ:
1892         case OPBITOREQ:
1893
1894         case OPCONV:
1895         case OPADDR:
1896         case OPWHATSIN:
1897
1898         case OPCOMMA:
1899         case OPCOMMA_ARG:
1900         case OPQUEST:
1901         case OPCOLON:
1902         case OPDOT:
1903         case OPARROW:
1904         case OPIDENTITY:
1905         case OPCHARCAST:
1906         case OPABS:
1907         case OPDABS:
1908                 break;
1909
1910         default:
1911                 badop("mkexpr", opcode);
1912         }
1913
1914         e = (expptr) ALLOC(Exprblock);
1915         e->exprblock.tag = TEXPR;
1916         e->exprblock.opcode = opcode;
1917         e->exprblock.vtype = etype;
1918         e->exprblock.leftp = lp;
1919         e->exprblock.rightp = rp;
1920         if(ltag==TCONST && (rp==0 || rtag==TCONST) )
1921                 e = fold(e);
1922         return(e);
1923
1924 retleft:
1925         frexpr(rp);
1926         return(lp);
1927
1928 retright:
1929         frexpr(lp);
1930         return(rp);
1931
1932 error:
1933         frexpr(lp);
1934         if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1935                 frexpr(rp);
1936         return( errnode() );
1937 }
1938
1939 #define ERR(s)   { errs = s; goto error; }
1940
1941 /* cktype -- Check and return the type of the expression */
1942
1943 cktype(op, lt, rt)
1944 register int op, lt, rt;
1945 {
1946         char *errs;
1947
1948         if(lt==TYERROR || rt==TYERROR)
1949                 goto error1;
1950
1951         if(lt==TYUNKNOWN)
1952                 return(TYUNKNOWN);
1953         if(rt==TYUNKNOWN)
1954
1955 /* If not unary operation, return UNKNOWN */
1956
1957                 if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
1958                         return(TYUNKNOWN);
1959
1960         switch(op)
1961         {
1962         case OPPLUS:
1963         case OPMINUS:
1964         case OPSTAR:
1965         case OPSLASH:
1966         case OPPOWER:
1967         case OPMOD:
1968                 if( ISNUMERIC(lt) && ISNUMERIC(rt) )
1969                         return( maxtype(lt, rt) );
1970                 ERR("nonarithmetic operand of arithmetic operator")
1971
1972         case OPNEG:
1973         case OPNEG1:
1974                 if( ISNUMERIC(lt) )
1975                         return(lt);
1976                 ERR("nonarithmetic operand of negation")
1977
1978         case OPNOT:
1979                 if(lt == TYLOGICAL)
1980                         return(TYLOGICAL);
1981                 ERR("NOT of nonlogical")
1982
1983         case OPAND:
1984         case OPOR:
1985         case OPEQV:
1986         case OPNEQV:
1987                 if(lt==TYLOGICAL && rt==TYLOGICAL)
1988                         return(TYLOGICAL);
1989                 ERR("nonlogical operand of logical operator")
1990
1991         case OPLT:
1992         case OPGT:
1993         case OPLE:
1994         case OPGE:
1995         case OPEQ:
1996         case OPNE:
1997                 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1998                 {
1999                         if(lt != rt)
2000                                 ERR("illegal comparison")
2001                 }
2002
2003                 else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
2004                 {
2005                         if(op!=OPEQ && op!=OPNE)
2006                                 ERR("order comparison of complex data")
2007                 }
2008
2009                 else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
2010                         ERR("comparison of nonarithmetic data")
2011                             return(TYLOGICAL);
2012
2013         case OPCONCAT:
2014                 if(lt==TYCHAR && rt==TYCHAR)
2015                         return(TYCHAR);
2016                 ERR("concatenation of nonchar data")
2017
2018         case OPCALL:
2019         case OPCCALL:
2020         case OPIDENTITY:
2021                 return(lt);
2022
2023         case OPADDR:
2024         case OPCHARCAST:
2025                 return(TYADDR);
2026
2027         case OPCONV:
2028                 if(rt == 0)
2029                         return(0);
2030                 if(lt==TYCHAR && ISINT(rt) )
2031                         return(TYCHAR);
2032         case OPASSIGN:
2033         case OPASSIGNI:
2034         case OPMINUSEQ:
2035         case OPPLUSEQ:
2036         case OPSTAREQ:
2037         case OPSLASHEQ:
2038         case OPMODEQ:
2039         case OPLSHIFTEQ:
2040         case OPRSHIFTEQ:
2041         case OPBITANDEQ:
2042         case OPBITXOREQ:
2043         case OPBITOREQ:
2044                 if( ISINT(lt) && rt==TYCHAR)
2045                         return(lt);
2046                 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
2047                         if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
2048                             || (lt!=rt))
2049                         {
2050                                 ERR("impossible conversion")
2051                         }
2052                 return(lt);
2053
2054         case OPMIN:
2055         case OPMAX:
2056         case OPDMIN:
2057         case OPDMAX:
2058         case OPMIN2:
2059         case OPMAX2:
2060         case OPBITOR:
2061         case OPBITAND:
2062         case OPBITXOR:
2063         case OPBITNOT:
2064         case OPLSHIFT:
2065         case OPRSHIFT:
2066         case OPWHATSIN:
2067         case OPABS:
2068         case OPDABS:
2069                 return(lt);
2070
2071         case OPCOMMA:
2072         case OPCOMMA_ARG:
2073         case OPQUEST:
2074         case OPCOLON:           /* Only checks the rightmost type because
2075                                    of C language definition (rightmost
2076                                    comma-expr is the value of the expr) */
2077                 return(rt);
2078
2079         case OPDOT:
2080         case OPARROW:
2081             return (lt);
2082             break;
2083         default:
2084                 badop("cktype", op);
2085         }
2086 error:
2087         err(errs);
2088 error1:
2089         return(TYERROR);
2090 }
2091
2092 /* fold -- simplifies constant expressions; it assumes that e -> leftp and
2093    e -> rightp are TCONST or NULL */
2094
2095  LOCAL expptr
2096 fold(e)
2097  register expptr e;
2098 {
2099         Constp p;
2100         register expptr lp, rp;
2101         int etype, mtype, ltype, rtype, opcode;
2102         int i, ll, lr;
2103         char *q, *s;
2104         struct Constblock lcon, rcon;
2105         long L;
2106         double d;
2107
2108         opcode = e->exprblock.opcode;
2109         etype = e->exprblock.vtype;
2110
2111         lp = e->exprblock.leftp;
2112         ltype = lp->headblock.vtype;
2113         rp = e->exprblock.rightp;
2114
2115         if(rp == 0)
2116                 switch(opcode)
2117                 {
2118                 case OPNOT:
2119                         lp->constblock.Const.ci = ! lp->constblock.Const.ci;
2120  retlp:
2121                         e->exprblock.leftp = 0;
2122                         frexpr(e);
2123                         return(lp);
2124
2125                 case OPBITNOT:
2126                         lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
2127                         goto retlp;
2128
2129                 case OPNEG:
2130                 case OPNEG1:
2131                         consnegop((Constp)lp);
2132                         goto retlp;
2133
2134                 case OPCONV:
2135                 case OPADDR:
2136                         return(e);
2137
2138                 case OPABS:
2139                 case OPDABS:
2140                         switch(ltype) {
2141                             case TYSHORT:
2142                             case TYLONG:
2143                                 if ((L = lp->constblock.Const.ci) < 0)
2144                                         lp->constblock.Const.ci = -L;
2145                                 goto retlp;
2146                             case TYREAL:
2147                             case TYDREAL:
2148                                 if (lp->constblock.vstg) {
2149                                     s = lp->constblock.Const.cds[0];
2150                                     if (*s == '-')
2151                                         lp->constblock.Const.cds[0] = s + 1;
2152                                     goto retlp;
2153                                 }
2154                                 if ((d = lp->constblock.Const.cd[0]) < 0.)
2155                                         lp->constblock.Const.cd[0] = -d;
2156                             case TYCOMPLEX:
2157                             case TYDCOMPLEX:
2158                                 return e;       /* lazy way out */
2159                             }
2160                 default:
2161                         badop("fold", opcode);
2162                 }
2163
2164         rtype = rp->headblock.vtype;
2165
2166         p = ALLOC(Constblock);
2167         p->tag = TCONST;
2168         p->vtype = etype;
2169         p->vleng = e->exprblock.vleng;
2170
2171         switch(opcode)
2172         {
2173         case OPCOMMA:
2174         case OPCOMMA_ARG:
2175         case OPQUEST:
2176         case OPCOLON:
2177                 return(e);
2178
2179         case OPAND:
2180                 p->Const.ci = lp->constblock.Const.ci &&
2181                     rp->constblock.Const.ci;
2182                 break;
2183
2184         case OPOR:
2185                 p->Const.ci = lp->constblock.Const.ci ||
2186                     rp->constblock.Const.ci;
2187                 break;
2188
2189         case OPEQV:
2190                 p->Const.ci = lp->constblock.Const.ci ==
2191                     rp->constblock.Const.ci;
2192                 break;
2193
2194         case OPNEQV:
2195                 p->Const.ci = lp->constblock.Const.ci !=
2196                     rp->constblock.Const.ci;
2197                 break;
2198
2199         case OPBITAND:
2200                 p->Const.ci = lp->constblock.Const.ci &
2201                     rp->constblock.Const.ci;
2202                 break;
2203
2204         case OPBITOR:
2205                 p->Const.ci = lp->constblock.Const.ci |
2206                     rp->constblock.Const.ci;
2207                 break;
2208
2209         case OPBITXOR:
2210                 p->Const.ci = lp->constblock.Const.ci ^
2211                     rp->constblock.Const.ci;
2212                 break;
2213
2214         case OPLSHIFT:
2215                 p->Const.ci = lp->constblock.Const.ci <<
2216                     rp->constblock.Const.ci;
2217                 break;
2218
2219         case OPRSHIFT:
2220                 p->Const.ci = lp->constblock.Const.ci >>
2221                     rp->constblock.Const.ci;
2222                 break;
2223
2224         case OPCONCAT:
2225                 ll = lp->constblock.vleng->constblock.Const.ci;
2226                 lr = rp->constblock.vleng->constblock.Const.ci;
2227                 p->Const.ccp = q = (char *) ckalloc(ll+lr);
2228                 p->Const.ccp1.blanks = 0;
2229                 p->vleng = ICON(ll+lr);
2230                 s = lp->constblock.Const.ccp;
2231                 for(i = 0 ; i < ll ; ++i)
2232                         *q++ = *s++;
2233                 s = rp->constblock.Const.ccp;
2234                 for(i = 0; i < lr; ++i)
2235                         *q++ = *s++;
2236                 break;
2237
2238
2239         case OPPOWER:
2240                 if( ! ISINT(rtype) )
2241                         return(e);
2242                 conspower(p, (Constp)lp, rp->constblock.Const.ci);
2243                 break;
2244
2245
2246         default:
2247                 if(ltype == TYCHAR)
2248                 {
2249                         lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
2250                             rp->constblock.Const.ccp,
2251                             lp->constblock.vleng->constblock.Const.ci,
2252                             rp->constblock.vleng->constblock.Const.ci);
2253                         rcon.Const.ci = 0;
2254                         mtype = tyint;
2255                 }
2256                 else    {
2257                         mtype = maxtype(ltype, rtype);
2258                         consconv(mtype, &lcon, &lp->constblock);
2259                         consconv(mtype, &rcon, &rp->constblock);
2260                 }
2261                 consbinop(opcode, mtype, p, &lcon, &rcon);
2262                 break;
2263         }
2264
2265         frexpr(e);
2266         return( (expptr) p );
2267 }
2268
2269
2270
2271 /* assign constant l = r , doing coercion */
2272
2273 consconv(lt, lc, rc)
2274  int lt;
2275  register Constp lc, rc;
2276 {
2277         int rt = rc->vtype;
2278         register union Constant *lv = &lc->Const, *rv = &rc->Const;
2279
2280         lc->vtype = lt;
2281         if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
2282                 memcpy((char *)lv, (char *)rv, sizeof(union Constant));
2283                 lc->vstg = rc->vstg;
2284                 if (ISCOMPLEX(lt) && ISREAL(rt)) {
2285                         if (rc->vstg)
2286                                 lv->cds[1] = cds("0",CNULL);
2287                         else
2288                                 lv->cd[1] = 0.;
2289                         }
2290                 return;
2291                 }
2292         lc->vstg = 0;
2293
2294         switch(lt)
2295         {
2296
2297 /* Casting to character means just copying the first sizeof (character)
2298    bytes into a new 1 character string.  This is weird. */
2299
2300         case TYCHAR:
2301                 *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
2302                 lv->ccp1.blanks = 0;
2303                 break;
2304
2305         case TYSHORT:
2306         case TYLONG:
2307                 if(rt == TYCHAR)
2308                         lv->ci = rv->ccp[0];
2309                 else if( ISINT(rt) )
2310                         lv->ci = rv->ci;
2311                 else    lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];
2312
2313                 break;
2314
2315         case TYCOMPLEX:
2316         case TYDCOMPLEX:
2317                 lv->cd[1] = 0.;
2318                 lv->cd[0] = rv->ci;
2319                 break;
2320
2321         case TYREAL:
2322         case TYDREAL:
2323                 lv->cd[0] = rv->ci;
2324                 break;
2325
2326         case TYLOGICAL:
2327                 lv->ci = rv->ci;
2328                 break;
2329         }
2330 }
2331
2332
2333
2334 /* Negate constant value -- changes the input node's value */
2335
2336 consnegop(p)
2337 register Constp p;
2338 {
2339         register char *s;
2340
2341         if (p->vstg) {
2342                 if (ISCOMPLEX(p->vtype)) {
2343                         s = p->Const.cds[1];
2344                         p->Const.cds[1] = *s == '-' ? s+1
2345                                         : *s == '0' ? s : s-1;
2346                         }
2347                 s = p->Const.cds[0];
2348                 p->Const.cds[0] = *s == '-' ? s+1
2349                                 : *s == '0' ? s : s-1;
2350                 return;
2351                 }
2352         switch(p->vtype)
2353         {
2354         case TYSHORT:
2355         case TYLONG:
2356                 p->Const.ci = - p->Const.ci;
2357                 break;
2358
2359         case TYCOMPLEX:
2360         case TYDCOMPLEX:
2361                 p->Const.cd[1] = - p->Const.cd[1];
2362                 /* fall through and do the real parts */
2363         case TYREAL:
2364         case TYDREAL:
2365                 p->Const.cd[0] = - p->Const.cd[0];
2366                 break;
2367         default:
2368                 badtype("consnegop", p->vtype);
2369         }
2370 }
2371
2372
2373
2374 /* conspower -- Expand out an exponentiation */
2375
2376  LOCAL void
2377 conspower(p, ap, n)
2378  Constp p, ap;
2379  ftnint n;
2380 {
2381         register union Constant *powp = &p->Const;
2382         register int type;
2383         struct Constblock x, x0;
2384
2385         if (n == 1) {
2386                 memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
2387                 return;
2388                 }
2389
2390         switch(type = ap->vtype)        /* pow = 1 */
2391         {
2392         case TYSHORT:
2393         case TYLONG:
2394                 powp->ci = 1;
2395                 break;
2396         case TYCOMPLEX:
2397         case TYDCOMPLEX:
2398                 powp->cd[1] = 0;
2399         case TYREAL:
2400         case TYDREAL:
2401                 powp->cd[0] = 1;
2402                 break;
2403         default:
2404                 badtype("conspower", type);
2405         }
2406
2407         if(n == 0)
2408                 return;
2409         switch(type)    /* x0 = ap */
2410         {
2411         case TYSHORT:
2412         case TYLONG:
2413                 x0.Const.ci = ap->Const.ci;
2414                 break;
2415         case TYCOMPLEX:
2416         case TYDCOMPLEX:
2417                 x0.Const.cd[1] =
2418                         ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
2419         case TYREAL:
2420         case TYDREAL:
2421                 x0.Const.cd[0] =
2422                         ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
2423                 break;
2424         }
2425         x0.vtype = type;
2426         x0.vstg = 0;
2427         if(n < 0)
2428         {
2429                 if( ISINT(type) )
2430                 {
2431                         err("integer ** negative number");
2432                         return;
2433                 }
2434                 else if (!x0.Const.cd[0]
2435                                 && (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
2436                         err("0.0 ** negative number");
2437                         return;
2438                         }
2439                 n = -n;
2440                 consbinop(OPSLASH, type, &x, p, &x0);
2441         }
2442         else
2443                 consbinop(OPSTAR, type, &x, p, &x0);
2444
2445         for( ; ; )
2446         {
2447                 if(n & 01)
2448                         consbinop(OPSTAR, type, p, p, &x);
2449                 if(n >>= 1)
2450                         consbinop(OPSTAR, type, &x, &x, &x);
2451                 else
2452                         break;
2453         }
2454 }
2455
2456
2457
2458 /* do constant operation cp = a op b -- assumes that   ap and bp   have data
2459    matching the input   type */
2460
2461
2462  LOCAL void
2463 consbinop(opcode, type, cpp, app, bpp)
2464  int opcode, type;
2465  Constp cpp, app, bpp;
2466 {
2467         register union Constant *ap = &app->Const,
2468                                 *bp = &bpp->Const,
2469                                 *cp = &cpp->Const;
2470         int k;
2471         double ad[2], bd[2], temp;
2472
2473         cpp->vstg = 0;
2474
2475         if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
2476                 ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
2477                 bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
2478                 if (ISCOMPLEX(type)) {
2479                         ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
2480                         bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
2481                         }
2482                 }
2483         switch(opcode)
2484         {
2485         case OPPLUS:
2486                 switch(type)
2487                 {
2488                 case TYSHORT:
2489                 case TYLONG:
2490                         cp->ci = ap->ci + bp->ci;
2491                         break;
2492                 case TYCOMPLEX:
2493                 case TYDCOMPLEX:
2494                         cp->cd[1] = ad[1] + bd[1];
2495                 case TYREAL:
2496                 case TYDREAL:
2497                         cp->cd[0] = ad[0] + bd[0];
2498                         break;
2499                 }
2500                 break;
2501
2502         case OPMINUS:
2503                 switch(type)
2504                 {
2505                 case TYSHORT:
2506                 case TYLONG:
2507                         cp->ci = ap->ci - bp->ci;
2508                         break;
2509                 case TYCOMPLEX:
2510                 case TYDCOMPLEX:
2511                         cp->cd[1] = ad[1] - bd[1];
2512                 case TYREAL:
2513                 case TYDREAL:
2514                         cp->cd[0] = ad[0] - bd[0];
2515                         break;
2516                 }
2517                 break;
2518
2519         case OPSTAR:
2520                 switch(type)
2521                 {
2522                 case TYSHORT:
2523                 case TYLONG:
2524                         cp->ci = ap->ci * bp->ci;
2525                         break;
2526                 case TYREAL:
2527                 case TYDREAL:
2528                         cp->cd[0] = ad[0] * bd[0];
2529                         break;
2530                 case TYCOMPLEX:
2531                 case TYDCOMPLEX:
2532                         temp = ad[0] * bd[0]  -  ad[1] * bd[1] ;
2533                         cp->cd[1] = ad[0] * bd[1]  +  ad[1] * bd[0] ;
2534                         cp->cd[0] = temp;
2535                         break;
2536                 }
2537                 break;
2538         case OPSLASH:
2539                 switch(type)
2540                 {
2541                 case TYSHORT:
2542                 case TYLONG:
2543                         cp->ci = ap->ci / bp->ci;
2544                         break;
2545                 case TYREAL:
2546                 case TYDREAL:
2547                         cp->cd[0] = ad[0] / bd[0];
2548                         break;
2549                 case TYCOMPLEX:
2550                 case TYDCOMPLEX:
2551                         zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
2552                         break;
2553                 }
2554                 break;
2555
2556         case OPMOD:
2557                 if( ISINT(type) )
2558                 {
2559                         cp->ci = ap->ci % bp->ci;
2560                         break;
2561                 }
2562                 else
2563                         Fatal("inline mod of noninteger");
2564
2565         case OPMIN2:
2566         case OPDMIN:
2567                 switch(type)
2568                 {
2569                 case TYSHORT:
2570                 case TYLONG:
2571                         cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
2572                         break;
2573                 case TYREAL:
2574                 case TYDREAL:
2575                         cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
2576                         break;
2577                 default:
2578                         Fatal("inline min of exected type");
2579                 }
2580                 break;
2581
2582         case OPMAX2:
2583         case OPDMAX:
2584                 switch(type)
2585                 {
2586                 case TYSHORT:
2587                 case TYLONG:
2588                         cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
2589                         break;
2590                 case TYREAL:
2591                 case TYDREAL:
2592                         cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
2593                         break;
2594                 default:
2595                         Fatal("inline max of exected type");
2596                 }
2597                 break;
2598
2599         default:          /* relational ops */
2600                 switch(type)
2601                 {
2602                 case TYSHORT:
2603                 case TYLONG:
2604                         if(ap->ci < bp->ci)
2605                                 k = -1;
2606                         else if(ap->ci == bp->ci)
2607                                 k = 0;
2608                         else    k = 1;
2609                         break;
2610                 case TYREAL:
2611                 case TYDREAL:
2612                         if(ad[0] < bd[0])
2613                                 k = -1;
2614                         else if(ad[0] == bd[0])
2615                                 k = 0;
2616                         else    k = 1;
2617                         break;
2618                 case TYCOMPLEX:
2619                 case TYDCOMPLEX:
2620                         if(ad[0] == bd[0] &&
2621                             ad[1] == bd[1] )
2622                                 k = 0;
2623                         else    k = 1;
2624                         break;
2625                 }
2626
2627                 switch(opcode)
2628                 {
2629                 case OPEQ:
2630                         cp->ci = (k == 0);
2631                         break;
2632                 case OPNE:
2633                         cp->ci = (k != 0);
2634                         break;
2635                 case OPGT:
2636                         cp->ci = (k == 1);
2637                         break;
2638                 case OPLT:
2639                         cp->ci = (k == -1);
2640                         break;
2641                 case OPGE:
2642                         cp->ci = (k >= 0);
2643                         break;
2644                 case OPLE:
2645                         cp->ci = (k <= 0);
2646                         break;
2647                 }
2648                 break;
2649         }
2650 }
2651
2652
2653
2654 /* conssgn - returns the sign of a Fortran constant */
2655
2656 conssgn(p)
2657 register expptr p;
2658 {
2659         register char *s;
2660
2661         if( ! ISCONST(p) )
2662                 Fatal( "sgn(nonconstant)" );
2663
2664         switch(p->headblock.vtype)
2665         {
2666         case TYSHORT:
2667         case TYLONG:
2668                 if(p->constblock.Const.ci > 0) return(1);
2669                 if(p->constblock.Const.ci < 0) return(-1);
2670                 return(0);
2671
2672         case TYREAL:
2673         case TYDREAL:
2674                 if (p->constblock.vstg) {
2675                         s = p->constblock.Const.cds[0];
2676                         if (*s == '-')
2677                                 return -1;
2678                         if (*s == '0')
2679                                 return 0;
2680                         return 1;
2681                         }
2682                 if(p->constblock.Const.cd[0] > 0) return(1);
2683                 if(p->constblock.Const.cd[0] < 0) return(-1);
2684                 return(0);
2685
2686
2687 /* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */
2688
2689         case TYCOMPLEX:
2690         case TYDCOMPLEX:
2691                 if (p->constblock.vstg)
2692                         return *p->constblock.Const.cds[0] != '0'
2693                             && *p->constblock.Const.cds[1] != '0';
2694                 return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
2695
2696         default:
2697                 badtype( "conssgn", p->constblock.vtype);
2698         }
2699         /* NOT REACHED */ return 0;
2700 }
2701
2702 char *powint[ ] = {
2703         "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
2704
2705 LOCAL expptr mkpower(p)
2706 register expptr p;
2707 {
2708         register expptr q, lp, rp;
2709         int ltype, rtype, mtype, tyi;
2710
2711         lp = p->exprblock.leftp;
2712         rp = p->exprblock.rightp;
2713         ltype = lp->headblock.vtype;
2714         rtype = rp->headblock.vtype;
2715
2716         if(ISICON(rp))
2717         {
2718                 if(rp->constblock.Const.ci == 0)
2719                 {
2720                         frexpr(p);
2721                         if( ISINT(ltype) )
2722                                 return( ICON(1) );
2723                         else if (ISREAL (ltype))
2724                                 return mkconv (ltype, ICON (1));
2725                         else
2726                                 return( (expptr) putconst((Constp)
2727                                         mkconv(ltype, ICON(1))) );
2728                 }
2729                 if(rp->constblock.Const.ci < 0)
2730                 {
2731                         if( ISINT(ltype) )
2732                         {
2733                                 frexpr(p);
2734                                 err("integer**negative");
2735                                 return( errnode() );
2736                         }
2737                         rp->constblock.Const.ci = - rp->constblock.Const.ci;
2738                         p->exprblock.leftp = lp
2739                                 = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
2740                 }
2741                 if(rp->constblock.Const.ci == 1)
2742                 {
2743                         frexpr(rp);
2744                         free( (charptr) p );
2745                         return(lp);
2746                 }
2747
2748                 if( ONEOF(ltype, MSKINT|MSKREAL) && !doin_setbound) {
2749                         p->exprblock.vtype = ltype;
2750                         return(p);
2751                 }
2752         }
2753         if( ISINT(rtype) )
2754         {
2755                 if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
2756                         q = call2(TYSHORT, "pow_hh", lp, rp);
2757                 else    {
2758                         if(ltype == TYSHORT)
2759                         {
2760                                 ltype = TYLONG;
2761                                 lp = mkconv(TYLONG,lp);
2762                         }
2763                         rp = mkconv(TYLONG,rp);
2764                         if (ISCONST(rp)) {
2765                                 tyi = tyint;
2766                                 tyint = TYLONG;
2767                                 rp = (expptr)putconst((Constp)rp);
2768                                 tyint = tyi;
2769                                 }
2770                         q = call2(ltype, powint[ltype-TYLONG], lp, rp);
2771                 }
2772         }
2773         else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
2774                 extern int callk_kludge;
2775                 callk_kludge = TYDREAL;
2776                 q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
2777                 callk_kludge = 0;
2778                 }
2779         else    {
2780                 q  = call2(TYDCOMPLEX, "pow_zz",
2781                     mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
2782                 if(mtype == TYCOMPLEX)
2783                         q = mkconv(TYCOMPLEX, q);
2784         }
2785         free( (charptr) p );
2786         return(q);
2787 }
2788
2789
2790 /* Complex Division.  Same code as in Runtime Library
2791 */
2792
2793
2794  LOCAL void
2795 zdiv(c, a, b)
2796  register dcomplex *a, *b, *c;
2797 {
2798         double ratio, den;
2799         double abr, abi;
2800
2801         if( (abr = b->dreal) < 0.)
2802                 abr = - abr;
2803         if( (abi = b->dimag) < 0.)
2804                 abi = - abi;
2805         if( abr <= abi )
2806         {
2807                 if(abi == 0)
2808                         Fatal("complex division by zero");
2809                 ratio = b->dreal / b->dimag ;
2810                 den = b->dimag * (1 + ratio*ratio);
2811                 c->dreal = (a->dreal*ratio + a->dimag) / den;
2812                 c->dimag = (a->dimag*ratio - a->dreal) / den;
2813         }
2814
2815         else
2816         {
2817                 ratio = b->dimag / b->dreal ;
2818                 den = b->dreal * (1 + ratio*ratio);
2819                 c->dreal = (a->dreal + a->dimag*ratio) / den;
2820                 c->dimag = (a->dimag - a->dreal*ratio) / den;
2821         }
2822 }