lang/fortran/comp/expr.c

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