lang/fortran/comp/format.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 /* Format.c -- this file takes an intermediate file (generated by pass 1
  25    of the translator) and some state information about the contents of that
  26    file, and generates C program text. */
  27
  28 #include "defs.h"
  29 #include "p1defs.h"
  30 #include "format.h"
  31 #include "output.h"
  32 #include "names.h"
  33 #include "iob.h"
  34
  35 int c_output_line_length = DEF_C_LINE_LENGTH;
  36
  37 int last_was_label;     /* Boolean used to generate semicolons
  38                                    when a label terminates a block */
  39 static char this_proc_name[52]; /* Name of the current procedure.  This is
  40                                    probably too simplistic to handle
  41                                    multiple entry points */
  42
  43 static int p1getd(), p1gets(), p1getf(), get_p1_token();
  44 static int p1get_const(), p1getn();
  45 static expptr do_format(), do_p1_name_pointer(), do_p1_const();
  46 static expptr do_p1_expr(), do_p1_ident(), do_p1_charp(), do_p1_extern();
  47 static expptr do_p1_head(), do_p1_list(), do_p1_literal();
  48 static void do_p1_label(), do_p1_asgoto(), do_p1_goto();
  49 static void do_p1_if(), do_p1_else(), do_p1_elif(), do_p1_endif();
  50 static void do_p1_endelse(), do_p1_subr_ret(), do_p1_comp_goto();
  51 static void do_p1_for(), do_p1_end_for(), do_p1_fortran();
  52 static void do_p1_1while(), do_p1_2while(), do_p1_elseifstart();
  53 static void do_p1_comment(), do_p1_set_line();
  54 static expptr do_p1_addr();
  55 static void proto();
  56 void list_arg_types();
  57 chainp length_comp();
  58 void listargs();
  59 extern chainp assigned_fmts;
  60 static long old_lineno;
  61 static char filename[P1_FILENAME_MAX];
  62 extern int gflag;
  63 extern char *parens;
  64
  65 start_formatting ()
  66 {
  67     FILE *infile;
  68     static int wrote_one = 0;
  69     extern int usedefsforcommon;
  70     extern char *p1_file, *p1_bakfile;
  71
  72     this_proc_name[0] = '\0';
  73     last_was_label = 0;
  74     old_lineno = lineno;
  75     ei_next = ei_first;
  76     wh_next = wh_first;
  77
  78     (void) fclose (pass1_file);
  79     if ((infile = fopen (p1_file, binread)) == NULL)
  80         Fatal("start_formatting:  couldn't open the intermediate file\n");
  81
  82     if (wrote_one)
  83         nice_printf (c_file, "\n");
  84
  85     while (!feof (infile)) {
  86         expptr this_expr;
  87
  88         this_expr = do_format (infile, c_file);
  89         if (this_expr) {
  90             out_and_free_statement (c_file, this_expr);
  91         } /* if this_expr */
  92     } /* while !feof infile */
  93
  94     (void) fclose (infile);
  95
  96     if (last_was_label)
  97         nice_printf (c_file, ";\n");
  98
  99     prev_tab (c_file);
 100     if (this_proc_name[0])
 101         nice_printf (c_file, "} /* %s */\n", this_proc_name);
 102
 103
 104 /* Write the #undefs for common variable reference */
 105
 106     if (usedefsforcommon) {
 107         Extsym *ext;
 108         int did_one = 0;
 109
 110         for (ext = extsymtab; ext < nextext; ext++)
 111             if (ext -> extstg == STGCOMMON && ext -> used_here) {
 112                 ext -> used_here = 0;
 113                 if (!did_one)
 114                     nice_printf (c_file, "\n");
 115                 wr_abbrevs(c_file, 0, ext->extp);
 116                 did_one = 1;
 117                 ext -> extp = CHNULL;
 118             } /* if */
 119
 120         if (did_one)
 121             nice_printf (c_file, "\n");
 122     } /* if usedefsforcommon */
 123
 124     other_undefs(c_file);
 125
 126     wrote_one = 1;
 127
 128 /* For debugging only */
 129
 130     if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
 131         if (infile = fopen (p1_file, binread)) {
 132             ffilecopy (infile, pass1_file);
 133             fclose (infile);
 134             fclose (pass1_file);
 135         } /* if infile */
 136
 137 /* End of "debugging only" */
 138
 139     scrub(p1_file);     /* optionally unlink */
 140
 141     if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
 142         err ("start_formatting:  couldn't reopen the pass1 file");
 143
 144 } /* start_formatting */
 145
 146
 147  static void
 148 put_semi(outfile)
 149  FILE *outfile;
 150 {
 151         nice_printf (outfile, ";\n");
 152         last_was_label = 0;
 153         }
 154
 155 #define SEM_CHECK(x) if (last_was_label) put_semi(x)
 156
 157 /* do_format -- takes an input stream (a file in pass1 format) and writes
 158    the appropriate C code to   outfile   when possible.  When reading an
 159    expression, the expression tree is returned instead. */
 160
 161 static expptr do_format (infile, outfile)
 162 FILE *infile, *outfile;
 163 {
 164     int gsave, token_type, was_c_token;
 165     expptr retval = ENULL;
 166
 167     token_type = get_p1_token (infile);
 168     was_c_token = 1;
 169     switch (token_type) {
 170         case P1_COMMENT:
 171             do_p1_comment (infile, outfile);
 172             was_c_token = 0;
 173             break;
 174         case P1_SET_LINE:
 175             do_p1_set_line (infile);
 176             was_c_token = 0;
 177             break;
 178         case P1_FILENAME:
 179             p1gets(infile, filename, P1_FILENAME_MAX);
 180             was_c_token = 0;
 181             break;
 182         case P1_NAME_POINTER:
 183             retval = do_p1_name_pointer (infile);
 184             break;
 185         case P1_CONST:
 186             retval = do_p1_const (infile);
 187             break;
 188         case P1_EXPR:
 189             retval = do_p1_expr (infile, outfile);
 190             break;
 191         case P1_IDENT:
 192             retval = do_p1_ident(infile);
 193             break;
 194         case P1_CHARP:
 195                 retval = do_p1_charp(infile);
 196                 break;
 197         case P1_EXTERN:
 198             retval = do_p1_extern (infile);
 199             break;
 200         case P1_HEAD:
 201             gsave = gflag;
 202             gflag = 0;
 203             retval = do_p1_head (infile, outfile);
 204             gflag = gsave;
 205             break;
 206         case P1_LIST:
 207             retval = do_p1_list (infile, outfile);
 208             break;
 209         case P1_LITERAL:
 210             retval = do_p1_literal (infile);
 211             break;
 212         case P1_LABEL:
 213             do_p1_label (infile, outfile);
 214             /* last_was_label = 1; -- now set in do_p1_label */
 215             was_c_token = 0;
 216             break;
 217         case P1_ASGOTO:
 218             do_p1_asgoto (infile, outfile);
 219             break;
 220         case P1_GOTO:
 221             do_p1_goto (infile, outfile);
 222             break;
 223         case P1_IF:
 224             do_p1_if (infile, outfile);
 225             break;
 226         case P1_ELSE:
 227             SEM_CHECK(outfile);
 228             do_p1_else (outfile);
 229             break;
 230         case P1_ELIF:
 231             SEM_CHECK(outfile);
 232             do_p1_elif (infile, outfile);
 233             break;
 234         case P1_ENDIF:
 235             SEM_CHECK(outfile);
 236             do_p1_endif (outfile);
 237             break;
 238         case P1_ENDELSE:
 239             SEM_CHECK(outfile);
 240             do_p1_endelse (outfile);
 241             break;
 242         case P1_ADDR:
 243             retval = do_p1_addr (infile, outfile);
 244             break;
 245         case P1_SUBR_RET:
 246             do_p1_subr_ret (infile, outfile);
 247             break;
 248         case P1_COMP_GOTO:
 249             do_p1_comp_goto (infile, outfile);
 250             break;
 251         case P1_FOR:
 252             do_p1_for (infile, outfile);
 253             break;
 254         case P1_ENDFOR:
 255             SEM_CHECK(outfile);
 256             do_p1_end_for (outfile);
 257             break;
 258         case P1_WHILE1START:
 259                 do_p1_1while(outfile);
 260                 break;
 261         case P1_WHILE2START:
 262                 do_p1_2while(infile, outfile);
 263                 break;
 264         case P1_PROCODE:
 265                 procode(outfile);
 266                 break;
 267         case P1_ELSEIFSTART:
 268                 SEM_CHECK(outfile);
 269                 do_p1_elseifstart(outfile);
 270                 break;
 271         case P1_FORTRAN:
 272                 do_p1_fortran(infile, outfile);
 273                 /* no break; */
 274         case P1_EOF:
 275             was_c_token = 0;
 276             break;
 277         case P1_UNKNOWN:
 278             Fatal("do_format:  Unknown token type in intermediate file");
 279             break;
 280         default:
 281             Fatal("do_format:  Bad token type in intermediate file");
 282             break;
 283    } /* switch */
 284
 285     if (was_c_token)
 286         last_was_label = 0;
 287     return retval;
 288 } /* do_format */
 289
 290
 291  static void
 292 do_p1_comment (infile, outfile)
 293 FILE *infile, *outfile;
 294 {
 295     extern int c_output_line_length, in_comment;
 296
 297     char storage[COMMENT_BUFFER_SIZE + 1];
 298     int length;
 299
 300     if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
 301         return;
 302
 303     length = strlen (storage);
 304
 305     in_comment = 1;
 306     if (length > c_output_line_length - 6)
 307         margin_printf (outfile, "/*%s*/\n", storage);
 308     else
 309         margin_printf (outfile, length ? "/* %s */\n" : "\n", storage);
 310     in_comment = 0;
 311 } /* do_p1_comment */
 312
 313  static void
 314 do_p1_set_line (infile)
 315 FILE *infile;
 316 {
 317     int status;
 318     long new_line_number = -1;
 319
 320     status = p1getd (infile, &new_line_number);
 321
 322     if (status == EOF)
 323         err ("do_p1_set_line:  Missing line number at end of file\n");
 324     else if (status == 0 || new_line_number == -1)
 325         errl("do_p1_set_line:  Illegal line number in intermediate file: %ld\n",
 326                 new_line_number);
 327     else {
 328         lineno = new_line_number;
 329         if (gflag)
 330                 fprintf(c_file, "/*# %ld \"%s\"*/\n", lineno, filename);
 331         }
 332 } /* do_p1_set_line */
 333
 334
 335 static expptr do_p1_name_pointer (infile)
 336 FILE *infile;
 337 {
 338     Namep namep = (Namep) NULL;
 339     int status;
 340
 341     status = p1getd (infile, (long *) &namep);
 342
 343     if (status == EOF)
 344         err ("do_p1_name_pointer:  Missing pointer at end of file\n");
 345     else if (status == 0 || namep == (Namep) NULL)
 346         erri ("do_p1_name_pointer:  Illegal name pointer in p1 file: '%x'\n",
 347                 (int) namep);
 348
 349     return (expptr) namep;
 350 } /* do_p1_name_pointer */
 351
 352
 353
 354 static expptr do_p1_const (infile)
 355 FILE *infile;
 356 {
 357     struct Constblock *c = (struct Constblock *) NULL;
 358     long type = -1;
 359     int status;
 360
 361     status = p1getd (infile, &type);
 362
 363     if (status == EOF)
 364         err ("do_p1_const:  Missing constant type at end of file\n");
 365     else if (status == 0)
 366         errl("do_p1_const:  Illegal constant type in p1 file: %ld\n", type);
 367     else {
 368         status = p1get_const (infile, (int)type, &c);
 369
 370         if (status == EOF) {
 371             err ("do_p1_const:  Missing constant value at end of file\n");
 372             c = (struct Constblock *) NULL;
 373         } else if (status == 0) {
 374             err ("do_p1_const:  Illegal constant value in p1 file\n");
 375             c = (struct Constblock *) NULL;
 376         } /* else */
 377     } /* else */
 378     return (expptr) c;
 379 } /* do_p1_const */
 380
 381
 382 static expptr do_p1_literal (infile)
 383 FILE *infile;
 384 {
 385     int status;
 386     long memno;
 387     Addrp addrp;
 388
 389     status = p1getd (infile, &memno);
 390
 391     if (status == EOF)
 392         err ("do_p1_literal:  Missing memno at end of file");
 393     else if (status == 0)
 394         err ("do_p1_literal:  Missing memno in p1 file");
 395     else {
 396         struct Literal *litp, *lastlit;
 397
 398         addrp = ALLOC (Addrblock);
 399         addrp -> tag = TADDR;
 400         addrp -> vtype = TYUNKNOWN;
 401         addrp -> Field = NULL;
 402
 403         lastlit = litpool + nliterals;
 404         for (litp = litpool; litp < lastlit; litp++)
 405             if (litp -> litnum == memno) {
 406                 addrp -> vtype = litp -> littype;
 407                 *((union Constant *) &(addrp -> user)) =
 408                         *((union Constant *) &(litp -> litval));
 409                 break;
 410             } /* if litp -> litnum == memno */
 411
 412         addrp -> memno = memno;
 413         addrp -> vstg = STGMEMNO;
 414         addrp -> uname_tag = UNAM_CONST;
 415     } /* else */
 416
 417     return (expptr) addrp;
 418 } /* do_p1_literal */
 419
 420
 421 static void do_p1_label (infile, outfile)
 422 FILE *infile, *outfile;
 423 {
 424     int status;
 425     ftnint stateno;
 426     char *user_label ();
 427     struct Labelblock *L;
 428     char *fmt;
 429
 430     status = p1getd (infile, &stateno);
 431
 432     if (status == EOF)
 433         err ("do_p1_label:  Missing label at end of file");
 434     else if (status == 0)
 435         err ("do_p1_label:  Missing label in p1 file ");
 436     else if (stateno < 0) {     /* entry */
 437         margin_printf(outfile, "\n%s:\n", user_label(stateno));
 438         last_was_label = 1;
 439         }
 440     else {
 441         L = labeltab + stateno;
 442         if (L->labused) {
 443                 fmt = "%s:\n";
 444                 last_was_label = 1;
 445                 }
 446         else
 447                 fmt = "/* %s: */\n";
 448         margin_printf(outfile, fmt, user_label(L->stateno));
 449     } /* else */
 450 } /* do_p1_label */
 451
 452
 453
 454 static void do_p1_asgoto (infile, outfile)
 455 FILE *infile, *outfile;
 456 {
 457     expptr expr;
 458
 459     expr = do_format (infile, outfile);
 460     out_asgoto (outfile, expr);
 461
 462 } /* do_p1_asgoto */
 463
 464
 465 static void do_p1_goto (infile, outfile)
 466 FILE *infile, *outfile;
 467 {
 468     int status;
 469     long stateno;
 470     char *user_label ();
 471
 472     status = p1getd (infile, &stateno);
 473
 474     if (status == EOF)
 475         err ("do_p1_goto:  Missing goto label at end of file");
 476     else if (status == 0)
 477         err ("do_p1_goto:  Missing goto label in p1 file");
 478     else {
 479         nice_printf (outfile, "goto %s;\n", user_label (stateno));
 480     } /* else */
 481 } /* do_p1_goto */
 482
 483
 484 static void do_p1_if (infile, outfile)
 485 FILE *infile, *outfile;
 486 {
 487     expptr cond;
 488
 489     do {
 490         cond = do_format (infile, outfile);
 491     } while (cond == ENULL);
 492
 493     out_if (outfile, cond);
 494 } /* do_p1_if */
 495
 496
 497 static void do_p1_else (outfile)
 498 FILE *outfile;
 499 {
 500     out_else (outfile);
 501 } /* do_p1_else */
 502
 503
 504 static void do_p1_elif (infile, outfile)
 505 FILE *infile, *outfile;
 506 {
 507     expptr cond;
 508
 509     do {
 510         cond = do_format (infile, outfile);
 511     } while (cond == ENULL);
 512
 513     elif_out (outfile, cond);
 514 } /* do_p1_elif */
 515
 516 static void do_p1_endif (outfile)
 517 FILE *outfile;
 518 {
 519     endif_out (outfile);
 520 } /* do_p1_endif */
 521
 522
 523 static void do_p1_endelse (outfile)
 524 FILE *outfile;
 525 {
 526     end_else_out (outfile);
 527 } /* do_p1_endelse */
 528
 529
 530 static expptr do_p1_addr (infile, outfile)
 531 FILE *infile, *outfile;
 532 {
 533     Addrp addrp = (Addrp) NULL;
 534     int status;
 535
 536     status = p1getn (infile, sizeof (struct Addrblock), (char **) &addrp);
 537
 538     if (status == EOF)
 539         err ("do_p1_addr:  Missing Addrp at end of file");
 540     else if (status == 0)
 541         err ("do_p1_addr:  Missing Addrp in p1 file");
 542     else if (addrp == (Addrp) NULL)
 543         err ("do_p1_addr:  Null addrp in p1 file");
 544     else if (addrp -> tag != TADDR)
 545         erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
 546     else {
 547         addrp -> vleng = do_format (infile, outfile);
 548         addrp -> memoffset = do_format (infile, outfile);
 549     }
 550
 551     return (expptr) addrp;
 552 } /* do_p1_addr */
 553
 554
 555
 556 static void do_p1_subr_ret (infile, outfile)
 557 FILE *infile, *outfile;
 558 {
 559     expptr retval;
 560
 561     nice_printf (outfile, "return ");
 562     retval = do_format (infile, outfile);
 563     if (!multitype)
 564         if (retval)
 565                 expr_out (outfile, retval);
 566
 567     nice_printf (outfile, ";\n");
 568 } /* do_p1_subr_ret */
 569
 570
 571
 572 static void do_p1_comp_goto (infile, outfile)
 573 FILE *infile, *outfile;
 574 {
 575     expptr index;
 576     expptr labels;
 577
 578     index = do_format (infile, outfile);
 579
 580     if (index == ENULL) {
 581         err ("do_p1_comp_goto:  no expression for computed goto");
 582         return;
 583     } /* if index == ENULL */
 584
 585     labels = do_format (infile, outfile);
 586
 587     if (labels && labels -> tag != TLIST)
 588         erri ("do_p1_comp_goto:  expected list, got tag '%d'", labels -> tag);
 589     else
 590         compgoto_out (outfile, index, labels);
 591 } /* do_p1_comp_goto */
 592
 593
 594 static void do_p1_for (infile, outfile)
 595 FILE *infile, *outfile;
 596 {
 597     expptr init, test, inc;
 598
 599     init = do_format (infile, outfile);
 600     test = do_format (infile, outfile);
 601     inc = do_format (infile, outfile);
 602
 603     out_for (outfile, init, test, inc);
 604 } /* do_p1_for */
 605
 606 static void do_p1_end_for (outfile)
 607 FILE *outfile;
 608 {
 609     out_end_for (outfile);
 610 } /* do_p1_end_for */
 611
 612
 613  static void
 614 do_p1_fortran(infile, outfile)
 615  FILE *infile, *outfile;
 616 {
 617         char buf[P1_STMTBUFSIZE];
 618         if (!p1gets(infile, buf, P1_STMTBUFSIZE))
 619                 return;
 620         /* bypass nice_printf nonsense */
 621         fprintf(outfile, "/*< %s >*/\n", buf+1);        /* + 1 to skip by '$' */
 622         }
 623
 624
 625 static expptr do_p1_expr (infile, outfile)
 626 FILE *infile, *outfile;
 627 {
 628     int status;
 629     long opcode, type;
 630     struct Exprblock *result = (struct Exprblock *) NULL;
 631
 632     status = p1getd (infile, &opcode);
 633
 634     if (status == EOF)
 635         err ("do_p1_expr:  Missing expr opcode at end of file");
 636     else if (status == 0)
 637         err ("do_p1_expr:  Missing expr opcode in p1 file");
 638     else {
 639
 640         status = p1getd (infile, &type);
 641
 642         if (status == EOF)
 643             err ("do_p1_expr:  Missing expr type at end of file");
 644         else if (status == 0)
 645             err ("do_p1_expr:  Missing expr type in p1 file");
 646         else if (opcode == 0)
 647             return ENULL;
 648         else {
 649             result = ALLOC (Exprblock);
 650
 651             result -> tag = TEXPR;
 652             result -> vtype = type;
 653             result -> opcode = opcode;
 654             result -> vleng = do_format (infile, outfile);
 655
 656             if (is_unary_op (opcode))
 657                 result -> leftp = do_format (infile, outfile);
 658             else if (is_binary_op (opcode)) {
 659                 result -> leftp = do_format (infile, outfile);
 660                 result -> rightp = do_format (infile, outfile);
 661             } else
 662                 errl("do_p1_expr:  Illegal opcode %ld", opcode);
 663         } /* else */
 664     } /* else */
 665
 666     return (expptr) result;
 667 } /* do_p1_expr */
 668
 669
 670 static expptr do_p1_ident(infile)
 671 FILE *infile;
 672 {
 673         Addrp addrp;
 674         int status;
 675         long vtype, vstg;
 676
 677         addrp = ALLOC (Addrblock);
 678         addrp -> tag = TADDR;
 679
 680         status = p1getd (infile, &vtype);
 681         if (status == EOF)
 682             err ("do_p1_ident:  Missing identifier type at end of file\n");
 683         else if (status == 0 || vtype < 0 || vtype >= NTYPES)
 684             errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
 685         else
 686             addrp -> vtype = vtype;
 687
 688         status = p1getd (infile, &vstg);
 689         if (status == EOF)
 690             err ("do_p1_ident:  Missing identifier storage at end of file\n");
 691         else if (status == 0 || vstg < 0 || vstg > STGNULL)
 692             errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
 693         else
 694             addrp -> vstg = vstg;
 695
 696         status = p1gets(infile, addrp->user.ident, IDENT_LEN);
 697
 698         if (status == EOF)
 699             err ("do_p1_ident:  Missing ident string at end of file");
 700         else if (status == 0)
 701             err ("do_p1_ident:  Missing ident string in intermediate file");
 702         addrp->uname_tag = UNAM_IDENT;
 703         return (expptr) addrp;
 704 } /* do_p1_ident */
 705
 706 static expptr do_p1_charp(infile)
 707 FILE *infile;
 708 {
 709         Addrp addrp;
 710         int status;
 711         long vtype, vstg;
 712         char buf[64];
 713
 714         addrp = ALLOC (Addrblock);
 715         addrp -> tag = TADDR;
 716
 717         status = p1getd (infile, &vtype);
 718         if (status == EOF)
 719             err ("do_p1_ident:  Missing identifier type at end of file\n");
 720         else if (status == 0 || vtype < 0 || vtype >= NTYPES)
 721             errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
 722         else
 723             addrp -> vtype = vtype;
 724
 725         status = p1getd (infile, &vstg);
 726         if (status == EOF)
 727             err ("do_p1_ident:  Missing identifier storage at end of file\n");
 728         else if (status == 0 || vstg < 0 || vstg > STGNULL)
 729             errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
 730         else
 731             addrp -> vstg = vstg;
 732
 733         status = p1gets(infile, buf, (int)sizeof(buf));
 734
 735         if (status == EOF)
 736             err ("do_p1_ident:  Missing charp ident string at end of file");
 737         else if (status == 0)
 738             err ("do_p1_ident:  Missing charp ident string in intermediate file");
 739         addrp->uname_tag = UNAM_CHARP;
 740         addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
 741         return (expptr) addrp;
 742 }
 743
 744
 745 static expptr do_p1_extern (infile)
 746 FILE *infile;
 747 {
 748     Addrp addrp;
 749
 750     addrp = ALLOC (Addrblock);
 751     if (addrp) {
 752         int status;
 753
 754         addrp->tag = TADDR;
 755         addrp->vstg = STGEXT;
 756         addrp->uname_tag = UNAM_EXTERN;
 757         status = p1getd (infile, &(addrp -> memno));
 758         if (status == EOF)
 759             err ("do_p1_extern:  Missing memno at end of file");
 760         else if (status == 0)
 761             err ("do_p1_extern:  Missing memno in intermediate file");
 762         if (addrp->vtype = extsymtab[addrp->memno].extype)
 763                 addrp->vclass = CLPROC;
 764     } /* if addrp */
 765
 766     return (expptr) addrp;
 767 } /* do_p1_extern */
 768
 769
 770
 771 static expptr do_p1_head (infile, outfile)
 772 FILE *infile, *outfile;
 773 {
 774     int status;
 775     int add_n_;
 776     long class;
 777     char storage[256];
 778
 779     status = p1getd (infile, &class);
 780     if (status == EOF)
 781         err ("do_p1_head:  missing header class at end of file");
 782     else if (status == 0)
 783         err ("do_p1_head:  missing header class in p1 file");
 784     else {
 785         status = p1gets (infile, storage, (int)sizeof(storage));
 786         if (status == EOF || status == 0)
 787             storage[0] = '\0';
 788     } /* else */
 789
 790     if (class == CLPROC || class == CLMAIN) {
 791         chainp lengths;
 792
 793         add_n_ = nentry > 1;
 794         lengths = length_comp(entries, add_n_);
 795
 796         if (!add_n_ && protofile && class != CLMAIN)
 797                 protowrite(protofile, proctype, storage, entries, lengths);
 798
 799         if (class == CLMAIN)
 800             nice_printf (outfile, "/* Main program */ ");
 801         else
 802             nice_printf(outfile, "%s ", multitype ? "VOID"
 803                         : c_type_decl(proctype, 1));
 804
 805         nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
 806         if (!Ansi) {
 807                 listargs(outfile, entries, add_n_, lengths);
 808                 nice_printf (outfile, "\n");
 809                 }
 810         list_arg_types (outfile, entries, lengths, add_n_, "\n");
 811         nice_printf (outfile, "{\n");
 812         frchain(&lengths);
 813         next_tab (outfile);
 814         strcpy(this_proc_name, storage);
 815         list_decls (outfile);
 816
 817     } else if (class == CLBLOCK)
 818         next_tab (outfile);
 819     else
 820         errl("do_p1_head: got class %ld", class);
 821
 822     return NULL;
 823 } /* do_p1_head */
 824
 825
 826 static expptr do_p1_list (infile, outfile)
 827 FILE *infile, *outfile;
 828 {
 829     long tag, type, count;
 830     int status;
 831     expptr result;
 832
 833     status = p1getd (infile, &tag);
 834     if (status == EOF)
 835         err ("do_p1_list:  missing list tag at end of file");
 836     else if (status == 0)
 837         err ("do_p1_list:  missing list tag in p1 file");
 838     else {
 839         status = p1getd (infile, &type);
 840         if (status == EOF)
 841             err ("do_p1_list:  missing list type at end of file");
 842         else if (status == 0)
 843             err ("do_p1_list:  missing list type in p1 file");
 844         else {
 845             status = p1getd (infile, &count);
 846             if (status == EOF)
 847                 err ("do_p1_list:  missing count at end of file");
 848             else if (status == 0)
 849                 err ("do_p1_list:  missing count in p1 file");
 850         } /* else */
 851     } /* else */
 852
 853     result = (expptr) ALLOC (Listblock);
 854     if (result) {
 855         chainp pointer;
 856
 857         result -> tag = tag;
 858         result -> listblock.vtype = type;
 859
 860 /* Assume there will be enough data */
 861
 862         if (count--) {
 863             pointer = result->listblock.listp =
 864                 mkchain((char *)do_format(infile, outfile), CHNULL);
 865             while (count--) {
 866                 pointer -> nextp =
 867                         mkchain((char *)do_format(infile, outfile), CHNULL);
 868                 pointer = pointer -> nextp;
 869             } /* while (count--) */
 870         } /* if (count) */
 871     } /* if (result) */
 872
 873     return result;
 874 } /* do_p1_list */
 875
 876
 877 chainp length_comp(e, add_n)    /* get lengths of characters args */
 878  struct Entrypoint *e;
 879  int add_n;
 880 {
 881         chainp lengths;
 882         chainp args, args1;
 883         Namep arg, np;
 884         int nchargs;
 885         Argtypes *at;
 886         Atype *a;
 887         extern int init_ac[TYSUBR+1];
 888
 889         args = args1 = add_n ? allargs : e->arglist;
 890         nchargs = 0;
 891         for (lengths = NULL; args; args = args -> nextp)
 892                 if (arg = (Namep)args->datap) {
 893                         if (arg->vclass == CLUNKNOWN)
 894                                 arg->vclass = CLVAR;
 895                         if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
 896                                 lengths = mkchain((char *)arg, lengths);
 897                                 nchargs++;
 898                                 }
 899                         }
 900         if (!add_n && (np = e->enamep)) {
 901                 /* one last check -- by now we know all we ever will
 902                  * about external args...
 903                  */
 904                 save_argtypes(e->arglist, &e->entryname->arginfo,
 905                         &np->arginfo, 0, np->fvarname, STGEXT, nchargs,
 906                         np->vtype, 1);
 907                 at = e->entryname->arginfo;
 908                 a = at->atypes + init_ac[np->vtype];
 909                 for(; args1; a++, args1 = args1->nextp) {
 910                         frchain(&a->cp);
 911                         if (arg = (Namep)args1->datap)
 912                             switch(arg->vclass) {
 913                                 case CLPROC:
 914                                         if (arg->vimpltype
 915                                         && a->type >= 300)
 916                                                 a->type = TYUNKNOWN + 200;
 917                                         break;
 918                                 case CLUNKNOWN:
 919                                         a->type %= 100;
 920                                 }
 921                         }
 922                 }
 923         return revchain(lengths);
 924         }
 925
 926 void listargs(outfile, entryp, add_n_, lengths)
 927  FILE *outfile;
 928  struct Entrypoint *entryp;
 929  int add_n_;
 930  chainp lengths;
 931 {
 932         chainp args;
 933         char *s;
 934         Namep arg;
 935         int did_one = 0;
 936
 937         nice_printf (outfile, "(");
 938
 939         if (add_n_) {
 940                 nice_printf(outfile, "n__");
 941                 did_one = 1;
 942                 args = allargs;
 943                 }
 944         else
 945                 args = entryp->arglist;
 946
 947         if (multitype)
 948                 {
 949                 nice_printf(outfile, ", ret_val");
 950                 did_one = 1;
 951                 args = allargs;
 952                 }
 953         else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
 954                 {
 955                 s = xretslot[proctype]->user.ident;
 956                 nice_printf(outfile, did_one ? ", %s" : "%s",
 957                         *s == '(' /*)*/ ? "r_v" : s);
 958                 did_one = 1;
 959                 if (proctype == TYCHAR)
 960                         nice_printf (outfile, ", ret_val_len");
 961                 }
 962         for (; args; args = args -> nextp)
 963                 if (arg = (Namep)args->datap) {
 964                         nice_printf (outfile, "%s", did_one ? ", " : "");
 965                         out_name (outfile, arg);
 966                         did_one = 1;
 967                         }
 968
 969         for (args = lengths; args; args = args -> nextp)
 970                 nice_printf(outfile, ", %s",
 971                         new_arg_length((Namep)args->datap));
 972         nice_printf (outfile, ")");
 973 } /* listargs */
 974
 975
 976 void list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
 977 FILE *outfile;
 978 struct Entrypoint *entryp;
 979 chainp lengths;
 980 int add_n_;
 981 char *finalnl;
 982 {
 983     chainp args;
 984     int last_type = -1, last_class = -1;
 985     int did_one = 0, done_one, is_ext;
 986     char *s, *sep = "", *sep1;
 987
 988     if (outfile == (FILE *) NULL) {
 989         err ("list_arg_types:  null output file");
 990         return;
 991     } else if (entryp == (struct Entrypoint *) NULL) {
 992         err ("list_arg_types:  null procedure entry pointer");
 993         return;
 994     } /* else */
 995
 996     if (Ansi) {
 997         done_one = 0;
 998         sep1 = ", ";
 999         nice_printf(outfile, "(" /*)*/);
1000         }
1001     else {
1002         done_one = 1;
1003         sep1 = ";\n";
1004         }
1005     args = entryp->arglist;
1006     if (add_n_) {
1007         nice_printf(outfile, "int n__");
1008         did_one = done_one;
1009         sep = sep1;
1010         args = allargs;
1011         }
1012     if (multitype) {
1013         nice_printf(outfile, "%sMultitype *ret_val", sep);
1014         did_one = done_one;
1015         sep = sep1;
1016         }
1017     else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
1018         s = xretslot[proctype]->user.ident;
1019         nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
1020                         *s == '(' /*)*/ ? "r_v" : s);
1021         did_one = done_one;
1022         sep = sep1;
1023         if (proctype == TYCHAR)
1024             nice_printf (outfile, "%sftnlen ret_val_len", sep);
1025     } /* if ONEOF proctype */
1026     for (; args; args = args -> nextp) {
1027         Namep arg = (Namep) args->datap;
1028
1029 /* Scalars are passed by reference, and arrays will have their lower bound
1030    adjusted, so nearly everything is printed with a star in front.  The
1031    exception is character lengths, which are passed by value. */
1032
1033         if (arg) {
1034             int type = arg -> vtype, class = arg -> vclass;
1035
1036             if (class == CLPROC)
1037                 if (arg->vimpltype)
1038                         type = Castargs ? TYUNKNOWN : TYSUBR;
1039                 else if (type == TYREAL && forcedouble && !Castargs)
1040                         type = TYDREAL;
1041
1042             if (type == last_type && class == last_class && did_one)
1043                 nice_printf (outfile, ", ");
1044             else
1045                 if ((is_ext = class == CLPROC) && Castargs)
1046                         nice_printf(outfile, "%s%s ", sep,
1047                                 usedcasts[type] = casttypes[type]);
1048                 else
1049                         nice_printf(outfile, "%s%s ", sep,
1050                                 c_type_decl(type, is_ext));
1051             if (class == CLPROC)
1052                 if (Castargs)
1053                         out_name(outfile, arg);
1054                 else {
1055                         nice_printf(outfile, "(*");
1056                         out_name(outfile, arg);
1057                         nice_printf(outfile, ") %s", parens);
1058                         }
1059             else {
1060                 nice_printf (outfile, "*");
1061                 out_name (outfile, arg);
1062                 }
1063
1064             last_type = type;
1065             last_class = class;
1066             did_one = done_one;
1067             sep = sep1;
1068         } /* if (arg) */
1069     } /* for args = entryp -> arglist */
1070
1071     for (args = lengths; args; args = args -> nextp)
1072         nice_printf(outfile, "%sftnlen %s", sep,
1073                         new_arg_length((Namep)args->datap));
1074     if (did_one)
1075         nice_printf (outfile, ";\n");
1076     else if (Ansi)
1077         nice_printf(outfile,
1078                 /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
1079                 finalnl);
1080 } /* list_arg_types */
1081
1082  static void
1083 write_formats(outfile)
1084  FILE *outfile;
1085 {
1086         register struct Labelblock *lp;
1087         int first = 1;
1088         char *fs;
1089
1090         for(lp = labeltab ; lp < highlabtab ; ++lp)
1091                 if (lp->fmtlabused) {
1092                         if (first) {
1093                                 first = 0;
1094                                 nice_printf(outfile, "/* Format strings */\n");
1095                                 }
1096                         nice_printf(outfile, "static char fmt_%ld[] = \"",
1097                                 lp->stateno);
1098                         if (!(fs = lp->fmtstring))
1099                                 fs = "";
1100                         nice_printf(outfile, "%s\";\n", fs);
1101                         }
1102         if (!first)
1103                 nice_printf(outfile, "\n");
1104         }
1105
1106  static void
1107 write_ioblocks(outfile)
1108  FILE *outfile;
1109 {
1110         register iob_data *L;
1111         register char *f, **s, *sep;
1112
1113         nice_printf(outfile, "/* Fortran I/O blocks */\n");
1114         L = iob_list = (iob_data *)revchain((chainp)iob_list);
1115         do {
1116                 nice_printf(outfile, "static %s %s = { ",
1117                         L->type, L->name);
1118                 sep = 0;
1119                 for(s = L->fields; f = *s; s++) {
1120                         if (sep)
1121                                 nice_printf(outfile, sep);
1122                         sep = ", ";
1123                         if (*f == '"') {        /* kludge */
1124                                 nice_printf(outfile, "\"");
1125                                 nice_printf(outfile, "%s\"", f+1);
1126                                 }
1127                         else
1128                                 nice_printf(outfile, "%s", f);
1129                         }
1130                 nice_printf(outfile, " };\n");
1131                 }
1132                 while(L = L->next);
1133         nice_printf(outfile, "\n\n");
1134         }
1135
1136  static void
1137 write_assigned_fmts(outfile)
1138  FILE *outfile;
1139 {
1140         register chainp cp;
1141         Namep np;
1142         int did_one = 0;
1143
1144         cp = assigned_fmts = revchain(assigned_fmts);
1145         nice_printf(outfile, "/* Assigned format variables */\nchar ");
1146         do {
1147                 np = (Namep)cp->datap;
1148                 if (did_one)
1149                         nice_printf(outfile, ", ");
1150                 did_one = 1;
1151                 nice_printf(outfile, "*%s_fmt", np->fvarname);
1152                 }
1153                 while(cp = cp->nextp);
1154         nice_printf(outfile, ";\n\n");
1155         }
1156
1157  static char *
1158 to_upper(s)
1159  register char *s;
1160 {
1161         static char buf[64];
1162         register char *t = buf;
1163         register int c;
1164         while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
1165         return buf;
1166         }
1167
1168
1169 /* This routine creates static structures representing a namelist.
1170    Declarations of the namelist and related structures are:
1171
1172         struct Vardesc {
1173                 char *name;
1174                 char *addr;
1175                 ftnlen *dims;   /* laid out as struct dimensions below *//*
1176                 int  type;
1177                 };
1178         typedef struct Vardesc Vardesc;
1179
1180         struct Namelist {
1181                 char *name;
1182                 Vardesc **vars;
1183                 int nvars;
1184                 };
1185
1186         struct dimensions
1187                 {
1188                 ftnlen numberofdimensions;
1189                 ftnlen numberofelements
1190                 ftnlen baseoffset;
1191                 ftnlen span[numberofdimensions-1];
1192                 };
1193
1194    If dims is not null, then the corner element of the array is at
1195    addr.  However,  the element with subscripts (i1,...,in) is at
1196    addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
1197 */
1198
1199  static void
1200 write_namelists(nmch, outfile)
1201  chainp nmch;
1202  FILE *outfile;
1203 {
1204         Namep var;
1205         struct Hashentry *entry;
1206         struct Dimblock *dimp;
1207         int i, nd, type;
1208         char *comma, *name;
1209         register chainp q;
1210         register Namep v;
1211
1212         nice_printf(outfile, "/* Namelist stuff */\n\n");
1213         for (entry = hashtab; entry < lasthash; ++entry) {
1214                 if (!(v = entry->varp) || !v->vnamelist)
1215                         continue;
1216                 type = v->vtype;
1217                 name = v->cvarname;
1218                 if (dimp = v->vdim) {
1219                         nd = dimp->ndim;
1220                         nice_printf(outfile,
1221                                 "static ftnlen %s_dims[] = { %d, %ld, %ld",
1222                                 name, nd,
1223                                 dimp->nelt->constblock.Const.ci,
1224                                 dimp->baseoffset->constblock.Const.ci);
1225                         for(i = 0, --nd; i < nd; i++)
1226                                 nice_printf(outfile, ", %ld",
1227                                   dimp->dims[i].dimsize->constblock.Const.ci);
1228                         nice_printf(outfile, " };\n");
1229                         }
1230                 nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
1231                         name, to_upper(name),
1232                         type == TYCHAR ? "" : dimp ? "(char *)" : "(char *)&");
1233                 out_name(outfile, v);
1234                 nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
1235                 nice_printf(outfile, ", %ld };\n",
1236                         type != TYCHAR  ? (long)type
1237                                         : -v->vleng->constblock.Const.ci);
1238                 }
1239
1240         do {
1241                 var = (Namep)nmch->datap;
1242                 name = var->cvarname;
1243                 nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
1244                 comma = "{";
1245                 i = 0;
1246                 for(q = var->varxptr.namelist ; q ; q = q->nextp) {
1247                         v = (Namep)q->datap;
1248                         if (!v->vnamelist)
1249                                 continue;
1250                         i++;
1251                         nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
1252                         comma = ",";
1253                         }
1254                 nice_printf(outfile, " };\n");
1255                 nice_printf(outfile,
1256                         "static Namelist %s = { \"%s\", %s_vl, %d };\n",
1257                         name, to_upper(name), name, i);
1258                 }
1259                 while(nmch = nmch->nextp);
1260         nice_printf(outfile, "\n");
1261         }
1262
1263 /* fixextype tries to infer from usage in previous procedures
1264    the type of an external procedure declared
1265    external and passed as an argument but never typed or invoked.
1266  */
1267
1268  static int
1269 fixexttype(var)
1270  Namep var;
1271 {
1272         Extsym *e;
1273         int type, type1;
1274         extern void changedtype();
1275
1276         type = var->vtype;
1277         e = &extsymtab[var->vardesc.varno];
1278         if ((type1 = e->extype) && type == TYUNKNOWN)
1279                 return var->vtype = type1;
1280         if (var->visused) {
1281                 if (e->exused && type != type1)
1282                         changedtype(var);
1283                 e->exused = 1;
1284                 e->extype = type;
1285                 }
1286         return type;
1287         }
1288
1289 list_decls (outfile)
1290 FILE *outfile;
1291 {
1292     extern chainp used_builtins;
1293     extern struct Hashentry *hashtab;
1294     extern ftnint wr_char_len();
1295     struct Hashentry *entry;
1296     int write_header = 1;
1297     int last_class = -1, last_stg = -1;
1298     Namep var;
1299     int Alias, Define, did_one, last_type, type;
1300     extern int def_equivs, useauto;
1301     extern chainp new_vars;     /* Compiler-generated locals */
1302     chainp namelists = 0;
1303     char *ctype;
1304     long lineno_save = lineno;
1305     int useauto1 = useauto && !saveall;
1306     long x;
1307     extern int hsize;
1308
1309     lineno = old_lineno;
1310
1311 /* First write out the statically initialized data */
1312
1313     if (initfile)
1314         list_init_data(&initfile, initfname, outfile);
1315
1316 /* Next come formats */
1317     write_formats(outfile);
1318
1319 /* Now write out the system-generated identifiers */
1320
1321     if (new_vars || nequiv) {
1322         chainp args, next_var, this_var;
1323         chainp nv[TYVOID], nv1[TYVOID];
1324         int i, j;
1325         Addrp Var;
1326         Namep arg;
1327
1328         /* zap unused dimension variables */
1329
1330         for(args = allargs; args; args = args->nextp) {
1331                 arg = (Namep)args->datap;
1332                 if (this_var = arg->vlastdim) {
1333                         frexpr((tagptr)this_var->datap);
1334                         this_var->datap = 0;
1335                         }
1336                 }
1337
1338         /* sort new_vars by type, skipping entries just zapped */
1339
1340         for(i = TYADDR; i < TYVOID; i++)
1341                 nv[i] = 0;
1342         for(this_var = new_vars; this_var; this_var = next_var) {
1343                 next_var = this_var->nextp;
1344                 if (Var = (Addrp)this_var->datap) {
1345                         if (!(this_var->nextp = nv[j = Var->vtype]))
1346                                 nv1[j] = this_var;
1347                         nv[j] = this_var;
1348                         }
1349                 else {
1350                         this_var->nextp = 0;
1351                         frchain(&this_var);
1352                         }
1353                 }
1354         new_vars = 0;
1355         for(i = TYVOID; --i >= TYADDR;)
1356                 if (this_var = nv[i]) {
1357                         nv1[i]->nextp = new_vars;
1358                         new_vars = this_var;
1359                         }
1360
1361         /* write the declarations */
1362
1363         did_one = 0;
1364         last_type = -1;
1365
1366         for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
1367             Var = (Addrp) this_var->datap;
1368
1369             if (Var == (Addrp) NULL)
1370                 err ("list_decls:  null variable");
1371             else if (Var -> tag != TADDR)
1372                 erri ("list_decls:  bad tag on new variable '%d'",
1373                         Var -> tag);
1374
1375             type = nv_type (Var);
1376             if (Var->vstg == STGINIT
1377             ||  Var->uname_tag == UNAM_IDENT
1378                         && *Var->user.ident == ' '
1379                         && multitype)
1380                 continue;
1381             if (!did_one)
1382                 nice_printf (outfile, "/* System generated locals */\n");
1383
1384             if (last_type == type && did_one)
1385                 nice_printf (outfile, ", ");
1386             else {
1387                 if (did_one)
1388                     nice_printf (outfile, ";\n");
1389                 nice_printf (outfile, "%s ",
1390                         c_type_decl (type, Var -> vclass == CLPROC));
1391             } /* else */
1392
1393 /* Character type is really a string type.  Put out a '*' for parameters
1394    with unknown length and functions returning character */
1395
1396             if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
1397                     || Var -> vclass == CLPROC))
1398                 nice_printf (outfile, "*");
1399
1400             write_nv_ident(outfile, (Addrp)this_var->datap);
1401             if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
1402                     ISICON((Var -> vleng))
1403                         && (i = Var->vleng->constblock.Const.ci) > 0)
1404                 nice_printf (outfile, "[%d]", i);
1405
1406             did_one = 1;
1407             last_type = nv_type (Var);
1408         } /* for this_var */
1409
1410 /* Handle the uninitialized equivalences */
1411
1412         do_uninit_equivs (outfile, &did_one);
1413
1414         if (did_one)
1415             nice_printf (outfile, ";\n\n");
1416     } /* if new_vars */
1417
1418 /* Write out builtin declarations */
1419
1420     if (used_builtins) {
1421         chainp cp;
1422         Extsym *es;
1423
1424         last_type = -1;
1425         did_one = 0;
1426
1427         nice_printf (outfile, "/* Builtin functions */");
1428
1429         for (cp = used_builtins; cp; cp = cp -> nextp) {
1430             Addrp e = (Addrp)cp->datap;
1431
1432             switch(type = e->vtype) {
1433                 case TYDREAL:
1434                 case TYREAL:
1435                         /* if (forcedouble || e->dbl_builtin) */
1436                         /* libF77 currently assumes everything double */
1437                         type = TYDREAL;
1438                         ctype = "double";
1439                         break;
1440                 case TYCOMPLEX:
1441                 case TYDCOMPLEX:
1442                         type = TYVOID;
1443                         /* no break */
1444                 default:
1445                         ctype = c_type_decl(type, 0);
1446                 }
1447
1448             if (did_one && last_type == type)
1449                 nice_printf(outfile, ", ");
1450             else
1451                 nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
1452
1453             extern_out(outfile, es = &extsymtab[e -> memno]);
1454             proto(outfile, es->arginfo, es->fextname);
1455             last_type = type;
1456             did_one = 1;
1457         } /* for cp = used_builtins */
1458
1459         nice_printf (outfile, ";\n\n");
1460     } /* if used_builtins */
1461
1462     last_type = -1;
1463     for (entry = hashtab; entry < lasthash; ++entry) {
1464         var = entry -> varp;
1465
1466         if (var) {
1467             int procclass = var -> vprocclass;
1468             char *comment = NULL;
1469             int stg = var -> vstg;
1470             int class = var -> vclass;
1471             type = var -> vtype;
1472
1473             if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
1474                 continue;
1475
1476             if (useauto1 && stg == STGBSS && !var->vsave)
1477                 stg = STGAUTO;
1478
1479             switch (class) {
1480                 case CLVAR:
1481                     break;
1482                 case CLPROC:
1483                     switch(procclass) {
1484                         case PTHISPROC:
1485                                 extsymtab[var->vardesc.varno].extype = type;
1486                                 continue;
1487                         case PSTFUNCT:
1488                         case PINTRINSIC:
1489                                 continue;
1490                         case PUNKNOWN:
1491                                 err ("list_decls:  unknown procedure class");
1492                                 continue;
1493                         case PEXTERNAL:
1494                                 if (stg == STGUNKNOWN) {
1495                                         warn1(
1496                                         "%.64s declared EXTERNAL but never used.",
1497                                                 var->fvarname);
1498                                         /* to retain names declared EXTERNAL */
1499                                         /* but not referenced, change
1500                                         /* "continue" to "stg = STGEXT" */
1501                                         continue;
1502                                         }
1503                                 else
1504                                         type = fixexttype(var);
1505                         }
1506                     break;
1507                 case CLUNKNOWN:
1508                         /* declared but never used */
1509                         continue;
1510                 case CLPARAM:
1511                         continue;
1512                 case CLNAMELIST:
1513                         if (var->visused)
1514                                 namelists = mkchain((char *)var, namelists);
1515                         continue;
1516                 default:
1517                     erri("list_decls:  can't handle class '%d' yet",
1518                             class);
1519                     Fatal(var->fvarname);
1520                     continue;
1521             } /* switch */
1522
1523             /* Might be equivalenced to a common.  If not, don't process */
1524             if (stg == STGCOMMON && !var->vcommequiv)
1525                 continue;
1526
1527 /* Only write the header if system-generated locals, builtins, or
1528    uninitialized equivs were already output */
1529
1530             if (write_header == 1 && (new_vars || nequiv || used_builtins)
1531                     && oneof_stg ( var, stg,
1532                     M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
1533                 nice_printf (outfile, "/* Local variables */\n");
1534                 write_header = 2;
1535                 }
1536
1537
1538             Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
1539             if (Define = (Alias && def_equivs)) {
1540                 if (!write_header)
1541                         nice_printf(outfile, ";\n");
1542                 def_start(outfile, var->cvarname, CNULL, "(");
1543                 goto Alias1;
1544                 }
1545             else if (type == last_type && class == last_class &&
1546                     stg == last_stg && !write_header)
1547                 nice_printf (outfile, ", ");
1548             else {
1549                 if (!write_header && ONEOF(stg, M(STGBSS)|
1550                     M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
1551                     nice_printf (outfile, ";\n");
1552
1553                 switch (stg) {
1554                     case STGARG:
1555                     case STGLENG:
1556                         /* Part of the argument list, don't write them out
1557                            again */
1558                         continue;           /* Go back to top of the loop */
1559                     case STGBSS:
1560                     case STGEQUIV:
1561                     case STGCOMMON:
1562                         nice_printf (outfile, "static ");
1563                         break;
1564                     case STGEXT:
1565                         nice_printf (outfile, "extern ");
1566                         break;
1567                     case STGAUTO:
1568                         break;
1569                     case STGINIT:
1570                     case STGUNKNOWN:
1571                         /* Don't want to touch the initialized data, that will
1572                            be handled elsewhere.  Unknown data have
1573                            already been complained about, so skip them */
1574                         continue;
1575                     default:
1576                         erri("list_decls:  can't handle storage class %d",
1577                                 stg);
1578                         continue;
1579                 } /* switch */
1580
1581                 if (type == TYCHAR && halign && class != CLPROC
1582                 && ISICON(var->vleng)) {
1583                         nice_printf(outfile, "struct { %s fill; char val",
1584                                 halign);
1585                         x = wr_char_len(outfile, var->vdim,
1586                                 var->vleng->constblock.Const.ci, 1);
1587                         if (x %= hsize)
1588                                 nice_printf(outfile, "; char fill2[%ld]",
1589                                         hsize - x);
1590                         nice_printf(outfile, "; } %s_st;\n", var->cvarname);
1591                         def_start(outfile, var->cvarname, CNULL, var->cvarname);
1592                         ind_printf(0, outfile, "_st.val\n");
1593                         last_type = -1;
1594                         write_header = 2;
1595                         continue;
1596                         }
1597                 nice_printf(outfile, "%s ",
1598                         c_type_decl(type, class == CLPROC));
1599             } /* else */
1600
1601 /* Character type is really a string type.  Put out a '*' for variable
1602    length strings, and also for equivalences */
1603
1604             if (type == TYCHAR && class != CLPROC
1605                     && (!var->vleng || !ISICON (var -> vleng))
1606             || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
1607                 nice_printf (outfile, "*%s", var->cvarname);
1608             else {
1609                 nice_printf (outfile, "%s", var->cvarname);
1610                 if (class == CLPROC)
1611                         proto(outfile, var->arginfo, var->fvarname);
1612                 else if (type == TYCHAR && ISICON ((var -> vleng)))
1613                         wr_char_len(outfile, var->vdim,
1614                                 (int)var->vleng->constblock.Const.ci, 0);
1615                 else if (var -> vdim &&
1616                     !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
1617                         comment = wr_ardecls(outfile, var->vdim, 1L);
1618                 }
1619
1620             if (comment)
1621                 nice_printf (outfile, "%s", comment);
1622  Alias1:
1623             if (Alias) {
1624                 char *amp, *lp, *name, *rp;
1625                 char *equiv_name ();
1626                 ftnint voff = var -> voffset;
1627                 int et0, expr_type, k;
1628                 Extsym *E;
1629                 struct Equivblock *eb;
1630                 char buf[16];
1631
1632 /* We DON'T want to use oneof_stg here, because we need to distinguish
1633    between them */
1634
1635                 if (stg == STGEQUIV) {
1636                         name = equiv_name(k = var->vardesc.varno, CNULL);
1637                         eb = eqvclass + k;
1638                         if (eb->eqvinit) {
1639                                 amp = "&";
1640                                 et0 = TYERROR;
1641                                 }
1642                         else {
1643                                 amp = "";
1644                                 et0 = eb->eqvtype;
1645                                 }
1646                         expr_type = et0;
1647                     }
1648                 else {
1649                         E = &extsymtab[var->vardesc.varno];
1650                         sprintf(name = buf, "%s%d", E->cextname, E->curno);
1651                         expr_type = type;
1652                         et0 = -1;
1653                         amp = "&";
1654                 } /* else */
1655
1656                 if (!Define)
1657                         nice_printf (outfile, " = ");
1658                 if (voff) {
1659                         k = typesize[type];
1660                         switch((int)(voff % k)) {
1661                                 case 0:
1662                                         voff /= k;
1663                                         expr_type = type;
1664                                         break;
1665                                 case SZSHORT:
1666                                 case SZSHORT+SZLONG:
1667                                         expr_type = TYSHORT;
1668                                         voff /= SZSHORT;
1669                                         break;
1670                                 case SZLONG:
1671                                         expr_type = TYLONG;
1672                                         voff /= SZLONG;
1673                                         break;
1674                                 default:
1675                                         expr_type = TYCHAR;
1676                                 }
1677                         }
1678
1679                 if (expr_type == type) {
1680                         lp = rp = "";
1681                         if (et0 == -1 && !voff)
1682                                 goto cast;
1683                         }
1684                 else {
1685                         lp = "(";
1686                         rp = ")";
1687  cast:
1688                         nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
1689                         }
1690
1691 /* Now worry about computing the offset */
1692
1693                 if (voff) {
1694                     if (expr_type == et0)
1695                         nice_printf (outfile, "%s%s + %ld%s",
1696                                 lp, name, voff, rp);
1697                     else
1698                         nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
1699                                 c_type_decl (expr_type, 0), amp,
1700                                 name, voff, rp);
1701                 } else
1702                     nice_printf(outfile, "%s%s", amp, name);
1703 /* Always put these at the end of the line */
1704                 last_type = last_class = last_stg = -1;
1705                 write_header = 0;
1706                 if (Define) {
1707                         ind_printf(0, outfile, ")\n");
1708                         write_header = 2;
1709                         }
1710                 continue;
1711                 }
1712             write_header = 0;
1713             last_type = type;
1714             last_class = class;
1715             last_stg = stg;
1716         } /* if (var) */
1717     } /* for (entry = hashtab */
1718
1719     if (!write_header)
1720         nice_printf (outfile, ";\n\n");
1721     else if (write_header == 2)
1722         nice_printf(outfile, "\n");
1723
1724 /* Next, namelists, which may reference equivs */
1725
1726     if (namelists) {
1727         write_namelists(namelists = revchain(namelists), outfile);
1728         frchain(&namelists);
1729         }
1730
1731 /* Finally, ioblocks (which may reference equivs and namelists) */
1732     if (iob_list)
1733         write_ioblocks(outfile);
1734     if (assigned_fmts)
1735         write_assigned_fmts(outfile);
1736     lineno = lineno_save;
1737 } /* list_decls */
1738
1739 do_uninit_equivs (outfile, did_one)
1740 FILE *outfile;
1741 int *did_one;
1742 {
1743     extern int nequiv;
1744     struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
1745     int k, last_type = -1, t;
1746
1747     for (eqv = eqvclass; eqv < lasteqv; eqv++)
1748         if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
1749             if (!*did_one)
1750                 nice_printf (outfile, "/* System generated locals */\n");
1751             t = eqv->eqvtype;
1752             if (last_type == t)
1753                 nice_printf (outfile, ", ");
1754             else {
1755                 if (*did_one)
1756                     nice_printf (outfile, ";\n");
1757                 nice_printf (outfile, "static %s ", c_type_decl(t, 0));
1758                 k = typesize[t];
1759             } /* else */
1760             nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
1761             nice_printf(outfile, "[%ld]",
1762                 (eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
1763             last_type = t;
1764             *did_one = 1;
1765         } /* if !eqv -> eqvinit */
1766 } /* do_uninit_equivs */
1767
1768
1769 /* wr_ardecls -- Writes the brackets and size for an array
1770    declaration.  Because of the inner workings of the compiler,
1771    multi-dimensional arrays get mapped directly into a one-dimensional
1772    array, so we have to compute the size of the array here.  When the
1773    dimension is greater than 1, a string comment about the original size
1774    is returned */
1775
1776 char *wr_ardecls(outfile, dimp, size)
1777 FILE *outfile;
1778 struct Dimblock *dimp;
1779 long size;
1780 {
1781     int i, k;
1782     static char buf[1000];
1783
1784     if (dimp == (struct Dimblock *) NULL)
1785         return NULL;
1786
1787     sprintf(buf, "\t/* was ");  /* would like to say  k = sprintf(...), but */
1788     k = strlen(buf);            /* BSD doesn't return char transmitted count */
1789
1790     for (i = 0; i < dimp -> ndim; i++) {
1791         expptr this_size = dimp -> dims[i].dimsize;
1792
1793         if (!ISICON (this_size))
1794             err ("wr_ardecls:  nonconstant array size");
1795         else {
1796             size *= this_size -> constblock.Const.ci;
1797             sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci);
1798             k += strlen(buf+k); /* BSD prevents combining this with prev stmt */
1799         } /* else */
1800     } /* for i = 0 */
1801
1802     nice_printf (outfile, "[%ld]", size);
1803     strcat(buf+k, " */");
1804
1805     return (i > 1) ? buf : NULL;
1806 } /* wr_ardecls */
1807
1808
1809
1810 /* ----------------------------------------------------------------------
1811
1812         The following routines read from the p1 intermediate file.  If
1813    that format changes, only these routines need be changed
1814
1815    ---------------------------------------------------------------------- */
1816
1817 static int get_p1_token (infile)
1818 FILE *infile;
1819 {
1820     int token = P1_UNKNOWN;
1821
1822 /* NOT PORTABLE!! */
1823
1824     if (fscanf (infile, "%d", &token) == EOF)
1825         return P1_EOF;
1826
1827 /* Skip over the ": " */
1828
1829     if (getc (infile) != '\n')
1830         getc (infile);
1831
1832     return token;
1833 } /* get_p1_token */
1834
1835
1836
1837 /* Returns a (null terminated) string from the input file */
1838
1839 static int p1gets (fp, str, size)
1840 FILE *fp;
1841 char *str;
1842 int size;
1843 {
1844     char *fgets ();
1845     char c;
1846
1847     if (str == NULL)
1848         return 0;
1849
1850     if ((c = getc (fp)) != ' ')
1851         ungetc (c, fp);
1852
1853     if (fgets (str, size, fp)) {
1854         int length;
1855
1856         str[size - 1] = '\0';
1857         length = strlen (str);
1858
1859 /* Get rid of the newline */
1860
1861         if (str[length - 1] == '\n')
1862             str[length - 1] = '\0';
1863         return 1;
1864
1865     } else if (feof (fp))
1866         return EOF;
1867     else
1868         return 0;
1869 } /* p1gets */
1870
1871
1872 static int p1get_const (infile, type, resultp)
1873 FILE *infile;
1874 int type;
1875 struct Constblock **resultp;
1876 {
1877     int status;
1878     struct Constblock *result;
1879
1880         if (type != TYCHAR) {
1881                 *resultp = result = ALLOC(Constblock);
1882                 result -> tag = TCONST;
1883                 result -> vtype = type;
1884                 }
1885
1886     switch (type) {
1887         case TYSHORT:
1888         case TYLONG:
1889         case TYLOGICAL:
1890             status = p1getd (infile, &(result -> Const.ci));
1891             break;
1892         case TYREAL:
1893         case TYDREAL:
1894             status = p1getf(infile, &result->Const.cds[0]);
1895             result->vstg = 1;
1896             break;
1897         case TYCOMPLEX:
1898         case TYDCOMPLEX:
1899             status = p1getf(infile, &result->Const.cds[0]);
1900             if (status && status != EOF)
1901                 status = p1getf(infile, &result->Const.cds[1]);
1902             result->vstg = 1;
1903             break;
1904         case TYCHAR:
1905             status = fscanf(infile, "%lx", resultp);
1906             break;
1907         default:
1908             erri ("p1get_const:  bad constant type '%d'", type);
1909             status = 0;
1910             break;
1911     } /* switch */
1912
1913     return status;
1914 } /* p1get_const */
1915
1916 static int p1getd (infile, result)
1917 FILE *infile;
1918 long *result;
1919 {
1920     return fscanf (infile, "%ld", result);
1921 } /* p1getd */
1922
1923  static int
1924 p1getf(infile, result)
1925  FILE *infile;
1926  char **result;
1927 {
1928
1929         char buf[1324];
1930         register int k;
1931
1932         k = fscanf (infile, "%s", buf);
1933         if (k < 1)
1934                 k = EOF;
1935         else
1936                 strcpy(*result = mem(strlen(buf)+1,0), buf);
1937         return k;
1938 }
1939
1940 static int p1getn (infile, count, result)
1941 FILE *infile;
1942 int count;
1943 char **result;
1944 {
1945
1946     char *bufptr;
1947     extern ptr ckalloc ();
1948
1949     bufptr = (char *) ckalloc (count);
1950
1951     if (result)
1952         *result = bufptr;
1953
1954     for (; !feof (infile) && count > 0; count--)
1955         *bufptr++ = getc (infile);
1956
1957     return feof (infile) ? EOF : 1;
1958 } /* p1getn */
1959
1960  static void
1961 proto(outfile, at, fname)
1962  FILE *outfile;
1963  Argtypes *at;
1964  char *fname;
1965 {
1966         int i, j, k, n;
1967         char *comma;
1968         Atype *atypes;
1969         Namep np;
1970         chainp cp;
1971         extern void bad_atypes();
1972
1973         if (at) {
1974                 /* Correct types that we learn on the fly, e.g.
1975                         subroutine gotcha(foo)
1976                         external foo
1977                         call zap(...,foo,...)
1978                         call foo(...)
1979                 */
1980                 atypes = at->atypes;
1981                 n = at->nargs;
1982                 for(i = 0; i++ < n; atypes++) {
1983                         if (!(cp = atypes->cp))
1984                                 continue;
1985                         j = atypes->type;
1986                         do {
1987                                 np = (Namep)cp->datap;
1988                                 k = np->vtype;
1989                                 if (np->vclass == CLPROC) {
1990                                         if (!np->vimpltype && k)
1991                                                 k += 200;
1992                                         else {
1993                                                 if (j >= 300)
1994                                                         j = TYUNKNOWN + 200;
1995                                                 continue;
1996                                                 }
1997                                         }
1998                                 if (j == k)
1999                                         continue;
2000                                 if (j >= 300
2001                                 ||  j == 200 && k >= 200)
2002                                         j = k;
2003                                 else {
2004                                         bad_atypes(at,fname,i,j,k,""," and");
2005                                         goto break2;
2006                                         }
2007                                 }
2008                                 while(cp = cp->nextp);
2009                         atypes->type = j;
2010                         frchain(&atypes->cp);
2011                         }
2012                 }
2013  break2:
2014         if (parens) {
2015                 nice_printf(outfile, parens);
2016                 return;
2017                 }
2018
2019         if (!at || (n = at->nargs) < 0) {
2020                 nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
2021                 return;
2022                 }
2023
2024         if (n == 0) {
2025                 nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
2026                 return;
2027                 }
2028
2029         atypes = at->atypes;
2030         nice_printf(outfile, "(");
2031         comma = "";
2032         for(; --n >= 0; atypes++) {
2033                 k = atypes->type;
2034                 if (k == TYADDR)
2035                         nice_printf(outfile, "%schar **", comma);
2036                 else if (k >= 200) {
2037                         k -= 200;
2038                         nice_printf(outfile, "%s%s", comma,
2039                                 usedcasts[k] = casttypes[k]);
2040                         }
2041                 else if (k >= 100)
2042                         nice_printf(outfile,
2043                                         k == TYCHAR + 100 ? "%s%s *" : "%s%s",
2044                                         comma, c_type_decl(k-100, 0));
2045                 else
2046                         nice_printf(outfile, "%s%s *", comma,
2047                                         c_type_decl(k, 0));
2048                 comma = ", ";
2049                 }
2050         nice_printf(outfile, ")");
2051         }
2052
2053  void
2054 protowrite(protofile, type, name, e, lengths)
2055  FILE *protofile;
2056  char *name;
2057  struct Entrypoint *e;
2058  chainp lengths;
2059 {
2060         extern char used_rets[];
2061
2062         nice_printf(protofile, "extern %s %s", protorettypes[type], name);
2063         list_arg_types(protofile, e, lengths, 0, ";\n");
2064         used_rets[type] = 1;
2065         }
2066
2067  static void
2068 do_p1_1while(outfile)
2069  FILE *outfile;
2070 {
2071         if (*wh_next) {
2072                 nice_printf(outfile,
2073                         "for(;;) { /* while(complicated condition) */\n" /*}*/ );
2074                 next_tab(outfile);
2075                 }
2076         else
2077                 nice_printf(outfile, "while(" /*)*/ );
2078         }
2079
2080  static void
2081 do_p1_2while(infile, outfile)
2082  FILE *infile, *outfile;
2083 {
2084         expptr test;
2085
2086         test = do_format(infile, outfile);
2087         if (*wh_next)
2088                 nice_printf(outfile, "if (!(");
2089         expr_out(outfile, test);
2090         if (*wh_next++)
2091                 nice_printf(outfile, "))\n\tbreak;\n");
2092         else {
2093                 nice_printf(outfile, /*(*/ ") {\n");
2094                 next_tab(outfile);
2095                 }
2096         }
2097
2098  static void
2099 do_p1_elseifstart(outfile)
2100  FILE *outfile;
2101 {
2102         if (*ei_next++) {
2103                 prev_tab(outfile);
2104                 nice_printf(outfile, /*{*/
2105                         "} else /* if(complicated condition) */ {\n" /*}*/ );
2106                 next_tab(outfile);
2107                 }
2108         }