lang/fortran/comp/putpcc.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 /* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
  25 /* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
  26
  27 #include "defs.h"
  28 #include "pccdefs.h"
  29 #include "output.h"             /* for nice_printf */
  30 #include "names.h"
  31 #include "p1defs.h"
  32
  33 Addrp realpart();
  34 LOCAL Addrp intdouble(), putcx1(), putcxeq (), putch1 ();
  35 LOCAL putct1 ();
  36
  37 expptr putcxop();
  38 LOCAL expptr putcall (), putmnmx (), putcheq(), putcat ();
  39 LOCAL expptr putaddr(), putchcmp (), putpower(), putop();
  40 LOCAL expptr putcxcmp ();
  41 expptr imagpart();
  42 ftnint lencat();
  43
  44 #define FOUR 4
  45 extern int ops2[];
  46 extern int types2[];
  47 extern int proc_argchanges, proc_protochanges;
  48 extern int krparens;
  49
  50 #define P2BUFFMAX 128
  51
  52 /* Puthead -- output the header information about subroutines, functions
  53    and entry points */
  54
  55 puthead(s, class)
  56 char *s;
  57 int class;
  58 {
  59         if (headerdone == NO) {
  60                 if (class == CLMAIN)
  61                         s = "MAIN__";
  62                 p1_head (class, s);
  63                 headerdone = YES;
  64                 }
  65 }
  66
  67 putif(p, else_if_p)
  68  register expptr p;
  69  int else_if_p;
  70 {
  71         register int k;
  72         int n;
  73         long where;
  74
  75         if (else_if_p) {
  76                 p1put(P1_ELSEIFSTART);
  77                 where = ftell(pass1_file);
  78                 }
  79         if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
  80         {
  81                 if(k != TYERROR)
  82                         err("non-logical expression in IF statement");
  83                 }
  84         else {
  85                 if (else_if_p) {
  86                         if (ei_next >= ei_last)
  87                                 {
  88                                 k = ei_last - ei_first;
  89                                 n = k + 100;
  90                                 ei_next = mem(n,0);
  91                                 ei_last = ei_first + n;
  92                                 if (k)
  93                                         memcpy(ei_next, ei_first, k);
  94                                 ei_first =  ei_next;
  95                                 ei_next += k;
  96                                 ei_last = ei_first + n;
  97                                 }
  98                         p = putx(p);
  99                         if (*ei_next++ = ftell(pass1_file) > where) {
 100                                 p1_if(p);
 101                                 new_endif();
 102                                 }
 103                         else
 104                                 p1_elif(p);
 105                         }
 106                 else {
 107                         p = putx(p);
 108                         p1_if(p);
 109                         }
 110                 }
 111         }
 112
 113
 114 putexpr(p)
 115 expptr p;
 116 {
 117         putex1(p);
 118 }
 119
 120
 121 putout(p)
 122 expptr p;
 123 {
 124         p1_expr (p);
 125
 126 /* Used to make temporaries in holdtemps available here, but they */
 127 /* may be reused too soon (e.g. when multiple **'s are involved). */
 128 }
 129
 130
 131
 132 putcmgo(index, nlab, labs)
 133 expptr index;
 134 int nlab;
 135 struct Labelblock *labs[];
 136 {
 137         if(! ISINT(index->headblock.vtype) )
 138         {
 139                 execerr("computed goto index must be integer", CNULL);
 140                 return;
 141         }
 142
 143         p1comp_goto (index, nlab, labs);
 144 }
 145
 146  static expptr
 147 krput(p)
 148  register expptr p;
 149 {
 150         register expptr e, e1;
 151         register unsigned op;
 152         int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
 153
 154         op = p->exprblock.opcode;
 155         e = p->exprblock.leftp;
 156         if (e->tag == TEXPR && e->exprblock.opcode == op) {
 157                 e1 = (expptr)mktmp(t, ENULL);
 158                 putout(putassign(cpexpr(e1), e));
 159                 p->exprblock.leftp = e1;
 160                 }
 161         else
 162                 p->exprblock.leftp = putx(e);
 163
 164         e = p->exprblock.rightp;
 165         if (e->tag == TEXPR && e->exprblock.opcode == op) {
 166                 e1 = (expptr)mktmp(t, ENULL);
 167                 putout(putassign(cpexpr(e1), e));
 168                 p->exprblock.rightp = e1;
 169                 }
 170         else
 171                 p->exprblock.rightp = putx(e);
 172         return p;
 173         }
 174
 175 expptr putx(p)
 176  register expptr p;
 177 {
 178         int opc;
 179         int k;
 180
 181         if (p)
 182           switch(p->tag)
 183         {
 184         case TERROR:
 185                 break;
 186
 187         case TCONST:
 188                 switch(p->constblock.vtype)
 189                 {
 190                 case TYLOGICAL:
 191                 case TYLONG:
 192                 case TYSHORT:
 193                         break;
 194
 195                 case TYADDR:
 196                         break;
 197                 case TYREAL:
 198                 case TYDREAL:
 199
 200 /* Don't write it out to the p2 file, since you'd need to call putconst,
 201    which is just what we need to avoid in the translator */
 202
 203                         break;
 204                 default:
 205                         p = putx( (expptr)putconst((Constp)p) );
 206                         break;
 207                 }
 208                 break;
 209
 210         case TEXPR:
 211                 switch(opc = p->exprblock.opcode)
 212                 {
 213                 case OPCALL:
 214                 case OPCCALL:
 215                         if( ISCOMPLEX(p->exprblock.vtype) )
 216                                 p = putcxop(p);
 217                         else    p = putcall(p, (Addrp *)NULL);
 218                         break;
 219
 220                 case OPMIN:
 221                 case OPMAX:
 222                         p = putmnmx(p);
 223                         break;
 224
 225
 226                 case OPASSIGN:
 227                         if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
 228                             || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
 229                                 (void) putcxeq(p);
 230                                 p = ENULL;
 231                         } else if( ISCHAR(p) )
 232                                 p = putcheq(p);
 233                         else
 234                                 goto putopp;
 235                         break;
 236
 237                 case OPEQ:
 238                 case OPNE:
 239                         if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
 240                             ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
 241                         {
 242                                 p = putcxcmp(p);
 243                                 break;
 244                         }
 245                 case OPLT:
 246                 case OPLE:
 247                 case OPGT:
 248                 case OPGE:
 249                         if(ISCHAR(p->exprblock.leftp))
 250                         {
 251                                 p = putchcmp(p);
 252                                 break;
 253                         }
 254                         goto putopp;
 255
 256                 case OPPOWER:
 257                         p = putpower(p);
 258                         break;
 259
 260                 case OPSTAR:
 261                         /*   m * (2**k) -> m<<k   */
 262                         if(INT(p->exprblock.leftp->headblock.vtype) &&
 263                             ISICON(p->exprblock.rightp) &&
 264                             ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
 265                         {
 266                                 p->exprblock.opcode = OPLSHIFT;
 267                                 frexpr(p->exprblock.rightp);
 268                                 p->exprblock.rightp = ICON(k);
 269                                 goto putopp;
 270                         }
 271                         if (krparens && ISREAL(p->exprblock.vtype))
 272                                 return krput(p);
 273
 274                 case OPMOD:
 275                         goto putopp;
 276                 case OPPLUS:
 277                         if (krparens && ISREAL(p->exprblock.vtype))
 278                                 return krput(p);
 279                 case OPMINUS:
 280                 case OPSLASH:
 281                 case OPNEG:
 282                 case OPNEG1:
 283                 case OPABS:
 284                 case OPDABS:
 285                         if( ISCOMPLEX(p->exprblock.vtype) )
 286                                 p = putcxop(p);
 287                         else    goto putopp;
 288                         break;
 289
 290                 case OPCONV:
 291                         if( ISCOMPLEX(p->exprblock.vtype) )
 292                                 p = putcxop(p);
 293                         else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
 294                         {
 295                                 p = putx( mkconv(p->exprblock.vtype,
 296                                     (expptr)realpart(putcx1(p->exprblock.leftp))));
 297                         }
 298                         else    goto putopp;
 299                         break;
 300
 301                 case OPNOT:
 302                 case OPOR:
 303                 case OPAND:
 304                 case OPEQV:
 305                 case OPNEQV:
 306                 case OPADDR:
 307                 case OPPLUSEQ:
 308                 case OPSTAREQ:
 309                 case OPCOMMA:
 310                 case OPQUEST:
 311                 case OPCOLON:
 312                 case OPBITOR:
 313                 case OPBITAND:
 314                 case OPBITXOR:
 315                 case OPBITNOT:
 316                 case OPLSHIFT:
 317                 case OPRSHIFT:
 318                 case OPASSIGNI:
 319                 case OPIDENTITY:
 320                 case OPCHARCAST:
 321                 case OPMIN2:
 322                 case OPMAX2:
 323                 case OPDMIN:
 324                 case OPDMAX:
 325 putopp:
 326                         p = putop(p);
 327                         break;
 328
 329                 default:
 330                         badop("putx", opc);
 331                         p = errnode ();
 332                 }
 333                 break;
 334
 335         case TADDR:
 336                 p = putaddr(p);
 337                 break;
 338
 339         default:
 340                 badtag("putx", p->tag);
 341                 p = errnode ();
 342         }
 343
 344         return p;
 345 }
 346
 347
 348
 349 LOCAL expptr putop(p)
 350 expptr p;
 351 {
 352         expptr lp, tp;
 353         int pt, lt, lt1;
 354         int comma;
 355
 356         switch(p->exprblock.opcode)     /* check for special cases and rewrite */
 357         {
 358         case OPCONV:
 359                 pt = p->exprblock.vtype;
 360                 lp = p->exprblock.leftp;
 361                 lt = lp->headblock.vtype;
 362
 363 /* Simplify nested type casts */
 364
 365                 while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
 366                     ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) ||
 367                     (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
 368                 {
 369                         if(pt==TYDREAL && lt==TYREAL)
 370                         {
 371                                 if(lp->tag==TEXPR
 372                                 && lp->exprblock.opcode == OPCONV) {
 373                                     lt1 = lp->exprblock.leftp->headblock.vtype;
 374                                     if (lt1 == TYDREAL) {
 375                                         lp->exprblock.leftp =
 376                                                 putx(lp->exprblock.leftp);
 377                                         return p;
 378                                         }
 379                                     if (lt1 == TYDCOMPLEX) {
 380                                         lp->exprblock.leftp = putx(
 381                                                 (expptr)realpart(
 382                                                 putcx1(lp->exprblock.leftp)));
 383                                         return p;
 384                                         }
 385                                     }
 386                                 break;
 387                         }
 388                         else if (ISREAL(pt) && ISCOMPLEX(lt)) {
 389                                 p->exprblock.leftp = putx(mkconv(pt,
 390                                         (expptr)realpart(
 391                                                 putcx1(p->exprblock.leftp))));
 392                                 break;
 393                                 }
 394                         if(lt==TYCHAR && lp->tag==TEXPR &&
 395                             lp->exprblock.opcode==OPCALL)
 396                         {
 397
 398 /* May want to make a comma expression here instead.  I had one, but took
 399    it out for my convenience, not for the convenience of the end user */
 400
 401                                 putout (putcall (lp, (Addrp *) &(p ->
 402                                     exprblock.leftp)));
 403                                 return putop (p);
 404                         }
 405                         if (lt == TYCHAR) {
 406                                 p->exprblock.leftp = putx(p->exprblock.leftp);
 407                                 return p;
 408                                 }
 409                         frexpr(p->exprblock.vleng);
 410                         free( (charptr) p );
 411                         p = lp;
 412                         if (p->tag != TEXPR)
 413                                 goto retputx;
 414                         pt = lt;
 415                         lp = p->exprblock.leftp;
 416                         lt = lp->headblock.vtype;
 417                 } /* while */
 418                 if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
 419                         break;
 420  retputx:
 421                 return putx(p);
 422
 423         case OPADDR:
 424                 comma = NO;
 425                 lp = p->exprblock.leftp;
 426                 free( (charptr) p );
 427                 if(lp->tag != TADDR)
 428                 {
 429                         tp = (expptr)
 430                             mktmp(lp->headblock.vtype,lp->headblock.vleng);
 431                         p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
 432                         lp = tp;
 433                         comma = YES;
 434                 }
 435                 if(comma)
 436                         p = mkexpr(OPCOMMA, p, putaddr(lp));
 437                 else
 438                         p = (expptr)putaddr(lp);
 439                 return p;
 440
 441         case OPASSIGN:
 442         case OPASSIGNI:
 443         case OPLT:
 444         case OPLE:
 445         case OPGT:
 446         case OPGE:
 447         case OPEQ:
 448         case OPNE:
 449             ;
 450         }
 451
 452         if( ops2[p->exprblock.opcode] <= 0)
 453                 badop("putop", p->exprblock.opcode);
 454         p -> exprblock.leftp = putx (p -> exprblock.leftp);
 455         if (p -> exprblock.rightp)
 456             p -> exprblock.rightp = putx (p -> exprblock.rightp);
 457         return p;
 458 }
 459
 460 LOCAL expptr putpower(p)
 461 expptr p;
 462 {
 463         expptr base;
 464         Addrp t1, t2;
 465         ftnint k;
 466         int type;
 467         char buf[80];                   /* buffer for text of comment */
 468
 469         if(!ISICON(p->exprblock.rightp) ||
 470             (k = p->exprblock.rightp->constblock.Const.ci)<2)
 471                 Fatal("putpower: bad call");
 472         base = p->exprblock.leftp;
 473         type = base->headblock.vtype;
 474         t1 = mktmp(type, ENULL);
 475         t2 = NULL;
 476
 477         free ((charptr) p);
 478         p = putassign (cpexpr((expptr) t1), base);
 479
 480         sprintf (buf, "Computing %ld%s power", k,
 481                 k == 2 ? "nd" : k == 3 ? "rd" : "th");
 482         p1_comment (buf);
 483
 484         for( ; (k&1)==0 && k>2 ; k>>=1 )
 485         {
 486                 p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
 487         }
 488
 489         if(k == 2) {
 490
 491 /* Write the power computation out immediately */
 492                 putout (p);
 493                 p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
 494         } else {
 495                 t2 = mktmp(type, ENULL);
 496                 p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
 497                                                 cpexpr((expptr)t1)));
 498
 499                 for(k>>=1 ; k>1 ; k>>=1)
 500                 {
 501                         p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
 502                         if(k & 1)
 503                         {
 504                                 p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
 505                         }
 506                 }
 507 /* Write the power computation out immediately */
 508                 putout (p);
 509                 p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
 510                     mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
 511         }
 512         frexpr((expptr)t1);
 513         if(t2)
 514                 frexpr((expptr)t2);
 515         return p;
 516 }
 517
 518
 519
 520
 521 LOCAL Addrp intdouble(p)
 522 Addrp p;
 523 {
 524         register Addrp t;
 525
 526         t = mktmp(TYDREAL, ENULL);
 527         putout (putassign(cpexpr((expptr)t), (expptr)p));
 528         return(t);
 529 }
 530
 531
 532
 533
 534
 535 /* Complex-type variable assignment */
 536
 537 LOCAL Addrp putcxeq(p)
 538 register expptr p;
 539 {
 540         register Addrp lp, rp;
 541         expptr code;
 542
 543         if(p->tag != TEXPR)
 544                 badtag("putcxeq", p->tag);
 545
 546         lp = putcx1(p->exprblock.leftp);
 547         rp = putcx1(p->exprblock.rightp);
 548         code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
 549
 550         if( ISCOMPLEX(p->exprblock.vtype) )
 551         {
 552                 code = mkexpr (OPCOMMA, code, putassign
 553                         (imagpart(lp), imagpart(rp)));
 554         }
 555         putout (code);
 556         frexpr((expptr)rp);
 557         free ((charptr) p);
 558         return lp;
 559 }
 560
 561
 562
 563 /* putcxop -- used to write out embedded calls to complex functions, and
 564    complex arguments to procedures */
 565
 566 expptr putcxop(p)
 567 expptr p;
 568 {
 569         return (expptr)putaddr((expptr)putcx1(p));
 570 }
 571
 572 #define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
 573
 574 LOCAL Addrp putcx1(p)
 575 register expptr p;
 576 {
 577         expptr q;
 578         Addrp lp, rp;
 579         register Addrp resp;
 580         int opcode;
 581         int ltype, rtype;
 582         long ts;
 583         expptr mkrealcon();
 584
 585         if(p == NULL)
 586                 return(NULL);
 587
 588         switch(p->tag)
 589         {
 590         case TCONST:
 591                 if( ISCOMPLEX(p->constblock.vtype) )
 592                         p = (expptr) putconst((Constp)p);
 593                 return( (Addrp) p );
 594
 595         case TADDR:
 596                 resp = &p->addrblock;
 597                 if (addressable(p))
 598                         return (Addrp) p;
 599                 if ((q = resp->memoffset) && resp->isarray
 600                                           && resp->vtype != TYCHAR) {
 601                         if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
 602                                         && resp->uname_tag == UNAM_NAME)
 603                                 q = mkexpr(OPMINUS, q,
 604                                         mkintcon(resp->user.name->voffset));
 605                         ts = typesize[resp->vtype]
 606                                         * (resp->Field ? 2 : 1);
 607                         q = resp->memoffset = mkexpr(OPSLASH, q, ICON(ts));
 608                         }
 609                 else
 610                         ts = 0;
 611                 resp = mktmp(tyint, ENULL);
 612                 putout(putassign(cpexpr((expptr)resp), q));
 613                 p->addrblock.memoffset = (expptr)resp;
 614                 if (ts) {
 615                         resp = &p->addrblock;
 616                         q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
 617                         if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
 618                                 && resp->uname_tag == UNAM_NAME)
 619                                 q = mkexpr(OPPLUS, q,
 620                                     mkintcon(resp->user.name->voffset));
 621                         resp->memoffset = q;
 622                         }
 623                 return (Addrp) p;
 624
 625         case TEXPR:
 626                 if( ISCOMPLEX(p->exprblock.vtype) )
 627                         break;
 628                 resp = mktmp(TYDREAL, ENULL);
 629                 putout (putassign( cpexpr((expptr)resp), p));
 630                 return(resp);
 631
 632         default:
 633                 badtag("putcx1", p->tag);
 634         }
 635
 636         opcode = p->exprblock.opcode;
 637         if(opcode==OPCALL || opcode==OPCCALL)
 638         {
 639                 Addrp t;
 640                 p = putcall(p, &t);
 641                 putout(p);
 642                 return t;
 643         }
 644         else if(opcode == OPASSIGN)
 645         {
 646                 return putcxeq (p);
 647         }
 648
 649 /* BUG  (inefficient)  Generates too many temporary variables */
 650
 651         resp = mktmp(p->exprblock.vtype, ENULL);
 652         if(lp = putcx1(p->exprblock.leftp) )
 653                 ltype = lp->vtype;
 654         if(rp = putcx1(p->exprblock.rightp) )
 655                 rtype = rp->vtype;
 656
 657         switch(opcode)
 658         {
 659         case OPCOMMA:
 660                 frexpr((expptr)resp);
 661                 resp = rp;
 662                 rp = NULL;
 663                 break;
 664
 665         case OPNEG:
 666         case OPNEG1:
 667                 putout (PAIR (
 668                         putassign( (expptr)realpart(resp),
 669                                 mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
 670                         putassign( imagpart(resp),
 671                                 mkexpr(OPNEG, imagpart(lp), ENULL))));
 672                 break;
 673
 674         case OPPLUS:
 675         case OPMINUS: { expptr r;
 676                 r = putassign( (expptr)realpart(resp),
 677                     mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
 678                 if(rtype < TYCOMPLEX)
 679                         q = putassign( imagpart(resp), imagpart(lp) );
 680                 else if(ltype < TYCOMPLEX)
 681                 {
 682                         if(opcode == OPPLUS)
 683                                 q = putassign( imagpart(resp), imagpart(rp) );
 684                         else
 685                                 q = putassign( imagpart(resp),
 686                                     mkexpr(OPNEG, imagpart(rp), ENULL) );
 687                 }
 688                 else
 689                         q = putassign( imagpart(resp),
 690                             mkexpr(opcode, imagpart(lp), imagpart(rp) ));
 691                 r = PAIR (r, q);
 692                 putout (r);
 693                 break;
 694             } /* case OPPLUS, OPMINUS: */
 695         case OPSTAR:
 696                 if(ltype < TYCOMPLEX)
 697                 {
 698                         if( ISINT(ltype) )
 699                                 lp = intdouble(lp);
 700                         putout (PAIR (
 701                                 putassign( (expptr)realpart(resp),
 702                                     mkexpr(OPSTAR, cpexpr((expptr)lp),
 703                                         (expptr)realpart(rp))),
 704                                 putassign( imagpart(resp),
 705                                     mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
 706                 }
 707                 else if(rtype < TYCOMPLEX)
 708                 {
 709                         if( ISINT(rtype) )
 710                                 rp = intdouble(rp);
 711                         putout (PAIR (
 712                                 putassign( (expptr)realpart(resp),
 713                                     mkexpr(OPSTAR, cpexpr((expptr)rp),
 714                                         (expptr)realpart(lp))),
 715                                 putassign( imagpart(resp),
 716                                     mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
 717                 }
 718                 else    {
 719                         putout (PAIR (
 720                                 putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
 721                                     mkexpr(OPSTAR, (expptr)realpart(lp),
 722                                         (expptr)realpart(rp)),
 723                                     mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
 724                                 putassign( imagpart(resp), mkexpr(OPPLUS,
 725                                     mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
 726                                     mkexpr(OPSTAR, imagpart(lp),
 727                                         (expptr)realpart(rp))))));
 728                 }
 729                 break;
 730
 731         case OPSLASH:
 732                 /* fixexpr has already replaced all divisions
 733                  * by a complex by a function call
 734                  */
 735                 if( ISINT(rtype) )
 736                         rp = intdouble(rp);
 737                 putout (PAIR (
 738                         putassign( (expptr)realpart(resp),
 739                             mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
 740                         putassign( imagpart(resp),
 741                             mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
 742                 break;
 743
 744         case OPCONV:
 745                 if( ISCOMPLEX(lp->vtype) )
 746                         q = imagpart(lp);
 747                 else if(rp != NULL)
 748                         q = (expptr) realpart(rp);
 749                 else
 750                         q = mkrealcon(TYDREAL, "0");
 751                 putout (PAIR (
 752                         putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
 753                         putassign( imagpart(resp), q)));
 754                 break;
 755
 756         default:
 757                 badop("putcx1", opcode);
 758         }
 759
 760         frexpr((expptr)lp);
 761         frexpr((expptr)rp);
 762         free( (charptr) p );
 763         return(resp);
 764 }
 765
 766
 767
 768
 769 /* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
 770    are not defined */
 771
 772 LOCAL expptr putcxcmp(p)
 773 register expptr p;
 774 {
 775         int opcode;
 776         register Addrp lp, rp;
 777         expptr q;
 778
 779         if(p->tag != TEXPR)
 780                 badtag("putcxcmp", p->tag);
 781
 782         opcode = p->exprblock.opcode;
 783         lp = putcx1(p->exprblock.leftp);
 784         rp = putcx1(p->exprblock.rightp);
 785
 786         q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
 787             mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
 788             mkexpr(opcode, imagpart(lp), imagpart(rp)) );
 789
 790         free( (charptr) lp);
 791         free( (charptr) rp);
 792         free( (charptr) p );
 793         return  putx( fixexpr((Exprp)q) );
 794 }
 795
 796 /* putch1 -- Forces constants into the literal pool, among other things */
 797
 798 LOCAL Addrp putch1(p)
 799 register expptr p;
 800 {
 801         Addrp t;
 802         expptr e;
 803
 804         switch(p->tag)
 805         {
 806         case TCONST:
 807                 return( putconst((Constp)p) );
 808
 809         case TADDR:
 810                 return( (Addrp) p );
 811
 812         case TEXPR:
 813                 switch(p->exprblock.opcode)
 814                 {
 815                         expptr q;
 816
 817                 case OPCALL:
 818                 case OPCCALL:
 819
 820                         p = putcall(p, &t);
 821                         putout (p);
 822                         break;
 823
 824                 case OPCONCAT:
 825                         t = mktmp(TYCHAR, ICON(lencat(p)));
 826                         q = (expptr) cpexpr(p->headblock.vleng);
 827                         p = putcat( cpexpr((expptr)t), p );
 828                         /* put the correct length on the block */
 829                         frexpr(t->vleng);
 830                         t->vleng = q;
 831                         putout (p);
 832                         break;
 833
 834                 case OPCONV:
 835                         if(!ISICON(p->exprblock.vleng)
 836                             || p->exprblock.vleng->constblock.Const.ci!=1
 837                             || ! INT(p->exprblock.leftp->headblock.vtype) )
 838                                 Fatal("putch1: bad character conversion");
 839                         t = mktmp(TYCHAR, ICON(1));
 840                         e = mkexpr(OPCONV, (expptr)t, ENULL);
 841                         e->headblock.vtype = tyint;
 842                         p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
 843                         putout (p);
 844                         break;
 845                 default:
 846                         badop("putch1", p->exprblock.opcode);
 847                 }
 848                 return(t);
 849
 850         default:
 851                 badtag("putch1", p->tag);
 852         }
 853         /* NOT REACHED */ return 0;
 854 }
 855
 856
 857 /* putchop -- Write out a character actual parameter; that is, this is
 858    part of a procedure invocation */
 859
 860 Addrp putchop(p)
 861 expptr p;
 862 {
 863         p = putaddr((expptr)putch1(p));
 864         return (Addrp)p;
 865 }
 866
 867
 868
 869
 870 LOCAL expptr putcheq(p)
 871 register expptr p;
 872 {
 873         expptr lp, rp;
 874
 875         if(p->tag != TEXPR)
 876                 badtag("putcheq", p->tag);
 877
 878         lp = p->exprblock.leftp;
 879         rp = p->exprblock.rightp;
 880         frexpr(p->exprblock.vleng);
 881         free( (charptr) p );
 882
 883 /* If s = t // u, don't bother copying the result, write it directly into
 884    this buffer */
 885
 886         if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
 887                 p = putcat(lp, rp);
 888         else if( ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
 889                 lp = mkexpr(OPCONV, lp, ENULL);
 890                 rp = mkexpr(OPCONV, rp, ENULL);
 891                 lp->headblock.vtype = rp->headblock.vtype = tyint;
 892                 p = putop(mkexpr(OPASSIGN, lp, rp));
 893                 }
 894         else
 895                 p = putx( call2(TYSUBR, "s_copy", lp, rp) );
 896         return p;
 897 }
 898
 899
 900
 901
 902 LOCAL expptr putchcmp(p)
 903 register expptr p;
 904 {
 905         expptr lp, rp;
 906
 907         if(p->tag != TEXPR)
 908                 badtag("putchcmp", p->tag);
 909
 910         lp = p->exprblock.leftp;
 911         rp = p->exprblock.rightp;
 912
 913         if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
 914                 lp = mkexpr(OPCONV, lp, ENULL);
 915                 rp = mkexpr(OPCONV, rp, ENULL);
 916                 lp->headblock.vtype = rp->headblock.vtype = tyint;
 917                 }
 918         else {
 919                 lp = call2(TYINT,"s_cmp", lp, rp);
 920                 rp = ICON(0);
 921                 }
 922         p->exprblock.leftp = lp;
 923         p->exprblock.rightp = rp;
 924         p = putop(p);
 925         return p;
 926 }
 927
 928
 929
 930
 931
 932 /* putcat -- Writes out a concatenation operation.  Two temporary arrays
 933    are allocated,   putct1()   is called to initialize them, and then a
 934    call to runtime library routine   s_cat()   is inserted.
 935
 936         This routine generates code which will perform an  (nconc lhs rhs)
 937    at runtime.  The runtime funciton does not return a value, the routine
 938    that calls this   putcat   must remember the name of   lhs.
 939 */
 940
 941
 942 LOCAL expptr putcat(lhs0, rhs)
 943  expptr lhs0;
 944  register expptr rhs;
 945 {
 946         register Addrp lhs = (Addrp)lhs0;
 947         int n, tyi;
 948         Addrp length_var, string_var;
 949         expptr p;
 950         static char Writing_concatenation[] = "Writing concatenation";
 951
 952 /* Create the temporary arrays */
 953
 954         n = ncat(rhs);
 955         length_var = mktmpn(n, tyioint, ENULL);
 956         string_var = mktmpn(n, TYADDR, ENULL);
 957         frtemp((Addrp)cpexpr((expptr)length_var));
 958         frtemp((Addrp)cpexpr((expptr)string_var));
 959
 960 /* Initialize the arrays */
 961
 962         n = 0;
 963         /* p1_comment scribbles on its argument, so we
 964          * cannot safely pass a string literal here. */
 965         p1_comment(Writing_concatenation);
 966         putct1(rhs, length_var, string_var, &n);
 967
 968 /* Create the invocation */
 969
 970         tyi = tyint;
 971         tyint = tyioint;        /* for -I2 */
 972         p = putx (call4 (TYSUBR, "s_cat",
 973                                 (expptr)lhs,
 974                                 (expptr)string_var,
 975                                 (expptr)length_var,
 976                                 (expptr)putconst((Constp)ICON(n))));
 977         tyint = tyi;
 978
 979         return p;
 980 }
 981
 982
 983
 984
 985
 986 LOCAL putct1(q, length_var, string_var, ip)
 987 register expptr q;
 988 register Addrp length_var, string_var;
 989 int *ip;
 990 {
 991         int i;
 992         Addrp length_copy, string_copy;
 993         expptr e;
 994         extern int szleng;
 995
 996         if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
 997         {
 998                 putct1(q->exprblock.leftp, length_var, string_var,
 999                     ip);
1000                 putct1(q->exprblock.rightp, length_var, string_var,
1001                     ip);
1002                 frexpr (q -> exprblock.vleng);
1003                 free ((charptr) q);
1004         }
1005         else
1006         {
1007                 i = (*ip)++;
1008                 length_copy = (Addrp) cpexpr((expptr)length_var);
1009                 length_copy->memoffset =
1010                     mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
1011                 string_copy = (Addrp) cpexpr((expptr)string_var);
1012                 string_copy->memoffset =
1013                     mkexpr(OPPLUS, string_copy->memoffset,
1014                         ICON(i*typesize[TYLONG]));
1015                 e = cpexpr(q->headblock.vleng);
1016                 putout (PAIR (putassign((expptr)length_copy, e),
1017                         putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
1018         }
1019 }
1020
1021 /* putaddr -- seems to write out function invocation actual parameters */
1022
1023 LOCAL expptr putaddr(p0)
1024  expptr p0;
1025 {
1026         register Addrp p;
1027
1028         if (!(p = (Addrp)p0))
1029                 return ENULL;
1030
1031         if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
1032         {
1033                 frexpr((expptr)p);
1034                 return ENULL;
1035         }
1036         if (p->isarray && p->memoffset)
1037                 p->memoffset = putx(p->memoffset);
1038         return (expptr) p;
1039 }
1040
1041  LOCAL expptr
1042 addrfix(e)              /* fudge character string length if it's a TADDR */
1043  expptr e;
1044 {
1045         return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
1046         }
1047
1048  LOCAL int
1049 typekludge(ccall, q, at, j)
1050  int ccall;
1051  register expptr q;
1052  Atype *at;
1053  int j; /* alternate type */
1054 {
1055         register int i, k;
1056         extern int iocalladdr;
1057         register Namep np;
1058
1059         /* Return value classes:
1060          *      < 100 ==> Fortran arg (pointer to type)
1061          *      < 200 ==> C arg
1062          *      < 300 ==> procedure arg
1063          *      < 400 ==> external, no explicit type
1064          *      < 500 ==> arg that may turn out to be
1065          *                either a variable or a procedure
1066          */
1067
1068         k = q->headblock.vtype;
1069         if (ccall) {
1070                 if (k == TYREAL)
1071                         k = TYDREAL;    /* force double for library routines */
1072                 return k + 100;
1073                 }
1074         if (k == TYADDR)
1075                 return iocalladdr;
1076         i = q->tag;
1077         if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
1078         ||  (i == TADDR && q->addrblock.charleng)
1079         ||   i == TCONST)
1080                 k = TYFTNLEN + 100;
1081         else if (i == TADDR)
1082             switch(q->addrblock.vclass) {
1083                 case CLPROC:
1084                         if (q->addrblock.uname_tag != UNAM_NAME)
1085                                 k += 200;
1086                         else if ((np = q->addrblock.user.name)->vprocclass
1087                                         != PTHISPROC) {
1088                                 if (k && !np->vimpltype)
1089                                         k += 200;
1090                                 else {
1091                                         if (j > 200 && infertypes && j < 300) {
1092                                                 k = j;
1093                                                 inferdcl(np, j-200);
1094                                                 }
1095                                         else k = (np->vstg == STGEXT
1096                                                 ? extsymtab[np->vardesc.varno].extype
1097                                                 : 0) + 200;
1098                                         at->cp = mkchain((char *)np, at->cp);
1099                                         }
1100                                 }
1101                         else if (k == TYSUBR)
1102                                 k += 200;
1103                         break;
1104
1105                 case CLUNKNOWN:
1106                         if (q->addrblock.vstg == STGARG
1107                          && q->addrblock.uname_tag == UNAM_NAME) {
1108                                 k += 400;
1109                                 at->cp = mkchain((char *)q->addrblock.user.name,
1110                                                 at->cp);
1111                                 }
1112                 }
1113         else if (i == TNAME && q->nameblock.vstg == STGARG) {
1114                 np = &q->nameblock;
1115                 switch(np->vclass) {
1116                     case CLPROC:
1117                         if (!np->vimpltype)
1118                                 k += 200;
1119                         else if (j <= 200 || !infertypes || j >= 300)
1120                                 k += 300;
1121                         else {
1122                                 k = j;
1123                                 inferdcl(np, j-200);
1124                                 }
1125                         goto add2chain;
1126
1127                     case CLUNKNOWN:
1128                         /* argument may be a scalar variable or a function */
1129                         if (np->vimpltype && j && infertypes
1130                         && j < 300) {
1131                                 inferdcl(np, j % 100);
1132                                 k = j;
1133                                 }
1134                         else
1135                                 k += 400;
1136
1137                         /* to handle procedure args only so far known to be
1138                          * external, save a pointer to the symbol table entry...
1139                          */
1140  add2chain:
1141                         at->cp = mkchain((char *)np, at->cp);
1142                     }
1143                 }
1144         return k;
1145         }
1146
1147  char *
1148 Argtype(k, buf)
1149  int k;
1150  char *buf;
1151 {
1152         if (k < 100) {
1153                 sprintf(buf, "%s variable", ftn_types[k]);
1154                 return buf;
1155                 }
1156         if (k < 200) {
1157                 k -= 100;
1158                 return ftn_types[k];
1159                 }
1160         if (k < 300) {
1161                 k -= 200;
1162                 if (k == TYSUBR)
1163                         return ftn_types[TYSUBR];
1164                 sprintf(buf, "%s function", ftn_types[k]);
1165                 return buf;
1166                 }
1167         if (k < 400)
1168                 return "external argument";
1169         k -= 400;
1170         sprintf(buf, "%s argument", ftn_types[k]);
1171         return buf;
1172         }
1173
1174  static void
1175 atype_squawk(at, msg)
1176  Argtypes *at;
1177  char *msg;
1178 {
1179         register Atype *a, *ae;
1180         warn(msg);
1181         for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
1182                 frchain(&a->cp);
1183         at->nargs = -1;
1184         if (at->changes & 2)
1185                 proc_protochanges++;
1186         }
1187
1188  static char inconsist[] = "inconsistent calling sequences for ";
1189
1190  void
1191 bad_atypes(at, fname, i, j, k, here, prev)
1192  Argtypes *at;
1193  char *fname, *here, *prev;
1194  int i, j, k;
1195 {
1196         char buf[208], buf1[32], buf2[32];
1197
1198         sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
1199                 inconsist, fname, i, here, Argtype(k, buf1),
1200                 prev, Argtype(j, buf2));
1201         atype_squawk(at, buf);
1202         }
1203
1204  int
1205 type_fixup(at,a,k)
1206  Argtypes *at;
1207  Atype *a;
1208  int k;
1209 {
1210         register struct Entrypoint *ep;
1211         if (!infertypes)
1212                 return 0;
1213         for(ep = entries; ep; ep = ep->entnextp)
1214                 if (at == ep->entryname->arginfo) {
1215                         a->type = k % 100;
1216                         return proc_argchanges = 1;
1217                         }
1218         return 0;
1219         }
1220
1221
1222  void
1223 save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
1224  chainp arglist;
1225  Argtypes **at0, **at1;
1226  int ccall, stg, nchargs, type, zap;
1227  char *fname;
1228 {
1229         Argtypes *at;
1230         chainp cp;
1231         int i, i0, j, k, nargs, *t, *te;
1232         Atype *atypes;
1233         expptr q;
1234         char buf[208];
1235         static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
1236         static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,
1237                                 initargs, initargs+1,0,initargs+2};
1238         extern int init_ac[TYSUBR+1];
1239
1240         i0 = init_ac[type];
1241         t = init_ap[type];
1242         te = t + i0;
1243         if (at = *at0) {
1244                 *at1 = at;
1245                 nargs = at->nargs;
1246                 if (nargs < 0) { /* inconsistent usage seen */
1247                         if (type) {
1248                                 if (at->changes & 2)
1249                                         --proc_protochanges;
1250                                 goto newlist;
1251                                 }
1252                         return;
1253                         }
1254                 atypes = at->atypes;
1255                 i = nchargs;
1256                 for(; t < te; atypes++) {
1257                         if (++i > nargs) {
1258  toomany:
1259                                 i = nchargs + i0;
1260                                 for(cp = arglist; cp; cp = cp->nextp)
1261                                         i++;
1262  toofew:
1263                                 sprintf(buf,
1264                 "%s%.90s:\n\there %d, previously %d args and string lengths.",
1265                                         inconsist, fname, i, nargs);
1266                                 atype_squawk(at, buf);
1267  retn:
1268                                 if (type)
1269                                         goto newlist;
1270                                 return;
1271                                 }
1272                         j = atypes->type;
1273                         k = *t++;
1274                         if (j != k)
1275                                 goto badtypes;
1276                         }
1277                 for(cp = arglist; cp; atypes++, cp = cp->nextp) {
1278                         if (++i > nargs)
1279                                 goto toomany;
1280                         j = atypes->type;
1281                         if (!(q = (expptr)cp->datap))
1282                                 continue;
1283                         k = typekludge(ccall, q, atypes, j);
1284                         if (k >= 300 || k == j)
1285                                 continue;
1286                         if (j >= 300) {
1287                                 if (k >= 200) {
1288                                         if (k == TYUNKNOWN + 200)
1289                                                 continue;
1290                                         if (j % 100 != k - 200
1291                                          && k != TYSUBR + 200
1292                                          && j != TYUNKNOWN + 300
1293                                          && !type_fixup(at,atypes,k))
1294                                                 goto badtypes;
1295                                         }
1296                                 else if (j % 100 % TYSUBR != k % TYSUBR
1297                                                 && !type_fixup(at,atypes,k))
1298                                         goto badtypes;
1299                                 }
1300                         else if (k < 200 || j < 200)
1301                                 if (j)
1302                                         goto badtypes;
1303                                 else ; /* fall through to update */
1304                         else if (k == TYUNKNOWN+200)
1305                                 continue;
1306                         else if (j != TYUNKNOWN+200)
1307                                 {
1308  badtypes:
1309                                 bad_atypes(at, fname, i, j, k, "here ",
1310                                                 ", previously");
1311                                 if (type) {
1312                                         /* we're defining the procedure */
1313                                         t = init_ap[type];
1314                                         te = t + i0;
1315                                         proc_argchanges = 1;
1316                                         goto newlist;
1317                                         }
1318                                 goto retn;
1319                                 }
1320                         /* We've subsequently learned the right type,
1321                            as in the call on zoo below...
1322
1323                                 subroutine foo(x, zap)
1324                                 external zap
1325                                 call goo(zap)
1326                                 x = zap(3)
1327                                 call zoo(zap)
1328                                 end
1329                          */
1330                         atypes->type = k;
1331                         at->changes |= 1;
1332                         }
1333                 if (i < nargs)
1334                         goto toofew;
1335                 if (zap && (at->changes & 5) != 5)
1336                         at->changes = 0;
1337                 return;
1338                 }
1339  newlist:
1340         i = i0 + nchargs;
1341         for(cp = arglist; cp; cp = cp->nextp)
1342                 i++;
1343         k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
1344         *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
1345                                          : (Argtypes *) mem(k,1);
1346         at->nargs = i;
1347         at->changes = type ? 0 : 4;
1348         atypes = at->atypes;
1349         for(; t < te; atypes++) {
1350                 atypes->type = *t++;
1351                 atypes->cp = 0;
1352                 }
1353         for(cp = arglist; cp; atypes++, cp = cp->nextp) {
1354                 atypes->cp = 0;
1355                 atypes->type = (q = (expptr)cp->datap)
1356                         ? typekludge(ccall, q, atypes, 0)
1357                         : 0;
1358                 }
1359         for(; --nchargs >= 0; atypes++) {
1360                 atypes->type = TYFTNLEN + 100;
1361                 atypes->cp = 0;
1362                 }
1363         }
1364
1365  void
1366 saveargtypes(p)         /* for writing prototypes */
1367  register Exprp p;
1368 {
1369         Addrp a;
1370         Argtypes **at0, **at1;
1371         Namep np;
1372         chainp arglist;
1373         expptr rp;
1374         Extsym *e;
1375         char *fname;
1376
1377         a = (Addrp)p->leftp;
1378         switch(a->vstg) {
1379                 case STGEXT:
1380                         switch(a->uname_tag) {
1381                                 case UNAM_EXTERN:       /* e.g., sqrt() */
1382                                         e = extsymtab + a->memno;
1383                                         at0 = at1 = &e->arginfo;
1384                                         fname = e->fextname;
1385                                         break;
1386                                 case UNAM_NAME:
1387                                         np = a->user.name;
1388                                         at0 = &extsymtab[np->vardesc.varno].arginfo;
1389                                         at1 = &np->arginfo;
1390                                         fname = np->fvarname;
1391                                         break;
1392                                 default:
1393                                         goto bug;
1394                                 }
1395                         break;
1396                 case STGARG:
1397                         if (a->uname_tag != UNAM_NAME)
1398                                 goto bug;
1399                         np = a->user.name;
1400                         at0 = at1 = &np->arginfo;
1401                         fname = np->fvarname;
1402                         break;
1403                 default:
1404          bug:
1405                         Fatal("Confusion in saveargtypes");
1406                 }
1407         rp = p->rightp;
1408         arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
1409         save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
1410                 fname, a->vstg, 0, 0, 0);
1411         }
1412
1413 /* putcall - fix up the argument list, and write out the invocation.   p
1414    is expected to be initialized and point to an OPCALL or OPCCALL
1415    expression.  The return value is a pointer to a temporary holding the
1416    result of a COMPLEX or CHARACTER operation, or NULL. */
1417
1418 LOCAL expptr putcall(p0, temp)
1419  expptr p0;
1420  Addrp *temp;
1421 {
1422     register Exprp p = (Exprp)p0;
1423     chainp arglist;             /* Pointer to actual arguments, if any */
1424     chainp charsp;              /* List of copies of the variables which
1425                                    hold the lengths of character
1426                                    parameters (other than procedure
1427                                    parameters) */
1428     chainp cp;                  /* Iterator over argument lists */
1429     register expptr q;          /* Pointer to the current argument */
1430     Addrp fval;                 /* Function return value */
1431     int type;                   /* type of the call - presumably this was
1432                                    set elsewhere */
1433     int byvalue;                /* True iff we don't want to massage the
1434                                    parameter list, since we're calling a C
1435                                    library routine */
1436     extern int Castargs;
1437     char *s;
1438     extern struct Listblock *mklist();
1439
1440     type = p -> vtype;
1441     charsp = NULL;
1442     byvalue =  (p->opcode == OPCCALL);
1443
1444 /* Verify the actual parameters */
1445
1446     if (p == (Exprp) NULL)
1447         err ("putcall:  NULL call expression");
1448     else if (p -> tag != TEXPR)
1449         erri ("putcall:  expected TEXPR, got '%d'", p -> tag);
1450
1451 /* Find the argument list */
1452
1453     if(p->rightp && p -> rightp -> tag == TLIST)
1454         arglist = p->rightp->listblock.listp;
1455     else
1456         arglist = NULL;
1457
1458 /* Count the number of explicit arguments, including lengths of character
1459    variables */
1460
1461     for(cp = arglist ; cp ; cp = cp->nextp)
1462         if(!byvalue) {
1463             q = (expptr) cp->datap;
1464             if( ISCONST(q) )
1465             {
1466
1467 /* Even constants are passed by reference, so we need to put them in the
1468    literal table */
1469
1470                 q = (expptr) putconst((Constp)q);
1471                 cp->datap = (char *) q;
1472             }
1473
1474 /* Save the length expression of character variables (NOT character
1475    procedures) for the end of the argument list */
1476
1477             if( ISCHAR(q) &&
1478                 (q->headblock.vclass != CLPROC
1479                 || q->headblock.vstg == STGARG
1480                         && q->tag == TADDR
1481                         && q->addrblock.uname_tag == UNAM_NAME
1482                         && q->addrblock.user.name->vprocclass == PTHISPROC))
1483             {
1484                 p0 = cpexpr(q->headblock.vleng);
1485                 charsp = mkchain((char *)p0, charsp);
1486                 if (q->headblock.vclass == CLUNKNOWN
1487                  && q->headblock.vstg == STGARG)
1488                         q->addrblock.user.name->vpassed = 1;
1489                 else if (q->tag == TADDR
1490                                 && q->addrblock.uname_tag == UNAM_CONST)
1491                         p0->constblock.Const.ci
1492                                 += q->addrblock.user.Const.ccp1.blanks;
1493             }
1494         }
1495     charsp = revchain(charsp);
1496
1497 /* If the routine is a CHARACTER function ... */
1498
1499     if(type == TYCHAR)
1500     {
1501         if( ISICON(p->vleng) )
1502         {
1503
1504 /* Allocate a temporary to hold the return value of the function */
1505
1506             fval = mktmp(TYCHAR, p->vleng);
1507         }
1508         else    {
1509                 err("adjustable character function");
1510                 if (temp)
1511                         *temp = 0;
1512                 return 0;
1513                 }
1514     }
1515
1516 /* If the routine is a COMPLEX function ... */
1517
1518     else if( ISCOMPLEX(type) )
1519         fval = mktmp(type, ENULL);
1520     else
1521         fval = NULL;
1522
1523 /* Write the function name, without taking its address */
1524
1525     p -> leftp = putx(fixtype(putaddr(p->leftp)));
1526
1527     if(fval)
1528     {
1529         chainp prepend;
1530
1531 /* Prepend a copy of the function return value buffer out as the first
1532    argument. */
1533
1534         prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
1535
1536 /* If it's a character function, also prepend the length of the result */
1537
1538         if(type==TYCHAR)
1539         {
1540
1541             prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
1542                                         p->vleng)), arglist);
1543         }
1544         if (!(q = p->rightp))
1545                 p->rightp = q = (expptr)mklist(CHNULL);
1546         q->listblock.listp = prepend;
1547     }
1548
1549 /* Scan through the fortran argument list */
1550
1551     for(cp = arglist ; cp ; cp = cp->nextp)
1552     {
1553         q = (expptr) (cp->datap);
1554         if (q == ENULL)
1555             err ("putcall:  NULL argument");
1556
1557 /* call putaddr only when we've got a parameter for a C routine or a
1558    memory resident parameter */
1559
1560         if (q -> tag == TCONST && !byvalue)
1561             q = (expptr) putconst ((Constp)q);
1562
1563         if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) )
1564                 cp->datap = (char *)putaddr(q);
1565         else if( ISCOMPLEX(q->headblock.vtype) )
1566             cp -> datap = (char *) putx (fixtype(putcxop(q)));
1567         else if (ISCHAR(q) )
1568             cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
1569         else if( ! ISERROR(q) )
1570         {
1571             if(byvalue
1572             || q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
1573                 cp -> datap = (char *) putx(q);
1574             else {
1575                 expptr t, t1;
1576
1577 /* If we've got a register parameter, or (maybe?) a constant, save it in a
1578    temporary first */
1579
1580                 t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);
1581
1582 /* Assign to temporary variables before invoking the subroutine or
1583    function */
1584
1585                 t1 = putassign( cpexpr(t), q );
1586                 if (doin_setbound)
1587                         t = mkexpr(OPCOMMA_ARG, t1, t);
1588                 else
1589                         putout(t1);
1590                 cp -> datap = (char *) t;
1591             } /* else */
1592         } /* if !ISERROR(q) */
1593     }
1594
1595 /* Now adjust the lengths of the CHARACTER parameters */
1596
1597     for(cp = charsp ; cp ; cp = cp->nextp)
1598         cp->datap = (char *)addrfix(putx(
1599                         /* in case MAIN has a character*(*)... */
1600                         (s = cp->datap) ? mkconv(TYLENG,(expptr)s)
1601                                          : ICON(0)));
1602
1603 /* ... and add them to the end of the argument list */
1604
1605     hookup (arglist, charsp);
1606
1607 /* Return the name of the temporary used to hold the results, if any was
1608    necessary. */
1609
1610     if (temp) *temp = fval;
1611     else frexpr ((expptr)fval);
1612
1613     saveargtypes(p);
1614
1615     return (expptr) p;
1616 }
1617
1618
1619
1620 /* putmnmx -- Put min or max.   p   must point to an EXPR, not just a
1621    CONST */
1622
1623 LOCAL expptr putmnmx(p)
1624 register expptr p;
1625 {
1626         int op, op2, type;
1627         expptr arg, qp, temp;
1628         chainp p0, p1;
1629         Addrp sp, tp;
1630         char comment_buf[80];
1631         char *what;
1632
1633         if(p->tag != TEXPR)
1634                 badtag("putmnmx", p->tag);
1635
1636         type = p->exprblock.vtype;
1637         op = p->exprblock.opcode;
1638         op2 = op == OPMIN ? OPMIN2 : OPMAX2;
1639         p0 = p->exprblock.leftp->listblock.listp;
1640         free( (charptr) (p->exprblock.leftp) );
1641         free( (charptr) p );
1642
1643         /* special case for two addressable operands */
1644
1645         if (addressable((expptr)p0->datap)
1646          && (p1 = p0->nextp)
1647          && addressable((expptr)p1->datap)
1648          && !p1->nextp) {
1649                 if (type == TYREAL && forcedouble)
1650                         op2 = op == OPMIN ? OPDMIN : OPDMAX;
1651                 p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
1652                                 mkconv(type, cpexpr((expptr)p1->datap)));
1653                 frchain(&p0);
1654                 return p;
1655                 }
1656
1657         /* general case */
1658
1659         sp = mktmp(type, ENULL);
1660
1661 /* We only need a second temporary if the arg list has an unaddressable
1662    value */
1663
1664         tp = (Addrp) NULL;
1665         qp = ENULL;
1666         for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
1667                 if (!addressable ((expptr) p1 -> datap)) {
1668                         tp = mktmp(type, ENULL);
1669                         qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
1670                         qp = fixexpr((Exprp)qp);
1671                         break;
1672                 } /* if */
1673
1674 /* Now output the appropriate number of assignments and comparisons.  Min
1675    and max are implemented by the simple O(n) algorithm:
1676
1677         min (a, b, c, d) ==>
1678         { <type> t1, t2;
1679
1680             t1 = a;
1681             t2 = b; t1 = (t1 < t2) ? t1 : t2;
1682             t2 = c; t1 = (t1 < t2) ? t1 : t2;
1683             t2 = d; t1 = (t1 < t2) ? t1 : t2;
1684         }
1685 */
1686
1687         if (!doin_setbound) {
1688                 switch(op) {
1689                         case OPLT:
1690                         case OPMIN:
1691                         case OPDMIN:
1692                         case OPMIN2:
1693                                 what = "IN";
1694                                 break;
1695                         default:
1696                                 what = "AX";
1697                         }
1698                 sprintf (comment_buf, "Computing M%s", what);
1699                 p1_comment (comment_buf);
1700                 }
1701
1702         p1 = p0->nextp;
1703         temp = (expptr)p0->datap;
1704         if (addressable(temp) && addressable((expptr)p1->datap)) {
1705                 p = mkconv(type, cpexpr(temp));
1706                 arg = mkconv(type, cpexpr((expptr)p1->datap));
1707                 temp = mkexpr(op2, p, arg);
1708                 if (!ISCONST(temp))
1709                         temp = fixexpr((Exprp)temp);
1710                 p1 = p1->nextp;
1711                 }
1712         p = putassign (cpexpr((expptr)sp), temp);
1713
1714         for(; p1 ; p1 = p1->nextp)
1715         {
1716                 if (addressable ((expptr) p1 -> datap)) {
1717                         arg = mkconv(type, cpexpr((expptr)p1->datap));
1718                         temp = mkexpr(op2, cpexpr((expptr)sp), arg);
1719                         temp = fixexpr((Exprp)temp);
1720                 } else {
1721                         temp = (expptr) cpexpr (qp);
1722                         p = mkexpr(OPCOMMA, p,
1723                                 putassign(cpexpr((expptr)tp), (expptr)p1->datap));
1724                 } /* else */
1725
1726                 if(p1->nextp)
1727                         p = mkexpr(OPCOMMA, p,
1728                                 putassign(cpexpr((expptr)sp), temp));
1729                 else {
1730                         if (type == TYREAL && forcedouble)
1731                                 temp->exprblock.opcode =
1732                                         op == OPMIN ? OPDMIN : OPDMAX;
1733                         if (doin_setbound)
1734                                 p = mkexpr(OPCOMMA, p, temp);
1735                         else {
1736                                 putout (p);
1737                                 p = putx(temp);
1738                                 }
1739                         if (qp)
1740                                 frexpr (qp);
1741                 } /* else */
1742         } /* for */
1743
1744         frchain( &p0 );
1745         return p;
1746 }
1747
1748
1749  void
1750 putwhile(p)
1751  expptr p;
1752 {
1753         long where;
1754         int k, n;
1755
1756         if (wh_next >= wh_last)
1757                 {
1758                 k = wh_last - wh_first;
1759                 n = k + 100;
1760                 wh_next = mem(n,0);
1761                 wh_last = wh_first + n;
1762                 if (k)
1763                         memcpy(wh_next, wh_first, k);
1764                 wh_first =  wh_next;
1765                 wh_next += k;
1766                 wh_last = wh_first + n;
1767                 }
1768         if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
1769                 {
1770                 if(k != TYERROR)
1771                         err("non-logical expression in DO WHILE statement");
1772                 }
1773         else    {
1774                 p1put(P1_WHILE1START);
1775                 where = ftell(pass1_file);
1776                 p = putx(p);
1777                 *wh_next++ = ftell(pass1_file) > where;
1778                 p1put(P1_WHILE2START);
1779                 p1_expr(p);
1780                 }
1781         }