sources/f2c/format.c

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