sources/f2c/p1output.c

   1 /****************************************************************
   2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
   3
   4 Permission to use, copy, modify, and distribute this software
   5 and its documentation for any purpose and without fee is hereby
   6 granted, provided that the above copyright notice appear in all
   7 copies and that both that the copyright notice and this
   8 permission notice and warranty disclaimer appear in supporting
   9 documentation, and that the names of AT&T Bell Laboratories or
  10 Bellcore or any of their entities not be used in advertising or
  11 publicity pertaining to distribution of the software without
  12 specific, written prior permission.
  13
  14 AT&T and Bellcore disclaim all warranties with regard to this
  15 software, including all implied warranties of merchantability
  16 and fitness.  In no event shall AT&T or Bellcore be liable for
  17 any special, indirect or consequential damages or any damages
  18 whatsoever resulting from loss of use, data or profits, whether
  19 in an action of contract, negligence or other tortious action,
  20 arising out of or in connection with the use or performance of
  21 this software.
  22 ****************************************************************/
  23
  24 #include "defs.h"
  25 #include "p1defs.h"
  26 #include "output.h"
  27 #include "names.h"
  28
  29
  30 static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
  31         p1_literal(), p1_name(), p1_unary(), p1putn();
  32 static void p1putd (/* int, int */);
  33 static void p1putds (/* int, int, char * */);
  34 static void p1putdds (/* int, int, int, char * */);
  35 static void p1putdd (/* int, int, int */);
  36 static void p1putddd (/* int, int, int, int */);
  37
  38
  39 /* p1_comment -- save the text of a Fortran comment in the intermediate
  40    file.  Make sure that there are no spurious "/ *" or "* /" characters by
  41    mapping them onto "/+" and "+/".   str   is assumed to hold no newlines and be
  42    null terminated; it may be modified by this function. */
  43
  44 void p1_comment (str)
  45 char *str;
  46 {
  47     register unsigned char *pointer, *ustr;
  48
  49     if (!str)
  50         return;
  51
  52 /* Get rid of any open or close comment combinations that may be in the
  53    Fortran input */
  54
  55         ustr = (unsigned char *)str;
  56         for(pointer = ustr; *pointer; pointer++)
  57                 if (*pointer == '*' && pointer[1] == '/')
  58                         *pointer = '+';
  59         /* trim trailing white space */
  60 #ifdef isascii
  61         while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
  62 #else
  63         while(--pointer >= ustr && isspace(*pointer));
  64 #endif
  65         pointer[1] = 0;
  66         p1puts (P1_COMMENT, str);
  67 } /* p1_comment */
  68
  69 void p1_line_number (line_number)
  70 long line_number;
  71 {
  72
  73     p1putd (P1_SET_LINE, line_number);
  74 } /* p1_line_number */
  75
  76 /* p1_name -- Writes the address of a hash table entry into the
  77    intermediate file */
  78
  79 static void p1_name (namep)
  80 Namep namep;
  81 {
  82         p1putd (P1_NAME_POINTER, (long) namep);
  83         namep->visused = 1;
  84 } /* p1_name */
  85
  86
  87
  88 void p1_expr (expr)
  89 expptr expr;
  90 {
  91 /* An opcode of 0 means a null entry */
  92
  93     if (expr == ENULL) {
  94         p1putdd (P1_EXPR, 0, TYUNKNOWN);        /* Should this be TYERROR? */
  95         return;
  96     } /* if (expr == ENULL) */
  97
  98     switch (expr -> tag) {
  99         case TNAME:
 100             p1_name ((Namep) expr);
 101             return;
 102         case TCONST:
 103             p1_const(&expr->constblock);
 104             return;
 105         case TEXPR:
 106             /* Fall through the switch */
 107             break;
 108         case TADDR:
 109             p1_addr (&(expr -> addrblock));
 110             return;
 111         case TPRIM:
 112             warn ("p1_expr:  got TPRIM");
 113             return;
 114         case TLIST:
 115             p1_list (&(expr -> listblock));
 116             return;
 117         case TERROR:
 118                 return;
 119         default:
 120             erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
 121             return;
 122     } /* switch */
 123
 124 /* Now we know that the tag is TEXPR */
 125
 126     if (is_unary_op (expr -> exprblock.opcode))
 127         p1_unary (&(expr -> exprblock));
 128     else if (is_binary_op (expr -> exprblock.opcode))
 129         p1_binary (&(expr -> exprblock));
 130     else
 131         erri ("p1_expr:  bad opcode '%d'", (int) expr -> exprblock.opcode);
 132
 133 } /* p1_expr */
 134
 135
 136
 137 static void p1_const(cp)
 138  register Constp cp;
 139 {
 140         int type = cp->vtype;
 141         expptr vleng = cp->vleng;
 142         union Constant *c = &cp->Const;
 143         char cdsbuf0[64], cdsbuf1[64];
 144         char *cds0, *cds1;
 145
 146     switch (type) {
 147         case TYSHORT:
 148         case TYLONG:
 149         case TYLOGICAL:
 150             p1putdd (P1_CONST, type, (int)c -> ci);
 151             break;
 152         case TYREAL:
 153         case TYDREAL:
 154                 fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
 155                         cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
 156             break;
 157         case TYCOMPLEX:
 158         case TYDCOMPLEX:
 159                 if (cp->vstg) {
 160                         cds0 = c->cds[0];
 161                         cds1 = c->cds[1];
 162                         }
 163                 else {
 164                         cds0 = cds(dtos(c->cd[0]), cdsbuf0);
 165                         cds1 = cds(dtos(c->cd[1]), cdsbuf1);
 166                         }
 167                 fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
 168                         cds0, cds1);
 169             break;
 170         case TYCHAR:
 171             if (vleng && !ISICON (vleng))
 172                 erri("p1_const:  bad vleng '%d'\n", (int) vleng);
 173             else
 174                 fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
 175                         cpexpr((expptr)cp));
 176             break;
 177         default:
 178             erri ("p1_const:  bad constant type '%d'", type);
 179             break;
 180     } /* switch */
 181 } /* p1_const */
 182
 183
 184 void p1_asgoto (addrp)
 185 Addrp addrp;
 186 {
 187     p1put (P1_ASGOTO);
 188     p1_addr (addrp);
 189 } /* p1_asgoto */
 190
 191
 192 void p1_goto (stateno)
 193 ftnint stateno;
 194 {
 195     p1putd (P1_GOTO, stateno);
 196 } /* p1_goto */
 197
 198
 199 static void p1_addr (addrp)
 200  register struct Addrblock *addrp;
 201 {
 202     int stg;
 203
 204     if (addrp == (struct Addrblock *) NULL)
 205         return;
 206
 207     stg = addrp -> vstg;
 208
 209     if (ONEOF(stg, M(STGINIT)|M(STGREG))
 210         || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
 211                 (!ISICON(addrp->memoffset)
 212                 || (addrp->uname_tag == UNAM_NAME
 213                         ? addrp->memoffset->constblock.Const.ci
 214                                 != addrp->user.name->voffset
 215                         : addrp->memoffset->constblock.Const.ci))
 216         || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
 217                 (!ISICON(addrp->memoffset)
 218                         || addrp->memoffset->constblock.Const.ci)
 219         || addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
 220         {
 221                 p1_big_addr (addrp);
 222                 return;
 223         }
 224
 225 /* Write out a level of indirection for non-array arguments, which have
 226    addrp -> memoffset   set and are handled by   p1_big_addr().
 227    Lengths are passed by value, so don't check STGLENG
 228    28-Jun-89 (dmg)  Added the check for != TYCHAR
 229  */
 230
 231     if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
 232             stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
 233         p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
 234         p1_expr (ENULL);        /* Put dummy   vleng   */
 235     } /* if stg == STGARG */
 236
 237     switch (addrp -> uname_tag) {
 238         case UNAM_NAME:
 239             p1_name (addrp -> user.name);
 240             break;
 241         case UNAM_IDENT:
 242             p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
 243                                 addrp->user.ident);
 244             break;
 245         case UNAM_CHARP:
 246                 p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
 247                                 addrp->user.Charp);
 248                 break;
 249         case UNAM_EXTERN:
 250             p1putd (P1_EXTERN, (long) addrp -> memno);
 251             if (addrp->vclass == CLPROC)
 252                 extsymtab[addrp->memno].extype = addrp->vtype;
 253             break;
 254         case UNAM_CONST:
 255             if (addrp -> memno != BAD_MEMNO)
 256                 p1_literal (addrp -> memno);
 257             else
 258                 p1_const((struct Constblock *)addrp);
 259             break;
 260         case UNAM_UNKNOWN:
 261         default:
 262             erri ("p1_addr:  unknown uname_tag '%d'", addrp -> uname_tag);
 263             break;
 264     } /* switch */
 265 } /* p1_addr */
 266
 267
 268 static void p1_list (listp)
 269 struct Listblock *listp;
 270 {
 271     chainp lis;
 272     int count = 0;
 273
 274     if (listp == (struct Listblock *) NULL)
 275         return;
 276
 277 /* Count the number of parameters in the list */
 278
 279     for (lis = listp -> listp; lis; lis = lis -> nextp)
 280         count++;
 281
 282     p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
 283
 284     for (lis = listp -> listp; lis; lis = lis -> nextp)
 285         p1_expr ((expptr) lis -> datap);
 286
 287 } /* p1_list */
 288
 289
 290 void p1_label (lab)
 291 long lab;
 292 {
 293         if (parstate < INDATA)
 294                 earlylabs = mkchain((char *)lab, earlylabs);
 295         else
 296                 p1putd (P1_LABEL, lab);
 297         }
 298
 299
 300
 301 static void p1_literal (memno)
 302 long memno;
 303 {
 304     p1putd (P1_LITERAL, memno);
 305 } /* p1_literal */
 306
 307
 308 void p1_if (expr)
 309 expptr expr;
 310 {
 311     p1put (P1_IF);
 312     p1_expr (expr);
 313 } /* p1_if */
 314
 315
 316
 317
 318 void p1_elif (expr)
 319 expptr expr;
 320 {
 321     p1put (P1_ELIF);
 322     p1_expr (expr);
 323 } /* p1_elif */
 324
 325
 326
 327
 328 void p1_else ()
 329 {
 330     p1put (P1_ELSE);
 331 } /* p1_else */
 332
 333
 334
 335
 336 void p1_endif ()
 337 {
 338     p1put (P1_ENDIF);
 339 } /* p1_endif */
 340
 341
 342
 343
 344 void p1else_end ()
 345 {
 346     p1put (P1_ENDELSE);
 347 } /* p1else_end */
 348
 349
 350 static void p1_big_addr (addrp)
 351 Addrp addrp;
 352 {
 353     if (addrp == (Addrp) NULL)
 354         return;
 355
 356     p1putn (P1_ADDR, sizeof (struct Addrblock), (char *) addrp);
 357     p1_expr (addrp -> vleng);
 358     p1_expr (addrp -> memoffset);
 359     if (addrp->uname_tag == UNAM_NAME)
 360         addrp->user.name->visused = 1;
 361 } /* p1_big_addr */
 362
 363
 364
 365 static void p1_unary (e)
 366 struct Exprblock *e;
 367 {
 368     if (e == (struct Exprblock *) NULL)
 369         return;
 370
 371     p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
 372     p1_expr (e -> vleng);
 373
 374     switch (e -> opcode) {
 375         case OPNEG:
 376         case OPNEG1:
 377         case OPNOT:
 378         case OPABS:
 379         case OPBITNOT:
 380         case OPPREINC:
 381         case OPPREDEC:
 382         case OPADDR:
 383         case OPIDENTITY:
 384         case OPCHARCAST:
 385         case OPDABS:
 386             p1_expr(e -> leftp);
 387             break;
 388         default:
 389             erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
 390             break;
 391     } /* switch */
 392
 393 } /* p1_unary */
 394
 395
 396 static void p1_binary (e)
 397 struct Exprblock *e;
 398 {
 399     if (e == (struct Exprblock *) NULL)
 400         return;
 401
 402     p1putdd (P1_EXPR, e -> opcode, e -> vtype);
 403     p1_expr (e -> vleng);
 404     p1_expr (e -> leftp);
 405     p1_expr (e -> rightp);
 406 } /* p1_binary */
 407
 408
 409 void p1_head (class, name)
 410 int class;
 411 char *name;
 412 {
 413     p1putds (P1_HEAD, class, name);
 414 } /* p1_head */
 415
 416
 417 void p1_subr_ret (retexp)
 418 expptr retexp;
 419 {
 420
 421     p1put (P1_SUBR_RET);
 422     p1_expr (retexp);
 423 } /* p1_subr_ret */
 424
 425
 426
 427 void p1comp_goto (index, count, labels)
 428 expptr index;
 429 int count;
 430 struct Labelblock *labels[];
 431 {
 432     struct Constblock c;
 433     int i;
 434     register struct Labelblock *L;
 435
 436     p1put (P1_COMP_GOTO);
 437     p1_expr (index);
 438
 439 /* Write out a P1_LIST directly, to avoid the overhead of allocating a
 440    list before it's needed HACK HACK HACK */
 441
 442     p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
 443     c.vtype = TYLONG;
 444     c.vleng = 0;
 445
 446     for (i = 0; i < count; i++) {
 447         L = labels[i];
 448         L->labused = 1;
 449         c.Const.ci = L->stateno;
 450         p1_const(&c);
 451     } /* for i = 0 */
 452 } /* p1comp_goto */
 453
 454
 455
 456 void p1_for (init, test, inc)
 457 expptr init, test, inc;
 458 {
 459     p1put (P1_FOR);
 460     p1_expr (init);
 461     p1_expr (test);
 462     p1_expr (inc);
 463 } /* p1_for */
 464
 465
 466 void p1for_end ()
 467 {
 468     p1put (P1_ENDFOR);
 469 } /* p1for_end */
 470
 471
 472
 473
 474 /* ----------------------------------------------------------------------
 475    The intermediate file actually gets written ONLY by the routines below.
 476    To change the format of the file, you need only change these routines.
 477    ----------------------------------------------------------------------
 478 */
 479
 480
 481 /* p1puts -- Put a typed string into the Pass 1 intermediate file.  Assumes that
 482    str   contains no newlines and is null-terminated. */
 483
 484 void p1puts (type, str)
 485 int type;
 486 char *str;
 487 {
 488     fprintf (pass1_file, "%d: %s\n", type, str);
 489 } /* p1puts */
 490
 491
 492 /* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
 493
 494 static void p1putd (type, value)
 495 int type;
 496 long value;
 497 {
 498     fprintf (pass1_file, "%d: %ld\n", type, value);
 499 } /* p1_putd */
 500
 501
 502 /* p1putdd -- Put a typed pair of integers into the intermediate file. */
 503
 504 static void p1putdd (type, v1, v2)
 505 int type, v1, v2;
 506 {
 507     fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
 508 } /* p1putdd */
 509
 510
 511 /* p1putddd -- Put a typed triple of integers into the intermediate file. */
 512
 513 static void p1putddd (type, v1, v2, v3)
 514 int type, v1, v2, v3;
 515 {
 516     fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
 517 } /* p1putddd */
 518
 519  union dL {
 520         double d;
 521         long L[2];
 522         };
 523
 524 static void p1putn (type, count, str)
 525 int type, count;
 526 char *str;
 527 {
 528     int i;
 529
 530     fprintf (pass1_file, "%d: ", type);
 531
 532     for (i = 0; i < count; i++)
 533         putc (str[i], pass1_file);
 534
 535     putc ('\n', pass1_file);
 536 } /* p1putn */
 537
 538
 539
 540 /* p1put -- Put a type marker into the intermediate file. */
 541
 542 void p1put(type)
 543 int type;
 544 {
 545     fprintf (pass1_file, "%d:\n", type);
 546 } /* p1put */
 547
 548
 549
 550 static void p1putds (type, i, str)
 551 int type;
 552 int i;
 553 char *str;
 554 {
 555     fprintf (pass1_file, "%d: %d %s\n", type, i, str);
 556 } /* p1putds */
 557
 558
 559 static void p1putdds (token, type, stg, str)
 560 int token, type, stg;
 561 char *str;
 562 {
 563     fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
 564 } /* p1putdds */