Move dstool_oss to ydb/apps/dstool.

1 files changed, 2613 insertions, 0 deletions

diff --git a/contrib/tools/f2c/src/format.c b/contrib/tools/f2c/src/format.c
new file mode 100644
index 0000000000..96f2acf995
--- /dev/null
+++ b/contrib/tools/f2c/src/format.c
@@ -0,0 +1,2613 @@
+/****************************************************************
+Copyright 1990-1996, 1999-2001 by AT&T, Lucent Technologies and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T, Bell Laboratories,
+Lucent or Bellcore or any of their entities not be used in
+advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+AT&T, Lucent and Bellcore disclaim all warranties with regard to
+this software, including all implied warranties of
+merchantability and fitness.  In no event shall AT&T, Lucent or
+Bellcore be liable for any special, indirect or consequential
+damages or any damages whatsoever resulting from loss of use,
+data or profits, whether in an action of contract, negligence or
+other tortious action, arising out of or in connection with the
+use or performance of this software.
+****************************************************************/
+
+/* Format.c -- this file takes an intermediate file (generated by pass 1
+   of the translator) and some state information about the contents of that
+   file, and generates C program text. */
+
+#include "defs.h"
+#include "p1defs.h"
+#include "format.h"
+#include "output.h"
+#include "names.h"
+#include "iob.h"
+
+int c_output_line_length = DEF_C_LINE_LENGTH;
+
+int last_was_label;	/* Boolean used to generate semicolons
+				   when a label terminates a block */
+static char this_proc_name[52];	/* Name of the current procedure.  This is
+				   probably too simplistic to handle
+				   multiple entry points */
+
+static tagptr do_format Argdcl((FILEP, FILEP));
+static void do_p1_1while Argdcl((FILEP));
+static void do_p1_2while Argdcl((FILEP, FILEP));
+static tagptr do_p1_addr Argdcl((FILEP, FILEP));
+static void do_p1_asgoto Argdcl((FILEP, FILEP));
+static tagptr do_p1_charp Argdcl((FILEP));
+static void do_p1_comment Argdcl((FILEP, FILEP));
+static void do_p1_comp_goto Argdcl((FILEP, FILEP));
+static tagptr do_p1_const Argdcl((FILEP));
+static void do_p1_elif Argdcl((FILEP, FILEP));
+static void do_p1_else Argdcl((FILEP));
+static void do_p1_elseifstart Argdcl((FILEP));
+static void do_p1_end_for Argdcl((FILEP));
+static void do_p1_endelse Argdcl((FILEP));
+static void do_p1_endif Argdcl((FILEP));
+static tagptr do_p1_expr Argdcl((FILEP, FILEP));
+static tagptr do_p1_extern Argdcl((FILEP));
+static void do_p1_for Argdcl((FILEP, FILEP));
+static void do_p1_fortran Argdcl((FILEP, FILEP));
+static void do_p1_goto Argdcl((FILEP, FILEP));
+static tagptr do_p1_head Argdcl((FILEP, FILEP));
+static tagptr do_p1_ident Argdcl((FILEP));
+static void do_p1_if Argdcl((FILEP, FILEP));
+static void do_p1_label Argdcl((FILEP, FILEP));
+static tagptr do_p1_list Argdcl((FILEP, FILEP));
+static tagptr do_p1_literal Argdcl((FILEP));
+static tagptr do_p1_name_pointer Argdcl((FILEP));
+static void do_p1_set_line Argdcl((FILEP));
+static void do_p1_subr_ret Argdcl((FILEP, FILEP));
+static int get_p1_token Argdcl((FILEP));
+static int p1get_const Argdcl((FILEP, int, Constp*));
+static int p1getd Argdcl((FILEP, long int*));
+static int p1getf Argdcl((FILEP, char**));
+static int p1getn Argdcl((FILEP, int, char**));
+static int p1gets Argdcl((FILEP, char*, int));
+static void proto Argdcl((FILEP, Argtypes*, char*));
+
+extern chainp assigned_fmts;
+char filename[P1_FILENAME_MAX];
+extern int gflag, sharp_line, trapuv;
+extern int typeconv[];
+int gflag1;
+extern char *parens;
+
+ void
+start_formatting(Void)
+{
+    FILE *infile;
+    static int wrote_one = 0;
+    extern int usedefsforcommon;
+    extern char *p1_file, *p1_bakfile;
+
+    this_proc_name[0] = '\0';
+    last_was_label = 0;
+    ei_next = ei_first;
+    wh_next = wh_first;
+
+    (void) fclose (pass1_file);
+    if ((infile = fopen (p1_file, binread)) == NULL)
+	Fatal("start_formatting:  couldn't open the intermediate file\n");
+
+    if (wrote_one)
+	nice_printf (c_file, "\n");
+
+    while (!feof (infile)) {
+	expptr this_expr;
+
+	this_expr = do_format (infile, c_file);
+	if (this_expr) {
+	    out_and_free_statement (c_file, this_expr);
+	} /* if this_expr */
+    } /* while !feof infile */
+
+    (void) fclose (infile);
+
+    if (last_was_label)
+	nice_printf (c_file, ";\n");
+
+    prev_tab (c_file);
+    gflag1 = sharp_line = 0;
+    if (this_proc_name[0])
+	nice_printf (c_file, "} /* %s */\n", this_proc_name);
+
+
+/* Write the #undefs for common variable reference */
+
+    if (usedefsforcommon) {
+	Extsym *ext;
+	int did_one = 0;
+
+	for (ext = extsymtab; ext < nextext; ext++)
+	    if (ext -> extstg == STGCOMMON && ext -> used_here) {
+		ext -> used_here = 0;
+		if (!did_one)
+		    nice_printf (c_file, "\n");
+		wr_abbrevs(c_file, 0, ext->extp);
+		did_one = 1;
+		ext -> extp = CHNULL;
+	    } /* if */
+
+	if (did_one)
+	    nice_printf (c_file, "\n");
+    } /* if usedefsforcommon */
+
+    other_undefs(c_file);
+
+    wrote_one = 1;
+
+/* For debugging only */
+
+    if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
+	if (infile = fopen (p1_file, binread)) {
+	    ffilecopy (infile, pass1_file);
+	    fclose (infile);
+	    fclose (pass1_file);
+	} /* if infile */
+
+/* End of "debugging only" */
+
+    scrub(p1_file);	/* optionally unlink */
+
+    if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
+	err ("start_formatting:  couldn't reopen the pass1 file");
+
+} /* start_formatting */
+
+
+ static void
+#ifdef KR_headers
+put_semi(outfile)
+	FILE *outfile;
+#else
+put_semi(FILE *outfile)
+#endif
+{
+	nice_printf (outfile, ";\n");
+	last_was_label = 0;
+	}
+
+#define SEM_CHECK(x) if (last_was_label) put_semi(x)
+
+/* do_format -- takes an input stream (a file in pass1 format) and writes
+   the appropriate C code to   outfile   when possible.  When reading an
+   expression, the expression tree is returned instead. */
+
+ static expptr
+#ifdef KR_headers
+do_format(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_format(FILE *infile, FILE *outfile)
+#endif
+{
+    int token_type, was_c_token;
+    expptr retval = ENULL;
+
+    token_type = get_p1_token (infile);
+    was_c_token = 1;
+    switch (token_type) {
+	case P1_COMMENT:
+	    do_p1_comment (infile, outfile);
+	    was_c_token = 0;
+	    break;
+	case P1_SET_LINE:
+	    do_p1_set_line (infile);
+	    was_c_token = 0;
+	    break;
+	case P1_FILENAME:
+	    p1gets(infile, filename, P1_FILENAME_MAX);
+	    was_c_token = 0;
+	    break;
+	case P1_NAME_POINTER:
+	    retval = do_p1_name_pointer (infile);
+	    break;
+	case P1_CONST:
+	    retval = do_p1_const (infile);
+	    break;
+	case P1_EXPR:
+	    retval = do_p1_expr (infile, outfile);
+	    break;
+	case P1_IDENT:
+	    retval = do_p1_ident(infile);
+	    break;
+	case P1_CHARP:
+		retval = do_p1_charp(infile);
+		break;
+	case P1_EXTERN:
+	    retval = do_p1_extern (infile);
+	    break;
+	case P1_HEAD:
+	    gflag1 = sharp_line = 0;
+	    retval = do_p1_head (infile, outfile);
+	    gflag1 = sharp_line = gflag;
+	    break;
+	case P1_LIST:
+	    retval = do_p1_list (infile, outfile);
+	    break;
+	case P1_LITERAL:
+	    retval = do_p1_literal (infile);
+	    break;
+	case P1_LABEL:
+	    do_p1_label (infile, outfile);
+	    /* last_was_label = 1; -- now set in do_p1_label */
+	    was_c_token = 0;
+	    break;
+	case P1_ASGOTO:
+	    do_p1_asgoto (infile, outfile);
+	    break;
+	case P1_GOTO:
+	    do_p1_goto (infile, outfile);
+	    break;
+	case P1_IF:
+	    do_p1_if (infile, outfile);
+	    break;
+	case P1_ELSE:
+	    SEM_CHECK(outfile);
+	    do_p1_else (outfile);
+	    break;
+	case P1_ELIF:
+	    SEM_CHECK(outfile);
+	    do_p1_elif (infile, outfile);
+	    break;
+	case P1_ENDIF:
+	    SEM_CHECK(outfile);
+	    do_p1_endif (outfile);
+	    break;
+	case P1_ENDELSE:
+	    SEM_CHECK(outfile);
+	    do_p1_endelse (outfile);
+	    break;
+	case P1_ADDR:
+	    retval = do_p1_addr (infile, outfile);
+	    break;
+	case P1_SUBR_RET:
+	    do_p1_subr_ret (infile, outfile);
+	    break;
+	case P1_COMP_GOTO:
+	    do_p1_comp_goto (infile, outfile);
+	    break;
+	case P1_FOR:
+	    do_p1_for (infile, outfile);
+	    break;
+	case P1_ENDFOR:
+	    SEM_CHECK(outfile);
+	    do_p1_end_for (outfile);
+	    break;
+	case P1_WHILE1START:
+		do_p1_1while(outfile);
+		break;
+	case P1_WHILE2START:
+		do_p1_2while(infile, outfile);
+		break;
+	case P1_PROCODE:
+		procode(outfile);
+		break;
+	case P1_ELSEIFSTART:
+		SEM_CHECK(outfile);
+		do_p1_elseifstart(outfile);
+		break;
+	case P1_FORTRAN:
+		do_p1_fortran(infile, outfile);
+		/* no break; */
+	case P1_EOF:
+	    was_c_token = 0;
+	    break;
+	case P1_UNKNOWN:
+	    Fatal("do_format:  Unknown token type in intermediate file");
+	    break;
+	default:
+	    Fatal("do_format:  Bad token type in intermediate file");
+	    break;
+   } /* switch */
+
+    if (was_c_token)
+	last_was_label = 0;
+    return retval;
+} /* do_format */
+
+
+ static void
+#ifdef KR_headers
+do_p1_comment(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_comment(FILE *infile, FILE *outfile)
+#endif
+{
+    extern int in_comment;
+
+    char storage[COMMENT_BUFFER_SIZE + 1];
+    int length;
+
+    if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
+	return;
+
+    length = strlen (storage);
+
+    gflag1 = sharp_line = 0;
+    in_comment = 1;
+    margin_printf(outfile, length ? "/* %s */\n" : "\n", storage);
+    in_comment = 0;
+    gflag1 = sharp_line = gflag;
+} /* do_p1_comment */
+
+ static void
+#ifdef KR_headers
+do_p1_set_line(infile)
+	FILE *infile;
+#else
+do_p1_set_line(FILE *infile)
+#endif
+{
+    int status;
+    long new_line_number = -1;
+
+    status = p1getd (infile, &new_line_number);
+
+    if (status == EOF)
+	err ("do_p1_set_line:  Missing line number at end of file\n");
+    else if (status == 0 || new_line_number == -1)
+	errl("do_p1_set_line:  Illegal line number in intermediate file: %ld\n",
+		new_line_number);
+    else {
+	lineno = new_line_number;
+	}
+} /* do_p1_set_line */
+
+
+ static expptr
+#ifdef KR_headers
+do_p1_name_pointer(infile)
+	FILE *infile;
+#else
+do_p1_name_pointer(FILE *infile)
+#endif
+{
+    Namep namep = (Namep) NULL;
+    int status;
+
+    status = p1getd (infile, (long *) &namep);
+
+    if (status == EOF)
+	err ("do_p1_name_pointer:  Missing pointer at end of file\n");
+    else if (status == 0 || namep == (Namep) NULL)
+	erri ("do_p1_name_pointer:  Illegal name pointer in p1 file: '#%lx'\n",
+		(unsigned long) namep);
+
+    return (expptr) namep;
+} /* do_p1_name_pointer */
+
+
+
+ static expptr
+#ifdef KR_headers
+do_p1_const(infile)
+	FILE *infile;
+#else
+do_p1_const(FILE *infile)
+#endif
+{
+    struct Constblock *c = (struct Constblock *) NULL;
+    long type = -1;
+    int status;
+
+    status = p1getd (infile, &type);
+
+    if (status == EOF)
+	err ("do_p1_const:  Missing constant type at end of file\n");
+    else if (status == 0)
+	errl("do_p1_const:  Illegal constant type in p1 file: %ld\n", type);
+    else {
+	status = p1get_const (infile, (int)type, &c);
+
+	if (status == EOF) {
+	    err ("do_p1_const:  Missing constant value at end of file\n");
+	    c = (struct Constblock *) NULL;
+	} else if (status == 0) {
+	    err ("do_p1_const:  Illegal constant value in p1 file\n");
+	    c = (struct Constblock *) NULL;
+	} /* else */
+    } /* else */
+    return (expptr) c;
+} /* do_p1_const */
+
+ void
+#ifdef KR_headers
+addrlit(addrp)
+	Addrp addrp;
+#else
+addrlit(Addrp addrp)
+#endif
+{
+	long memno = addrp->memno;
+	struct Literal *litp, *lastlit;
+
+	lastlit = litpool + nliterals;
+	for (litp = litpool; litp < lastlit; litp++)
+	    if (litp->litnum == memno) {
+		addrp->vtype = litp->littype;
+		*((union Constant *) &(addrp->user)) =
+			*((union Constant *) &(litp->litval));
+		addrp->vstg = STGMEMNO;
+		return;
+		}
+	err("addrlit failure!");
+	}
+
+ static expptr
+#ifdef KR_headers
+do_p1_literal(infile)
+	FILE *infile;
+#else
+do_p1_literal(FILE *infile)
+#endif
+{
+    int status;
+    long memno;
+    Addrp addrp;
+
+    status = p1getd (infile, &memno);
+
+    if (status == EOF)
+	err ("do_p1_literal:  Missing memno at end of file");
+    else if (status == 0)
+	err ("do_p1_literal:  Missing memno in p1 file");
+    else {
+	addrp = ALLOC (Addrblock);
+	addrp -> tag = TADDR;
+	addrp -> vtype = TYUNKNOWN;
+	addrp -> Field = NULL;
+	addrp -> memno = memno;
+	addrlit(addrp);
+	addrp -> uname_tag = UNAM_CONST;
+    } /* else */
+
+    return (expptr) addrp;
+} /* do_p1_literal */
+
+
+ static void
+#ifdef KR_headers
+do_p1_label(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_label(FILE *infile, FILE *outfile)
+#endif
+{
+    int status;
+    ftnint stateno;
+    struct Labelblock *L;
+    char *fmt;
+
+    status = p1getd (infile, &stateno);
+
+    if (status == EOF)
+	err ("do_p1_label:  Missing label at end of file");
+    else if (status == 0)
+	err ("do_p1_label:  Missing label in p1 file ");
+    else if (stateno < 0) {	/* entry */
+	margin_printf(outfile, "\n%s:\n", user_label(stateno));
+	last_was_label = 1;
+	}
+    else {
+	L = labeltab + stateno;
+	if (L->labused) {
+		fmt = "%s:\n";
+		last_was_label = 1;
+		}
+	else
+		fmt = "/* %s: */\n";
+	margin_printf(outfile, fmt, user_label(L->stateno));
+    } /* else */
+} /* do_p1_label */
+
+
+
+ static void
+#ifdef KR_headers
+do_p1_asgoto(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_asgoto(FILE *infile, FILE *outfile)
+#endif
+{
+    expptr expr;
+
+    expr = do_format (infile, outfile);
+    out_asgoto (outfile, expr);
+
+} /* do_p1_asgoto */
+
+
+ static void
+#ifdef KR_headers
+do_p1_goto(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_goto(FILE *infile, FILE *outfile)
+#endif
+{
+    int status;
+    long stateno;
+
+    status = p1getd (infile, &stateno);
+
+    if (status == EOF)
+	err ("do_p1_goto:  Missing goto label at end of file");
+    else if (status == 0)
+	err ("do_p1_goto:  Missing goto label in p1 file");
+    else {
+	nice_printf (outfile, "goto %s;\n", user_label (stateno));
+    } /* else */
+} /* do_p1_goto */
+
+
+ static void
+#ifdef KR_headers
+do_p1_if(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_if(FILE *infile, FILE *outfile)
+#endif
+{
+    expptr cond;
+
+    do {
+        cond = do_format (infile, outfile);
+    } while (cond == ENULL);
+
+    out_if (outfile, cond);
+} /* do_p1_if */
+
+
+ static void
+#ifdef KR_headers
+do_p1_else(outfile)
+	FILE *outfile;
+#else
+do_p1_else(FILE *outfile)
+#endif
+{
+    out_else (outfile);
+} /* do_p1_else */
+
+
+ static void
+#ifdef KR_headers
+do_p1_elif(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_elif(FILE *infile, FILE *outfile)
+#endif
+{
+    expptr cond;
+
+    do {
+        cond = do_format (infile, outfile);
+    } while (cond == ENULL);
+
+    elif_out (outfile, cond);
+} /* do_p1_elif */
+
+ static void
+#ifdef KR_headers
+do_p1_endif(outfile)
+	FILE *outfile;
+#else
+do_p1_endif(FILE *outfile)
+#endif
+{
+    endif_out (outfile);
+} /* do_p1_endif */
+
+
+ static void
+#ifdef KR_headers
+do_p1_endelse(outfile)
+	FILE *outfile;
+#else
+do_p1_endelse(FILE *outfile)
+#endif
+{
+    end_else_out (outfile);
+} /* do_p1_endelse */
+
+
+ static expptr
+#ifdef KR_headers
+do_p1_addr(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_addr(FILE *infile, FILE *outfile)
+#endif
+{
+    Addrp addrp = (Addrp) NULL;
+    int status;
+
+    status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp);
+
+    if (status == EOF)
+	err ("do_p1_addr:  Missing Addrp at end of file");
+    else if (status == 0)
+	err ("do_p1_addr:  Missing Addrp in p1 file");
+    else if (addrp == (Addrp) NULL)
+	err ("do_p1_addr:  Null addrp in p1 file");
+    else if (addrp -> tag != TADDR)
+	erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
+    else {
+	addrp -> vleng = do_format (infile, outfile);
+	addrp -> memoffset = do_format (infile, outfile);
+    }
+
+    return (expptr) addrp;
+} /* do_p1_addr */
+
+
+
+ static void
+#ifdef KR_headers
+do_p1_subr_ret(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_subr_ret(FILE *infile, FILE *outfile)
+#endif
+{
+    expptr retval;
+
+    nice_printf (outfile, "return ");
+    retval = do_format (infile, outfile);
+    if (!multitype)
+	if (retval)
+		expr_out (outfile, retval);
+
+    nice_printf (outfile, ";\n");
+} /* do_p1_subr_ret */
+
+
+
+ static void
+#ifdef KR_headers
+do_p1_comp_goto(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_comp_goto(FILE *infile, FILE *outfile)
+#endif
+{
+    expptr index;
+    expptr labels;
+
+    index = do_format (infile, outfile);
+
+    if (index == ENULL) {
+	err ("do_p1_comp_goto:  no expression for computed goto");
+	return;
+    } /* if index == ENULL */
+
+    labels = do_format (infile, outfile);
+
+    if (labels && labels -> tag != TLIST)
+	erri ("do_p1_comp_goto:  expected list, got tag '%d'", labels -> tag);
+    else
+	compgoto_out (outfile, index, labels);
+} /* do_p1_comp_goto */
+
+
+ static void
+#ifdef KR_headers
+do_p1_for(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_for(FILE *infile, FILE *outfile)
+#endif
+{
+    expptr init, test, inc;
+
+    init = do_format (infile, outfile);
+    test = do_format (infile, outfile);
+    inc = do_format (infile, outfile);
+
+    out_for (outfile, init, test, inc);
+} /* do_p1_for */
+
+ static void
+#ifdef KR_headers
+do_p1_end_for(outfile)
+	FILE *outfile;
+#else
+do_p1_end_for(FILE *outfile)
+#endif
+{
+    out_end_for (outfile);
+} /* do_p1_end_for */
+
+
+ static void
+#ifdef KR_headers
+do_p1_fortran(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_fortran(FILE *infile, FILE *outfile)
+#endif
+{
+	char buf[P1_STMTBUFSIZE];
+	if (!p1gets(infile, buf, P1_STMTBUFSIZE))
+		return;
+	/* bypass nice_printf nonsense */
+	fprintf(outfile, "/*< %s >*/\n", buf+1);	/* + 1 to skip by '$' */
+	}
+
+
+ static expptr
+#ifdef KR_headers
+do_p1_expr(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_expr(FILE *infile, FILE *outfile)
+#endif
+{
+    int status;
+    long opcode, type;
+    struct Exprblock *result = (struct Exprblock *) NULL;
+
+    status = p1getd (infile, &opcode);
+
+    if (status == EOF)
+	err ("do_p1_expr:  Missing expr opcode at end of file");
+    else if (status == 0)
+	err ("do_p1_expr:  Missing expr opcode in p1 file");
+    else {
+
+	status = p1getd (infile, &type);
+
+	if (status == EOF)
+	    err ("do_p1_expr:  Missing expr type at end of file");
+	else if (status == 0)
+	    err ("do_p1_expr:  Missing expr type in p1 file");
+	else if (opcode == 0)
+	    return ENULL;
+	else {
+	    result = ALLOC (Exprblock);
+
+	    result -> tag = TEXPR;
+	    result -> vtype = (field)type;
+	    result -> opcode = (unsigned int)opcode;
+	    result -> vleng = do_format (infile, outfile);
+
+	    if (is_unary_op (opcode))
+		result -> leftp = do_format (infile, outfile);
+	    else if (is_binary_op (opcode)) {
+		result -> leftp = do_format (infile, outfile);
+		result -> rightp = do_format (infile, outfile);
+	    } else
+		errl("do_p1_expr:  Illegal opcode %ld", opcode);
+	} /* else */
+    } /* else */
+
+    return (expptr) result;
+} /* do_p1_expr */
+
+
+ static expptr
+#ifdef KR_headers
+do_p1_ident(infile)
+	FILE *infile;
+#else
+do_p1_ident(FILE *infile)
+#endif
+{
+	Addrp addrp;
+	int status;
+	long vtype, vstg;
+
+	addrp = ALLOC (Addrblock);
+	addrp -> tag = TADDR;
+
+	status = p1getd (infile, &vtype);
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing identifier type at end of file\n");
+	else if (status == 0 || vtype < 0 || vtype >= NTYPES)
+	    errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
+	else
+	    addrp -> vtype = (field)vtype;
+
+	status = p1getd (infile, &vstg);
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing identifier storage at end of file\n");
+	else if (status == 0 || vstg < 0 || vstg > STGNULL)
+	    errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
+	else
+	    addrp -> vstg = (field)vstg;
+
+	status = p1gets(infile, addrp->user.ident, IDENT_LEN);
+
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing ident string at end of file");
+	else if (status == 0)
+	    err ("do_p1_ident:  Missing ident string in intermediate file");
+	addrp->uname_tag = UNAM_IDENT;
+	return (expptr) addrp;
+} /* do_p1_ident */
+
+ static expptr
+#ifdef KR_headers
+do_p1_charp(infile)
+	FILE *infile;
+#else
+do_p1_charp(FILE *infile)
+#endif
+{
+	Addrp addrp;
+	int status;
+	long vtype, vstg;
+	char buf[64];
+
+	addrp = ALLOC (Addrblock);
+	addrp -> tag = TADDR;
+
+	status = p1getd (infile, &vtype);
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing identifier type at end of file\n");
+	else if (status == 0 || vtype < 0 || vtype >= NTYPES)
+	    errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
+	else
+	    addrp -> vtype = (field)vtype;
+
+	status = p1getd (infile, &vstg);
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing identifier storage at end of file\n");
+	else if (status == 0 || vstg < 0 || vstg > STGNULL)
+	    errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
+	else
+	    addrp -> vstg = (field)vstg;
+
+	status = p1gets(infile, buf, (int)sizeof(buf));
+
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing charp ident string at end of file");
+	else if (status == 0)
+	    err ("do_p1_ident:  Missing charp ident string in intermediate file");
+	addrp->uname_tag = UNAM_CHARP;
+	addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
+	return (expptr) addrp;
+}
+
+
+ static expptr
+#ifdef KR_headers
+do_p1_extern(infile)
+	FILE *infile;
+#else
+do_p1_extern(FILE *infile)
+#endif
+{
+    Addrp addrp;
+
+    addrp = ALLOC (Addrblock);
+    if (addrp) {
+	int status;
+
+	addrp->tag = TADDR;
+	addrp->vstg = STGEXT;
+	addrp->uname_tag = UNAM_EXTERN;
+	status = p1getd (infile, &(addrp -> memno));
+	if (status == EOF)
+	    err ("do_p1_extern:  Missing memno at end of file");
+	else if (status == 0)
+	    err ("do_p1_extern:  Missing memno in intermediate file");
+	if (addrp->vtype = extsymtab[addrp->memno].extype)
+		addrp->vclass = CLPROC;
+    } /* if addrp */
+
+    return (expptr) addrp;
+} /* do_p1_extern */
+
+
+
+ static expptr
+#ifdef KR_headers
+do_p1_head(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_head(FILE *infile, FILE *outfile)
+#endif
+{
+    int status;
+    int add_n_;
+    long Class;
+    char storage[256];
+
+    status = p1getd (infile, &Class);
+    if (status == EOF)
+	err ("do_p1_head:  missing header class at end of file");
+    else if (status == 0)
+	err ("do_p1_head:  missing header class in p1 file");
+    else {
+	status = p1gets (infile, storage, (int)sizeof(storage));
+	if (status == EOF || status == 0)
+	    storage[0] = '\0';
+    } /* else */
+
+    if (Class == CLPROC || Class == CLMAIN) {
+	chainp lengths;
+
+	add_n_ = nentry > 1;
+	lengths = length_comp(entries, add_n_);
+
+	if (!add_n_ && protofile && Class != CLMAIN)
+		protowrite(protofile, proctype, storage, entries, lengths);
+
+	if (Class == CLMAIN)
+	    nice_printf (outfile, "/* Main program */ int ");
+	else
+	    nice_printf(outfile, "%s ", multitype ? "VOID"
+			: c_type_decl(proctype, 1));
+
+	nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
+	if (!Ansi) {
+		listargs(outfile, entries, add_n_, lengths);
+		nice_printf (outfile, "\n");
+		}
+	list_arg_types (outfile, entries, lengths, add_n_, "\n");
+	nice_printf (outfile, "{\n");
+	frchain(&lengths);
+	next_tab (outfile);
+	strcpy(this_proc_name, storage);
+	list_decls (outfile);
+
+    } else if (Class == CLBLOCK)
+        next_tab (outfile);
+    else
+	errl("do_p1_head: got class %ld", Class);
+
+    return NULL;
+} /* do_p1_head */
+
+
+ static expptr
+#ifdef KR_headers
+do_p1_list(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_list(FILE *infile, FILE *outfile)
+#endif
+{
+    long tag, type, count;
+    int status;
+    expptr result;
+
+    status = p1getd (infile, &tag);
+    if (status == EOF)
+	err ("do_p1_list:  missing list tag at end of file");
+    else if (status == 0)
+	err ("do_p1_list:  missing list tag in p1 file");
+    else {
+	status = p1getd (infile, &type);
+	if (status == EOF)
+	    err ("do_p1_list:  missing list type at end of file");
+	else if (status == 0)
+	    err ("do_p1_list:  missing list type in p1 file");
+	else {
+	    status = p1getd (infile, &count);
+	    if (status == EOF)
+		err ("do_p1_list:  missing count at end of file");
+	    else if (status == 0)
+		err ("do_p1_list:  missing count in p1 file");
+	} /* else */
+    } /* else */
+
+    result = (expptr) ALLOC (Listblock);
+    if (result) {
+	chainp pointer;
+
+	result -> tag = (field)tag;
+	result -> listblock.vtype = (field)type;
+
+/* Assume there will be enough data */
+
+	if (count--) {
+	    pointer = result->listblock.listp =
+		mkchain((char *)do_format(infile, outfile), CHNULL);
+	    while (count--) {
+		pointer -> nextp =
+			mkchain((char *)do_format(infile, outfile), CHNULL);
+		pointer = pointer -> nextp;
+	    } /* while (count--) */
+	} /* if (count) */
+    } /* if (result) */
+
+    return result;
+} /* do_p1_list */
+
+
+ chainp
+#ifdef KR_headers
+length_comp(e, add_n)
+	struct Entrypoint *e;
+	int add_n;
+#else
+length_comp(struct Entrypoint *e, int add_n)
+#endif
+		/* get lengths of characters args */
+{
+	chainp lengths;
+	chainp args, args1;
+	Namep arg, np;
+	int nchargs;
+	Argtypes *at;
+	Atype *a;
+	extern int init_ac[TYSUBR+1];
+
+	if (!e)
+		return 0;	/* possible only with errors */
+	args = args1 = add_n ? allargs : e->arglist;
+	nchargs = 0;
+	for (lengths = NULL; args; args = args -> nextp)
+		if (arg = (Namep)args->datap) {
+			if (arg->vclass == CLUNKNOWN)
+				arg->vclass = CLVAR;
+			if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
+				lengths = mkchain((char *)arg, lengths);
+				nchargs++;
+				}
+			}
+	if (!add_n && (np = e->enamep)) {
+		/* one last check -- by now we know all we ever will
+		 * about external args...
+		 */
+		save_argtypes(e->arglist, &e->entryname->arginfo,
+			&np->arginfo, 0, np->fvarname, STGEXT, nchargs,
+			np->vtype, 1);
+		at = e->entryname->arginfo;
+		a = at->atypes + init_ac[np->vtype];
+		for(; args1; a++, args1 = args1->nextp) {
+			frchain(&a->cp);
+			if (arg = (Namep)args1->datap)
+			    switch(arg->vclass) {
+				case CLPROC:
+					if (arg->vimpltype
+					&& a->type >= 300)
+						a->type = TYUNKNOWN + 200;
+					break;
+				case CLUNKNOWN:
+					a->type %= 100;
+				}
+			}
+		}
+	return revchain(lengths);
+	}
+
+ void
+#ifdef KR_headers
+listargs(outfile, entryp, add_n_, lengths)
+	FILE *outfile;
+	struct Entrypoint *entryp;
+	int add_n_;
+	chainp lengths;
+#else
+listargs(FILE *outfile, struct Entrypoint *entryp, int add_n_, chainp lengths)
+#endif
+{
+	chainp args;
+	char *s;
+	Namep arg;
+	int did_one = 0;
+
+	nice_printf (outfile, "(");
+
+	if (add_n_) {
+		nice_printf(outfile, "n__");
+		did_one = 1;
+		args = allargs;
+		}
+	else {
+		if (!entryp)
+			return;	/* possible only with errors */
+		args = entryp->arglist;
+		}
+
+	if (multitype)
+		{
+		nice_printf(outfile, ", ret_val");
+		did_one = 1;
+		args = allargs;
+		}
+	else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
+		{
+		s = xretslot[proctype]->user.ident;
+		nice_printf(outfile, did_one ? ", %s" : "%s",
+			*s == '(' /*)*/ ? "r_v" : s);
+		did_one = 1;
+		if (proctype == TYCHAR)
+			nice_printf (outfile, ", ret_val_len");
+		}
+	for (; args; args = args -> nextp)
+		if (arg = (Namep)args->datap) {
+			nice_printf (outfile, "%s", did_one ? ", " : "");
+			out_name (outfile, arg);
+			did_one = 1;
+			}
+
+	for (args = lengths; args; args = args -> nextp)
+		nice_printf(outfile, ", %s",
+			new_arg_length((Namep)args->datap));
+	nice_printf (outfile, ")");
+} /* listargs */
+
+
+ void
+#ifdef KR_headers
+list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
+	FILE *outfile;
+	struct Entrypoint *entryp;
+	chainp lengths;
+	int add_n_;
+	char *finalnl;
+#else
+list_arg_types(FILE *outfile, struct Entrypoint *entryp, chainp lengths, int add_n_, char *finalnl)
+#endif
+{
+    chainp args;
+    int last_type = -1, last_class = -1;
+    int did_one = 0, done_one, is_ext;
+    char *s, *sep = "", *sep1;
+
+    if (outfile == (FILE *) NULL) {
+	err ("list_arg_types:  null output file");
+	return;
+    } else if (entryp == (struct Entrypoint *) NULL) {
+	err ("list_arg_types:  null procedure entry pointer");
+	return;
+    } /* else */
+
+    if (Ansi) {
+	done_one = 0;
+	sep1 = ", ";
+	nice_printf(outfile, "(" /*)*/);
+	}
+    else {
+	done_one = 1;
+	sep1 = ";\n";
+	}
+    args = entryp->arglist;
+    if (add_n_) {
+	nice_printf(outfile, "int n__");
+	did_one = done_one;
+	sep = sep1;
+	args = allargs;
+	}
+    if (multitype) {
+	nice_printf(outfile, "%sMultitype *ret_val", sep);
+	did_one = done_one;
+	sep = sep1;
+	}
+    else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
+	s = xretslot[proctype]->user.ident;
+	nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
+			*s == '(' /*)*/ ? "r_v" : s);
+	did_one = done_one;
+	sep = sep1;
+	if (proctype == TYCHAR)
+	    nice_printf (outfile, "%sftnlen ret_val_len", sep);
+    } /* if ONEOF proctype */
+    for (; args; args = args -> nextp) {
+	Namep arg = (Namep) args->datap;
+
+/* Scalars are passed by reference, and arrays will have their lower bound
+   adjusted, so nearly everything is printed with a star in front.  The
+   exception is character lengths, which are passed by value. */
+
+	if (arg) {
+	    int type = arg -> vtype, vclass = arg -> vclass;
+
+	    if (vclass == CLPROC)
+		if (arg->vimpltype)
+			type = Castargs ? TYUNKNOWN : TYSUBR;
+		else if (type == TYREAL && forcedouble && !Castargs)
+			type = TYDREAL;
+
+	    if (type == last_type && vclass == last_class && did_one)
+		nice_printf (outfile, ", ");
+	    else
+		if ((is_ext = vclass == CLPROC) && Castargs)
+			nice_printf(outfile, "%s%s ", sep,
+				usedcasts[type] = casttypes[type]);
+		else
+			nice_printf(outfile, "%s%s ", sep,
+				c_type_decl(type, is_ext));
+	    if (vclass == CLPROC)
+		if (Castargs)
+			out_name(outfile, arg);
+		else {
+			nice_printf(outfile, "(*");
+			out_name(outfile, arg);
+			nice_printf(outfile, ") %s", parens);
+			}
+	    else {
+		nice_printf (outfile, "*");
+		out_name (outfile, arg);
+		}
+
+	    last_type = type;
+	    last_class = vclass;
+	    did_one = done_one;
+	    sep = sep1;
+	} /* if (arg) */
+    } /* for args = entryp -> arglist */
+
+    for (args = lengths; args; args = args -> nextp)
+	nice_printf(outfile, "%sftnlen %s", sep,
+			new_arg_length((Namep)args->datap));
+    if (did_one)
+	nice_printf (outfile, ";\n");
+    else if (Ansi)
+	nice_printf(outfile,
+		/*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
+		finalnl);
+} /* list_arg_types */
+
+ static void
+#ifdef KR_headers
+write_formats(outfile)
+	FILE *outfile;
+#else
+write_formats(FILE *outfile)
+#endif
+{
+	register struct Labelblock *lp;
+	int first = 1;
+	char *fs;
+
+	for(lp = labeltab ; lp < highlabtab ; ++lp)
+		if (lp->fmtlabused) {
+			if (first) {
+				first = 0;
+				nice_printf(outfile, "/* Format strings */\n");
+				}
+			nice_printf(outfile, "static char fmt_%ld[] = \"",
+				lp->stateno);
+			if (!(fs = lp->fmtstring))
+				fs = "";
+			nice_printf(outfile, "%s\";\n", fs);
+			}
+	if (!first)
+		nice_printf(outfile, "\n");
+	}
+
+ static void
+#ifdef KR_headers
+write_ioblocks(outfile)
+	FILE *outfile;
+#else
+write_ioblocks(FILE *outfile)
+#endif
+{
+	register iob_data *L;
+	register char *f, **s, *sep;
+
+	nice_printf(outfile, "/* Fortran I/O blocks */\n");
+	L = iob_list = (iob_data *)revchain((chainp)iob_list);
+	do {
+		nice_printf(outfile, "static %s %s = { ",
+			L->type, L->name);
+		sep = 0;
+		for(s = L->fields; f = *s; s++) {
+			if (sep)
+				nice_printf(outfile, sep);
+			sep = ", ";
+			if (*f == '"') {	/* kludge */
+				nice_printf(outfile, "\"");
+				nice_printf(outfile, "%s\"", f+1);
+				}
+			else
+				nice_printf(outfile, "%s", f);
+			}
+		nice_printf(outfile, " };\n");
+		}
+		while(L = L->next);
+	nice_printf(outfile, "\n\n");
+	}
+
+ static void
+#ifdef KR_headers
+write_assigned_fmts(outfile)
+	FILE *outfile;
+#else
+write_assigned_fmts(FILE *outfile)
+#endif
+{
+	register chainp cp;
+	Namep np;
+	char *comma, *type;
+	int did_one = 0;
+
+	cp = assigned_fmts = revchain(assigned_fmts);
+	nice_printf(outfile, "/* Assigned format variables */\n");
+	do {
+		np = (Namep)cp->datap;
+		if (did_one == np->vstg) {
+			comma = ", ";
+			type = "";
+			}
+		else {
+			comma = (char*)(did_one ? ";\n" : "");
+			type = (char*)(np->vstg == STGAUTO
+						? "char " : "static char ");
+			did_one = np->vstg;
+			}
+		nice_printf(outfile, "%s%s*%s_fmt", comma, type, np->fvarname);
+		}
+		while(cp = cp->nextp);
+	nice_printf(outfile, ";\n\n");
+	}
+
+ static char *
+#ifdef KR_headers
+to_upper(s)
+	register char *s;
+#else
+to_upper(register char *s)
+#endif
+{
+	static char buf[64];
+	register char *t = buf;
+	register int c;
+	while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
+	return buf;
+	}
+
+
+/* This routine creates static structures representing a namelist.
+   Declarations of the namelist and related structures are:
+
+	struct Vardesc {
+		char *name;
+		char *addr;
+		ftnlen *dims;	*//* laid out as struct dimensions below *//*
+		int  type;
+		};
+	typedef struct Vardesc Vardesc;
+
+	struct Namelist {
+		char *name;
+		Vardesc **vars;
+		int nvars;
+		};
+
+	struct dimensions
+		{
+		ftnlen numberofdimensions;
+		ftnlen numberofelements
+		ftnlen baseoffset;
+		ftnlen span[numberofdimensions-1];
+		};
+
+   If dims is not null, then the corner element of the array is at
+   addr.  However,  the element with subscripts (i1,...,in) is at
+   addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
+*/
+
+ static void
+#ifdef KR_headers
+write_namelists(nmch, outfile)
+	chainp nmch;
+	FILE *outfile;
+#else
+write_namelists(chainp nmch, FILE *outfile)
+#endif
+{
+	Namep var;
+	struct Hashentry *entry;
+	struct Dimblock *dimp;
+	int i, nd, type;
+	char *comma, *name;
+	register chainp q;
+	register Namep v;
+
+	nice_printf(outfile, "/* Namelist stuff */\n\n");
+	for (entry = hashtab; entry < lasthash; ++entry) {
+		if (!(v = entry->varp) || !v->vnamelist)
+			continue;
+		type = v->vtype;
+		name = v->cvarname;
+		if (dimp = v->vdim) {
+			nd = dimp->ndim;
+			nice_printf(outfile,
+				"static ftnlen %s_dims[] = { %d, %ld, %ld",
+				name, nd,
+				dimp->nelt->constblock.Const.ci,
+				dimp->baseoffset->constblock.Const.ci);
+			for(i = 0, --nd; i < nd; i++)
+				nice_printf(outfile, ", %ld",
+				  dimp->dims[i].dimsize->constblock.Const.ci);
+			nice_printf(outfile, " };\n");
+			}
+		nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
+			name, to_upper(v->fvarname),
+			type == TYCHAR ? ""
+				: (dimp || oneof_stg(v,v->vstg,
+					M(STGEQUIV)|M(STGCOMMON)))
+				? "(char *)" : "(char *)&");
+		out_name(outfile, v);
+		nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
+		nice_printf(outfile, ", %ld };\n",
+			type != TYCHAR  ? (long)typeconv[type]
+					: -v->vleng->constblock.Const.ci);
+		}
+
+	do {
+		var = (Namep)nmch->datap;
+		name = var->cvarname;
+		nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
+		comma = "{";
+		i = 0;
+		for(q = var->varxptr.namelist ; q ; q = q->nextp) {
+			v = (Namep)q->datap;
+			if (!v->vnamelist)
+				continue;
+			i++;
+			nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
+			comma = ",";
+			}
+		nice_printf(outfile, " };\n");
+		nice_printf(outfile,
+			"static Namelist %s = { \"%s\", %s_vl, %d };\n",
+			name, to_upper(var->fvarname), name, i);
+		}
+		while(nmch = nmch->nextp);
+	nice_printf(outfile, "\n");
+	}
+
+/* fixextype tries to infer from usage in previous procedures
+   the type of an external procedure declared
+   external and passed as an argument but never typed or invoked.
+ */
+
+ static int
+#ifdef KR_headers
+fixexttype(var)
+	Namep var;
+#else
+fixexttype(Namep var)
+#endif
+{
+	Extsym *e;
+	int type, type1;
+
+	type = var->vtype;
+	e = &extsymtab[var->vardesc.varno];
+	if ((type1 = e->extype) && type == TYUNKNOWN)
+		return var->vtype = type1;
+	if (var->visused) {
+		if (e->exused && type != type1)
+			changedtype(var);
+		e->exused = 1;
+		e->extype = type;
+		}
+	return type;
+	}
+
+ static void
+#ifdef KR_headers
+ref_defs(outfile, refdefs)
+	FILE *outfile;
+	chainp refdefs;
+#else
+ref_defs(FILE *outfile, chainp refdefs)
+#endif
+{
+	chainp cp;
+	int eb, i, j, n;
+	struct Dimblock *dimp;
+	expptr b, vl;
+	Namep var;
+	char *amp, *comma;
+
+	margin_printf(outfile, "\n");
+	for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) {
+		var = (Namep)cp->datap;
+		cp->datap = 0;
+		amp = "_subscr";
+		if (!(eb = var->vsubscrused)) {
+			var->vrefused = 0;
+			if (!ISCOMPLEX(var->vtype))
+				amp = "_ref";
+			}
+		def_start(outfile, var->cvarname, amp, CNULL);
+		dimp = var->vdim;
+		vl = 0;
+		comma = "(";
+		amp = "";
+		if (var->vtype == TYCHAR) {
+			amp = "&";
+			vl = var->vleng;
+			if (ISCONST(vl) && vl->constblock.Const.ci == 1)
+				vl = 0;
+			nice_printf(outfile, "%sa_0", comma);
+			comma = ",";
+			}
+		n = dimp->ndim;
+		for(i = 1; i <= n; i++, comma = ",")
+			nice_printf(outfile, "%sa_%d", comma, i);
+		nice_printf(outfile, ") %s", amp);
+		if (var->vsubscrused)
+			var->vsubscrused = 0;
+		else if (!ISCOMPLEX(var->vtype)) {
+			out_name(outfile, var);
+			nice_printf(outfile, "[%s", vl ? "(" : "");
+			}
+		for(j = 2; j < n; j++)
+			nice_printf(outfile, "(");
+		while(--i > 1) {
+			nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")");
+			expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize));
+			nice_printf(outfile, " + ");
+			}
+		nice_printf(outfile, "a_1");
+		if (var->vtype == TYCHAR) {
+			if (vl) {
+				nice_printf(outfile, ")*");
+				expr_out(outfile, cpexpr(vl));
+				}
+			nice_printf(outfile, " + a_0");
+			}
+		if ((var->vstg != STGARG /* || checksubs */ )
+		 && (b = dimp->baseoffset)) {
+			b = cpexpr(b);
+			if (var->vtype == TYCHAR)
+				b = mkexpr(OPSTAR, cpexpr(var->vleng), b);
+			nice_printf(outfile, " - ");
+			expr_out(outfile, b);
+			}
+		if (ISCOMPLEX(var->vtype)) {
+			margin_printf(outfile, "\n");
+			def_start(outfile, var->cvarname, "_ref", CNULL);
+			comma = "(";
+			for(i = 1; i <= n; i++, comma = ",")
+				nice_printf(outfile, "%sa_%d", comma, i);
+			nice_printf(outfile, ") %s[%s_subscr",
+				var->cvarname, var->cvarname);
+			comma = "(";
+			for(i = 1; i <= n; i++, comma = ",")
+				nice_printf(outfile, "%sa_%d", comma, i);
+			nice_printf(outfile, ")");
+			}
+		margin_printf(outfile, "]\n" + eb);
+		}
+	nice_printf(outfile, "\n");
+	frchain(&refdefs);
+	}
+
+ static long
+#ifdef KR_headers
+n_elt(vd) struct Dimblock *vd;
+#else
+n_elt(struct Dimblock *vd)
+#endif
+{
+	expptr ne;
+	long nv = 1;
+	if (vd) {
+		if (!(ne = vd->nelt))
+			Fatal("Null nelt in n_elt");
+		if (ne->tag != TCONST)
+			fatali("Unexpected nelt tag %d in n_elt", ne->tag);
+		if (!ISINT(ne->constblock.vtype))
+			fatali("Unexpected vtype %d in n_elt",
+				ne->constblock.vtype);
+		nv = ne->constblock.Const.ci;
+		}
+	return nv;
+	}
+
+ void
+#ifdef KR_headers
+list_decls(outfile)
+	FILE *outfile;
+#else
+list_decls(FILE *outfile)
+#endif
+{
+    extern chainp used_builtins;
+    extern struct Hashentry *hashtab;
+    struct Hashentry *entry;
+    int write_header = 1;
+    int last_class = -1, last_stg = -1;
+    Namep var;
+    int Alias, Define, did_one, last_type, stg, type;
+    extern int def_equivs, useauto;
+    extern chainp new_vars;	/* Compiler-generated locals */
+    chainp namelists = 0, refdefs = 0;
+    char *ctype;
+    int useauto1 = useauto && !saveall;
+    long x;
+    extern int hsize;
+
+/* First write out the statically initialized data */
+
+    if (initfile)
+	list_init_data(&initfile, initfname, outfile);
+
+/* Next come formats */
+    write_formats(outfile);
+
+/* Now write out the system-generated identifiers */
+
+    if (new_vars || nequiv) {
+	chainp args, next_var, this_var;
+	chainp nv[TYVOID], nv1[TYVOID];
+	int i, j;
+	ftnint k;
+	Addrp Var;
+	Namep arg;
+
+	/* zap unused dimension variables */
+
+	for(args = allargs; args; args = args->nextp) {
+		arg = (Namep)args->datap;
+		if (this_var = arg->vlastdim) {
+			frexpr((tagptr)this_var->datap);
+			this_var->datap = 0;
+			}
+		}
+
+	/* sort new_vars by type, skipping entries just zapped */
+
+	for(i = TYADDR; i < TYVOID; i++)
+		nv[i] = 0;
+	for(this_var = new_vars; this_var; this_var = next_var) {
+		next_var = this_var->nextp;
+		if (Var = (Addrp)this_var->datap) {
+			if (!(this_var->nextp = nv[j = Var->vtype]))
+				nv1[j] = this_var;
+			nv[j] = this_var;
+			}
+		else {
+			this_var->nextp = 0;
+			frchain(&this_var);
+			}
+		}
+	new_vars = 0;
+	for(i = TYVOID; --i >= TYADDR;)
+		if (this_var = nv[i]) {
+			nv1[i]->nextp = new_vars;
+			new_vars = this_var;
+			}
+
+	/* write the declarations */
+
+	did_one = 0;
+	last_type = -1;
+
+	for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
+	    Var = (Addrp) this_var->datap;
+
+	    if (Var == (Addrp) NULL)
+		err ("list_decls:  null variable");
+	    else if (Var -> tag != TADDR)
+		erri ("list_decls:  bad tag on new variable '%d'",
+			Var -> tag);
+
+	    type = nv_type (Var);
+	    if (Var->vstg == STGINIT
+	    ||  Var->uname_tag == UNAM_IDENT
+			&& *Var->user.ident == ' '
+			&& multitype)
+		continue;
+	    if (!did_one)
+		nice_printf (outfile, "/* System generated locals */\n");
+
+	    if (last_type == type && did_one)
+		nice_printf (outfile, ", ");
+	    else {
+		if (did_one)
+		    nice_printf (outfile, ";\n");
+		nice_printf (outfile, "%s ",
+			c_type_decl (type, Var -> vclass == CLPROC));
+	    } /* else */
+
+/* Character type is really a string type.  Put out a '*' for parameters
+   with unknown length and functions returning character */
+
+	    if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
+		    || Var -> vclass == CLPROC))
+		nice_printf (outfile, "*");
+
+	    write_nv_ident(outfile, (Addrp)this_var->datap);
+	    if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
+		    ISICON((Var -> vleng))
+			&& (k = Var->vleng->constblock.Const.ci) > 0)
+		nice_printf (outfile, "[%ld]", (long)k);
+
+	    did_one = 1;
+	    last_type = nv_type (Var);
+	} /* for this_var */
+
+/* Handle the uninitialized equivalences */
+
+	do_uninit_equivs (outfile, &did_one);
+
+	if (did_one)
+	    nice_printf (outfile, ";\n\n");
+    } /* if new_vars */
+
+/* Write out builtin declarations */
+
+    if (used_builtins) {
+	chainp cp;
+	Extsym *es;
+
+	last_type = -1;
+	did_one = 0;
+
+	nice_printf (outfile, "/* Builtin functions */");
+
+	for (cp = used_builtins; cp; cp = cp -> nextp) {
+	    Addrp e = (Addrp)cp->datap;
+
+	    switch(type = e->vtype) {
+		case TYDREAL:
+		case TYREAL:
+			/* if (forcedouble || e->dbl_builtin) */
+			/* libF77 currently assumes everything double */
+			type = TYDREAL;
+			ctype = "double";
+			break;
+		case TYCOMPLEX:
+		case TYDCOMPLEX:
+			type = TYVOID;
+			/* no break */
+		default:
+			ctype = c_type_decl(type, 0);
+		}
+
+	    if (did_one && last_type == type)
+		nice_printf(outfile, ", ");
+	    else
+		nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
+
+	    extern_out(outfile, es = &extsymtab[e -> memno]);
+	    proto(outfile, es->arginfo, es->fextname);
+	    last_type = type;
+	    did_one = 1;
+	} /* for cp = used_builtins */
+
+	nice_printf (outfile, ";\n\n");
+    } /* if used_builtins */
+
+    last_type = -1;
+    for (entry = hashtab; entry < lasthash; ++entry) {
+	var = entry -> varp;
+
+	if (var) {
+	    int procclass = var -> vprocclass;
+	    char *comment = NULL;
+	    int vclass = var -> vclass;
+	    stg = var -> vstg;
+	    type = var -> vtype;
+
+	    if (var->vrefused)
+		refdefs = mkchain((char *)var, refdefs);
+	    if (var->vsubscrused)
+		if (ISCOMPLEX(var->vtype))
+			var->vsubscrused = 0;
+		else
+			refdefs = mkchain((char *)var, refdefs);
+	    if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
+		continue;
+
+	    if (useauto1 && stg == STGBSS && !var->vsave)
+		stg = STGAUTO;
+
+	    switch (vclass) {
+	        case CLVAR:
+		    break;
+		case CLPROC:
+		    switch(procclass) {
+			case PTHISPROC:
+				extsymtab[var->vardesc.varno].extype = type;
+				continue;
+			case PSTFUNCT:
+			case PINTRINSIC:
+				continue;
+			case PUNKNOWN:
+				err ("list_decls:  unknown procedure class");
+				continue;
+			case PEXTERNAL:
+				if (stg == STGUNKNOWN) {
+					warn1(
+					"%.64s declared EXTERNAL but never used.",
+						var->fvarname);
+					/* to retain names declared EXTERNAL */
+					/* but not referenced, change	*/
+					/* "continue" to "stg = STGEXT" */
+					continue;
+					}
+				else
+					type = fixexttype(var);
+			}
+		    break;
+		case CLUNKNOWN:
+			/* declared but never used */
+			continue;
+		case CLPARAM:
+			continue;
+		case CLNAMELIST:
+			if (var->visused)
+				namelists = mkchain((char *)var, namelists);
+			continue;
+		default:
+		    erri("list_decls:  can't handle class '%d' yet",
+			    vclass);
+		    Fatal(var->fvarname);
+		    continue;
+	    } /* switch */
+
+	    /* Might be equivalenced to a common.  If not, don't process */
+	    if (stg == STGCOMMON && !var->vcommequiv)
+		continue;
+
+/* Only write the header if system-generated locals, builtins, or
+   uninitialized equivs were already output */
+
+	    if (write_header == 1 && (new_vars || nequiv || used_builtins)
+		    && oneof_stg ( var, stg,
+		    M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
+		nice_printf (outfile, "/* Local variables */\n");
+		write_header = 2;
+		}
+
+
+	    Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
+	    if (Define = (Alias && def_equivs)) {
+		if (!write_header)
+			nice_printf(outfile, ";\n");
+		def_start(outfile, var->cvarname, CNULL, "(");
+		goto Alias1;
+		}
+	    else if (type == last_type && vclass == last_class &&
+		    stg == last_stg && !write_header)
+		nice_printf (outfile, ", ");
+	    else {
+		if (!write_header && ONEOF(stg, M(STGBSS)|
+		    M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
+		    nice_printf (outfile, ";\n");
+
+		switch (stg) {
+		    case STGARG:
+		    case STGLENG:
+			/* Part of the argument list, don't write them out
+			   again */
+			continue;	    /* Go back to top of the loop */
+		    case STGBSS:
+		    case STGEQUIV:
+		    case STGCOMMON:
+			nice_printf (outfile, "static ");
+			break;
+		    case STGEXT:
+			nice_printf (outfile, "extern ");
+			break;
+		    case STGAUTO:
+			break;
+		    case STGINIT:
+		    case STGUNKNOWN:
+			/* Don't want to touch the initialized data, that will
+			   be handled elsewhere.  Unknown data have
+			   already been complained about, so skip them */
+			continue;
+		    default:
+			erri("list_decls:  can't handle storage class %d",
+				stg);
+			continue;
+		} /* switch */
+
+		if (type == TYCHAR && halign && vclass != CLPROC
+		&& ISICON(var->vleng)) {
+			nice_printf(outfile, "struct { %s fill; char val",
+				halign);
+			x = wr_char_len(outfile, var->vdim,
+				var->vleng->constblock.Const.ci, 1);
+			if (x %= hsize)
+				nice_printf(outfile, "; char fill2[%ld]",
+					hsize - x);
+			nice_printf(outfile, "; } %s_st;\n", var->cvarname);
+			def_start(outfile, var->cvarname, CNULL, var->cvarname);
+			margin_printf(outfile, "_st.val\n");
+			last_type = -1;
+			write_header = 2;
+			continue;
+			}
+		nice_printf(outfile, "%s ",
+			c_type_decl(type, vclass == CLPROC));
+	    } /* else */
+
+/* Character type is really a string type.  Put out a '*' for variable
+   length strings, and also for equivalences */
+
+	    if (type == TYCHAR && vclass != CLPROC
+		    && (!var->vleng || !ISICON (var -> vleng))
+	    || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
+		nice_printf (outfile, "*%s", var->cvarname);
+	    else {
+		nice_printf (outfile, "%s", var->cvarname);
+		if (vclass == CLPROC) {
+			Argtypes *at;
+			if (!(at = var->arginfo)
+			 && var->vprocclass == PEXTERNAL)
+				at = extsymtab[var->vardesc.varno].arginfo;
+			proto(outfile, at, var->fvarname);
+			}
+		else if (type == TYCHAR && ISICON ((var -> vleng)))
+			wr_char_len(outfile, var->vdim,
+				var->vleng->constblock.Const.ci, 0);
+		else if (var -> vdim &&
+		    !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
+			comment = wr_ardecls(outfile, var->vdim, 1L);
+		}
+
+	    if (comment)
+		nice_printf (outfile, "%s", comment);
+ Alias1:
+	    if (Alias) {
+		char *amp, *lp, *name, *rp;
+		ftnint voff = var -> voffset;
+		int et0, expr_type, k;
+		Extsym *E;
+		struct Equivblock *eb;
+		char buf[MAXNAMELEN+30]; /*30 should be overkill*/
+
+/* We DON'T want to use oneof_stg here, because we need to distinguish
+   between them */
+
+		if (stg == STGEQUIV) {
+			name = equiv_name(k = var->vardesc.varno, CNULL);
+			eb = eqvclass + k;
+			if (eb->eqvinit) {
+				amp = "&";
+				et0 = TYERROR;
+				}
+			else {
+				amp = "";
+				et0 = eb->eqvtype;
+				}
+			expr_type = et0;
+		    }
+		else {
+			E = &extsymtab[var->vardesc.varno];
+			sprintf(name = buf, "%s%d", E->cextname, E->curno);
+			expr_type = type;
+			et0 = -1;
+			amp = "&";
+		} /* else */
+
+		if (!Define)
+			nice_printf (outfile, " = ");
+		if (voff) {
+			k = typesize[type];
+			switch((int)(voff % k)) {
+				case 0:
+					voff /= k;
+					expr_type = type;
+					break;
+				case SZSHORT:
+				case SZSHORT+SZLONG:
+					expr_type = TYSHORT;
+					voff /= SZSHORT;
+					break;
+				case SZLONG:
+					expr_type = TYLONG;
+					voff /= SZLONG;
+					break;
+				default:
+					expr_type = TYCHAR;
+				}
+			}
+
+		if (expr_type == type) {
+			lp = rp = "";
+			if (et0 == -1 && !voff)
+				goto cast;
+			}
+		else {
+			lp = "(";
+			rp = ")";
+ cast:
+			nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
+			}
+
+/* Now worry about computing the offset */
+
+		if (voff) {
+		    if (expr_type == et0)
+			nice_printf (outfile, "%s%s + %ld%s",
+				lp, name, voff, rp);
+		    else
+			nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
+				c_type_decl (expr_type, 0), amp,
+				name, voff, rp);
+		} else
+		    nice_printf(outfile, "%s%s", amp, name);
+/* Always put these at the end of the line */
+		last_type = last_class = last_stg = -1;
+		write_header = 0;
+		if (Define) {
+			margin_printf(outfile, ")\n");
+			write_header = 2;
+			}
+		continue;
+		}
+	    write_header = 0;
+	    last_type = type;
+	    last_class = vclass;
+	    last_stg = stg;
+	} /* if (var) */
+    } /* for (entry = hashtab */
+
+    if (!write_header)
+	nice_printf (outfile, ";\n\n");
+    else if (write_header == 2)
+	nice_printf(outfile, "\n");
+
+/* Next, namelists, which may reference equivs */
+
+    if (namelists) {
+	write_namelists(namelists = revchain(namelists), outfile);
+	frchain(&namelists);
+	}
+
+/* Finally, ioblocks (which may reference equivs and namelists) */
+    if (iob_list)
+	write_ioblocks(outfile);
+    if (assigned_fmts)
+	write_assigned_fmts(outfile);
+
+    if (refdefs)
+	ref_defs(outfile, refdefs);
+
+    if (trapuv) {
+	for (entry = hashtab; entry < lasthash; ++entry)
+	    if ((var = entry->varp)
+		&& ONEOF(var->vstg, M(STGAUTO)|M(STGBSS))
+		&& ISNUMERIC(var->vtype)
+		&& var->vclass == CLVAR
+		&& !var->vsave)
+			nice_printf(outfile, "_uninit_f2c(&%s,%d,%ldL);\n",
+				var->cvarname, typeconv[var->vtype],
+				n_elt(var->vdim));
+	}
+
+} /* list_decls */
+
+ void
+#ifdef KR_headers
+do_uninit_equivs(outfile, did_one)
+	FILE *outfile;
+	int *did_one;
+#else
+do_uninit_equivs(FILE *outfile, int *did_one)
+#endif
+{
+    extern int nequiv;
+    struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
+    int k, last_type = -1, t;
+
+    for (eqv = eqvclass; eqv < lasteqv; eqv++)
+	if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
+	    if (!*did_one)
+		nice_printf (outfile, "/* System generated locals */\n");
+	    t = eqv->eqvtype;
+	    if (last_type == t)
+		nice_printf (outfile, ", ");
+	    else {
+		if (*did_one)
+		    nice_printf (outfile, ";\n");
+		nice_printf (outfile, "static %s ", c_type_decl(t, 0));
+		k = typesize[t];
+	    } /* else */
+	    nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
+	    nice_printf(outfile, "[%ld]",
+		(eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
+	    last_type = t;
+	    *did_one = 1;
+	} /* if !eqv -> eqvinit */
+} /* do_uninit_equivs */
+
+
+/* wr_ardecls -- Writes the brackets and size for an array
+   declaration.  Because of the inner workings of the compiler,
+   multi-dimensional arrays get mapped directly into a one-dimensional
+   array, so we have to compute the size of the array here.  When the
+   dimension is greater than 1, a string comment about the original size
+   is returned */
+
+ char *
+#ifdef KR_headers
+wr_ardecls(outfile, dimp, size)
+	FILE *outfile;
+	struct Dimblock *dimp;
+	long size;
+#else
+wr_ardecls(FILE *outfile, struct Dimblock *dimp, long size)
+#endif
+{
+    int i, k;
+    ftnint j;
+    static char buf[1000];
+
+    if (dimp == (struct Dimblock *) NULL)
+	return NULL;
+
+    sprintf(buf, "\t/* was ");	/* would like to say  k = sprintf(...), but */
+    k = strlen(buf);		/* BSD doesn't return char transmitted count */
+
+    for (i = 0; i < dimp -> ndim; i++) {
+	expptr this_size = dimp -> dims[i].dimsize;
+
+	if (ISCONST(this_size)) {
+		if (ISINT(this_size->constblock.vtype))
+			j = this_size -> constblock.Const.ci;
+		else if (ISREAL(this_size->constblock.vtype))
+			j = (ftnint)this_size -> constblock.Const.cd[0];
+		else
+			goto non_const;
+		size *= j;
+	   	sprintf(buf+k, "[%ld]", j);
+	    	k += strlen(buf+k);
+		/* BSD prevents getting strlen from sprintf */
+		}
+	else {
+ non_const:
+	    err ("wr_ardecls:  nonconstant array size");
+		}
+    } /* for i = 0 */
+
+    nice_printf (outfile, "[%ld]", size);
+    strcat(buf+k, " */");
+
+    return (i > 1) ? buf : NULL;
+} /* wr_ardecls */
+
+
+
+/* ----------------------------------------------------------------------
+
+	The following routines read from the p1 intermediate file.  If
+   that format changes, only these routines need be changed
+
+   ---------------------------------------------------------------------- */
+
+ static int
+#ifdef KR_headers
+get_p1_token(infile)
+	FILE *infile;
+#else
+get_p1_token(FILE *infile)
+#endif
+{
+    int token = P1_UNKNOWN;
+
+/* NOT PORTABLE!! */
+
+    if (fscanf (infile, "%d", &token) == EOF)
+	return P1_EOF;
+
+/* Skip over the ": " */
+
+    if (getc (infile) != '\n')
+	getc (infile);
+
+    return token;
+} /* get_p1_token */
+
+
+
+/* Returns a (null terminated) string from the input file */
+
+ static int
+#ifdef KR_headers
+p1gets(fp, str, size)
+	FILE *fp;
+	char *str;
+	int size;
+#else
+p1gets(FILE *fp, char *str, int size)
+#endif
+{
+    char c;
+
+    if (str == NULL)
+	return 0;
+
+    if ((c = getc (fp)) != ' ')
+	ungetc (c, fp);
+
+    if (fgets (str, size, fp)) {
+	int length;
+
+	str[size - 1] = '\0';
+	length = strlen (str);
+
+/* Get rid of the newline */
+
+	if (str[length - 1] == '\n')
+	    str[length - 1] = '\0';
+	return 1;
+
+    } else if (feof (fp))
+	return EOF;
+    else
+	return 0;
+} /* p1gets */
+
+
+#ifndef NO_LONG_LONG
+ static int
+#ifdef KR_headers
+p1getq(infile, result) FILE *infile; Llong *result;
+#else
+p1getq(FILE *infile, Llong *result)
+#endif
+{
+#ifdef __FreeBSD__
+#ifndef NO_FSCANF_LL_BUG
+#define FSCANF_LL_BUG
+#endif
+#endif
+#ifdef FSCANF_LL_BUG
+	ULlong x = 0;
+	int c, have_c = 0;
+	for(;;) {
+		c = getc(infile);
+		if (c == EOF)
+			break;
+		if (c <= ' ') {
+			if (!have_c)
+				continue;
+			goto done;
+			}
+		if (c >= '0' && c <= '9')
+			c -= '0';
+		else if (c >= 'a' && c <= 'f')
+			c += 10 - 'a';
+		else if (c >= 'A' && c <= 'F')
+			c += 10 - 'A';
+		else {
+ done:
+			ungetc(c, infile);
+			break;
+			}
+		x = x << 4 | c;
+		have_c = 1;
+		}
+	if (have_c) {
+		*result = (Llong)x;
+		return 1;
+		}
+	return 0;
+#else
+	return fscanf(infile, "%llx", result);
+#endif
+	}
+#endif
+
+ static int
+#ifdef KR_headers
+p1get_const(infile, type, resultp)
+	FILE *infile;
+	int type;
+	struct Constblock **resultp;
+#else
+p1get_const(FILE *infile, int type, struct Constblock **resultp)
+#endif
+{
+    int status;
+    unsigned long a;
+    struct Constblock *result;
+
+	if (type != TYCHAR) {
+		*resultp = result = ALLOC(Constblock);
+		result -> tag = TCONST;
+		result -> vtype = type;
+		}
+
+    switch (type) {
+	case TYINT1:
+        case TYSHORT:
+	case TYLONG:
+	case TYLOGICAL:
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+	    status = p1getd (infile, &(result -> Const.ci));
+	    break;
+#ifndef NO_LONG_LONG
+	case TYQUAD:
+		status = p1getq(infile, &result->Const.cq);
+		break;
+#endif
+	case TYREAL:
+	case TYDREAL:
+	    status = p1getf(infile, &result->Const.cds[0]);
+	    result->vstg = 1;
+	    break;
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+	    status = p1getf(infile, &result->Const.cds[0]);
+	    if (status && status != EOF)
+		status = p1getf(infile, &result->Const.cds[1]);
+	    result->vstg = 1;
+	    break;
+	case TYCHAR:
+	    status = fscanf(infile, "%lx", &a);
+	    *resultp = (struct Constblock *) a;
+	    break;
+	default:
+	    erri ("p1get_const:  bad constant type '%d'", type);
+	    status = 0;
+	    break;
+    } /* switch */
+
+    return status;
+} /* p1get_const */
+
+ static int
+#ifdef KR_headers
+p1getd(infile, result)
+	FILE *infile;
+	long *result;
+#else
+p1getd(FILE *infile, long *result)
+#endif
+{
+    return fscanf (infile, "%ld", result);
+} /* p1getd */
+
+ static int
+#ifdef KR_headers
+p1getf(infile, result)
+	FILE *infile;
+	char **result;
+#else
+p1getf(FILE *infile, char **result)
+#endif
+{
+
+	char buf[1324];
+	register int k;
+
+	k = fscanf (infile, "%s", buf);
+	if (k < 1)
+		k = EOF;
+	else
+		strcpy(*result = mem(strlen(buf)+1,0), buf);
+	return k;
+}
+
+ static int
+#ifdef KR_headers
+p1getn(infile, count, result)
+	FILE *infile;
+	int count;
+	char **result;
+#else
+p1getn(FILE *infile, int count, char **result)
+#endif
+{
+
+    char *bufptr;
+
+    bufptr = (char *) ckalloc (count);
+
+    if (result)
+	*result = bufptr;
+
+    for (; !feof (infile) && count > 0; count--)
+	*bufptr++ = getc (infile);
+
+    return feof (infile) ? EOF : 1;
+} /* p1getn */
+
+ static void
+#ifdef KR_headers
+proto(outfile, at, fname)
+	FILE *outfile;
+	Argtypes *at;
+	char *fname;
+#else
+proto(FILE *outfile,  Argtypes *at,  char *fname)
+#endif
+{
+	int i, j, k, n;
+	char *comma;
+	Atype *atypes;
+	Namep np;
+	chainp cp;
+
+	if (at) {
+		/* Correct types that we learn on the fly, e.g.
+			subroutine gotcha(foo)
+			external foo
+			call zap(...,foo,...)
+			call foo(...)
+		*/
+		atypes = at->atypes;
+		n = at->defined ? at->dnargs : at->nargs;
+		for(i = 0; i++ < n; atypes++) {
+			if (!(cp = atypes->cp))
+				continue;
+			j = atypes->type;
+			do {
+				np = (Namep)cp->datap;
+				k = np->vtype;
+				if (np->vclass == CLPROC) {
+					if (!np->vimpltype && k)
+						k += 200;
+					else {
+						if (j >= 300)
+							j = TYUNKNOWN + 200;
+						continue;
+						}
+					}
+				if (j == k)
+					continue;
+				if (j >= 300
+				||  j == 200 && k >= 200)
+					j = k;
+				else {
+					if (at->nargs >= 0)
+					   bad_atypes(at,fname,i,j,k,""," and");
+					goto break2;
+					}
+				}
+				while(cp = cp->nextp);
+			atypes->type = j;
+			frchain(&atypes->cp);
+			}
+		}
+ break2:
+	if (parens) {
+		nice_printf(outfile, parens);
+		return;
+		}
+
+	if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) {
+		nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
+		return;
+		}
+
+	if (n == 0) {
+		nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
+		return;
+		}
+
+	atypes = at->atypes;
+	nice_printf(outfile, "(");
+	comma = "";
+	for(; --n >= 0; atypes++) {
+		k = atypes->type;
+		if (k == TYADDR)
+			nice_printf(outfile, "%schar **", comma);
+		else if (k >= 200) {
+			k -= 200;
+			if (k >= 100)
+				k -= 100;
+			nice_printf(outfile, "%s%s", comma,
+				usedcasts[k] = casttypes[k]);
+			}
+		else if (k >= 100)
+			nice_printf(outfile,
+					k == TYCHAR + 100 ? "%s%s *" : "%s%s",
+					comma, c_type_decl(k-100, 0));
+		else
+			nice_printf(outfile, "%s%s *", comma,
+					c_type_decl(k, 0));
+		comma = ", ";
+		}
+	nice_printf(outfile, ")");
+	}
+
+ void
+#ifdef KR_headers
+protowrite(protofile, type, name, e, lengths)
+	FILE *protofile;
+	int type;
+	char *name;
+	struct Entrypoint *e;
+	chainp lengths;
+#else
+protowrite(FILE *protofile, int type, char *name, struct Entrypoint *e, chainp lengths)
+#endif
+{
+	extern char used_rets[];
+	int asave;
+
+	if (!(asave = Ansi))
+		Castargs = Ansi = 1;
+	nice_printf(protofile, "extern %s %s", protorettypes[type], name);
+	list_arg_types(protofile, e, lengths, 0, ";\n");
+	used_rets[type] = 1;
+	if (!(Ansi = asave))
+		Castargs = 0;
+	}
+
+ static void
+#ifdef KR_headers
+do_p1_1while(outfile)
+	FILE *outfile;
+#else
+do_p1_1while(FILE *outfile)
+#endif
+{
+	if (*wh_next) {
+		nice_printf(outfile,
+			"for(;;) { /* while(complicated condition) */\n" /*}*/ );
+		next_tab(outfile);
+		}
+	else
+		nice_printf(outfile, "while(" /*)*/ );
+	}
+
+ static void
+#ifdef KR_headers
+do_p1_2while(infile, outfile)
+	FILE *infile;
+	FILE *outfile;
+#else
+do_p1_2while(FILE *infile, FILE *outfile)
+#endif
+{
+	expptr test;
+
+	test = do_format(infile, outfile);
+	if (*wh_next)
+		nice_printf(outfile, "if (!(");
+	expr_out(outfile, test);
+	if (*wh_next++)
+		nice_printf(outfile, "))\n\tbreak;\n");
+	else {
+		nice_printf(outfile, /*(*/ ") {\n");
+		next_tab(outfile);
+		}
+	}
+
+ static void
+#ifdef KR_headers
+do_p1_elseifstart(outfile)
+	FILE *outfile;
+#else
+do_p1_elseifstart(FILE *outfile)
+#endif
+{ /* with sufficiently illegal input, ei_next == ei_last == 0 is possible */
+	if (ei_next < ei_last && *ei_next++) {
+		prev_tab(outfile);
+		nice_printf(outfile, /*{*/
+			"} else /* if(complicated condition) */ {\n" /*}*/ );
+		next_tab(outfile);
+		}
+	}