sources/f2c/putpcc.c

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