lang/fortran/comp/p1output.c

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