|
@@ -0,0 +1,2108 @@
|
|
|
+/****************************************************************
|
|
|
+Copyright 1990, 1991 by AT&T Bell Laboratories 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 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 and Bellcore disclaim all warranties with regard to this
|
|
|
+software, including all implied warranties of merchantability
|
|
|
+and fitness. In no event shall AT&T 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 int p1getd(), p1gets(), p1getf(), get_p1_token();
|
|
|
+static int p1get_const(), p1getn();
|
|
|
+static expptr do_format(), do_p1_name_pointer(), do_p1_const();
|
|
|
+static expptr do_p1_expr(), do_p1_ident(), do_p1_charp(), do_p1_extern();
|
|
|
+static expptr do_p1_head(), do_p1_list(), do_p1_literal();
|
|
|
+static void do_p1_label(), do_p1_asgoto(), do_p1_goto();
|
|
|
+static void do_p1_if(), do_p1_else(), do_p1_elif(), do_p1_endif();
|
|
|
+static void do_p1_endelse(), do_p1_subr_ret(), do_p1_comp_goto();
|
|
|
+static void do_p1_for(), do_p1_end_for(), do_p1_fortran();
|
|
|
+static void do_p1_1while(), do_p1_2while(), do_p1_elseifstart();
|
|
|
+static void do_p1_comment(), do_p1_set_line();
|
|
|
+static expptr do_p1_addr();
|
|
|
+static void proto();
|
|
|
+void list_arg_types();
|
|
|
+chainp length_comp();
|
|
|
+void listargs();
|
|
|
+extern chainp assigned_fmts;
|
|
|
+static long old_lineno;
|
|
|
+static char filename[P1_FILENAME_MAX];
|
|
|
+extern int gflag;
|
|
|
+extern char *parens;
|
|
|
+
|
|
|
+start_formatting ()
|
|
|
+{
|
|
|
+ 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;
|
|
|
+ old_lineno = lineno;
|
|
|
+ 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);
|
|
|
+ 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
|
|
|
+put_semi(outfile)
|
|
|
+ FILE *outfile;
|
|
|
+{
|
|
|
+ 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 do_format (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ int gsave, 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:
|
|
|
+ gsave = gflag;
|
|
|
+ gflag = 0;
|
|
|
+ retval = do_p1_head (infile, outfile);
|
|
|
+ gflag = gsave;
|
|
|
+ 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
|
|
|
+do_p1_comment (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ extern int c_output_line_length, in_comment;
|
|
|
+
|
|
|
+ char storage[COMMENT_BUFFER_SIZE + 1];
|
|
|
+ int length;
|
|
|
+
|
|
|
+ if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
|
|
|
+ return;
|
|
|
+
|
|
|
+ length = strlen (storage);
|
|
|
+
|
|
|
+ in_comment = 1;
|
|
|
+ if (length > c_output_line_length - 6)
|
|
|
+ margin_printf (outfile, "/*%s*/\n", storage);
|
|
|
+ else
|
|
|
+ margin_printf (outfile, length ? "/* %s */\n" : "\n", storage);
|
|
|
+ in_comment = 0;
|
|
|
+} /* do_p1_comment */
|
|
|
+
|
|
|
+ static void
|
|
|
+do_p1_set_line (infile)
|
|
|
+FILE *infile;
|
|
|
+{
|
|
|
+ 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;
|
|
|
+ if (gflag)
|
|
|
+ fprintf(c_file, "/*# %ld \"%s\"*/\n", lineno, filename);
|
|
|
+ }
|
|
|
+} /* do_p1_set_line */
|
|
|
+
|
|
|
+
|
|
|
+static expptr do_p1_name_pointer (infile)
|
|
|
+FILE *infile;
|
|
|
+{
|
|
|
+ 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: '%x'\n",
|
|
|
+ (int) namep);
|
|
|
+
|
|
|
+ return (expptr) namep;
|
|
|
+} /* do_p1_name_pointer */
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+static expptr do_p1_const (infile)
|
|
|
+FILE *infile;
|
|
|
+{
|
|
|
+ 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 */
|
|
|
+
|
|
|
+
|
|
|
+static expptr do_p1_literal (infile)
|
|
|
+FILE *infile;
|
|
|
+{
|
|
|
+ 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 {
|
|
|
+ struct Literal *litp, *lastlit;
|
|
|
+
|
|
|
+ addrp = ALLOC (Addrblock);
|
|
|
+ addrp -> tag = TADDR;
|
|
|
+ addrp -> vtype = TYUNKNOWN;
|
|
|
+ addrp -> Field = NULL;
|
|
|
+
|
|
|
+ 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));
|
|
|
+ break;
|
|
|
+ } /* if litp -> litnum == memno */
|
|
|
+
|
|
|
+ addrp -> memno = memno;
|
|
|
+ addrp -> vstg = STGMEMNO;
|
|
|
+ addrp -> uname_tag = UNAM_CONST;
|
|
|
+ } /* else */
|
|
|
+
|
|
|
+ return (expptr) addrp;
|
|
|
+} /* do_p1_literal */
|
|
|
+
|
|
|
+
|
|
|
+static void do_p1_label (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ int status;
|
|
|
+ ftnint stateno;
|
|
|
+ char *user_label ();
|
|
|
+ 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 do_p1_asgoto (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ expptr expr;
|
|
|
+
|
|
|
+ expr = do_format (infile, outfile);
|
|
|
+ out_asgoto (outfile, expr);
|
|
|
+
|
|
|
+} /* do_p1_asgoto */
|
|
|
+
|
|
|
+
|
|
|
+static void do_p1_goto (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ int status;
|
|
|
+ long stateno;
|
|
|
+ char *user_label ();
|
|
|
+
|
|
|
+ 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 do_p1_if (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ expptr cond;
|
|
|
+
|
|
|
+ do {
|
|
|
+ cond = do_format (infile, outfile);
|
|
|
+ } while (cond == ENULL);
|
|
|
+
|
|
|
+ out_if (outfile, cond);
|
|
|
+} /* do_p1_if */
|
|
|
+
|
|
|
+
|
|
|
+static void do_p1_else (outfile)
|
|
|
+FILE *outfile;
|
|
|
+{
|
|
|
+ out_else (outfile);
|
|
|
+} /* do_p1_else */
|
|
|
+
|
|
|
+
|
|
|
+static void do_p1_elif (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ expptr cond;
|
|
|
+
|
|
|
+ do {
|
|
|
+ cond = do_format (infile, outfile);
|
|
|
+ } while (cond == ENULL);
|
|
|
+
|
|
|
+ elif_out (outfile, cond);
|
|
|
+} /* do_p1_elif */
|
|
|
+
|
|
|
+static void do_p1_endif (outfile)
|
|
|
+FILE *outfile;
|
|
|
+{
|
|
|
+ endif_out (outfile);
|
|
|
+} /* do_p1_endif */
|
|
|
+
|
|
|
+
|
|
|
+static void do_p1_endelse (outfile)
|
|
|
+FILE *outfile;
|
|
|
+{
|
|
|
+ end_else_out (outfile);
|
|
|
+} /* do_p1_endelse */
|
|
|
+
|
|
|
+
|
|
|
+static expptr do_p1_addr (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ Addrp addrp = (Addrp) NULL;
|
|
|
+ int status;
|
|
|
+
|
|
|
+ status = p1getn (infile, 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 do_p1_subr_ret (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ 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 do_p1_comp_goto (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ 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 do_p1_for (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ 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 do_p1_end_for (outfile)
|
|
|
+FILE *outfile;
|
|
|
+{
|
|
|
+ out_end_for (outfile);
|
|
|
+} /* do_p1_end_for */
|
|
|
+
|
|
|
+
|
|
|
+ static void
|
|
|
+do_p1_fortran(infile, outfile)
|
|
|
+ FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ 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 do_p1_expr (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ 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 = type;
|
|
|
+ result -> opcode = 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 do_p1_ident(infile)
|
|
|
+FILE *infile;
|
|
|
+{
|
|
|
+ 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 = 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 = 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 do_p1_charp(infile)
|
|
|
+FILE *infile;
|
|
|
+{
|
|
|
+ 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 = 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 = 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 do_p1_extern (infile)
|
|
|
+FILE *infile;
|
|
|
+{
|
|
|
+ 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 do_p1_head (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ 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 */ ");
|
|
|
+ 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 do_p1_list (infile, outfile)
|
|
|
+FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ 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 = tag;
|
|
|
+ result -> listblock.vtype = 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 length_comp(e, add_n) /* get lengths of characters args */
|
|
|
+ struct Entrypoint *e;
|
|
|
+ int add_n;
|
|
|
+{
|
|
|
+ chainp lengths;
|
|
|
+ chainp args, args1;
|
|
|
+ Namep arg, np;
|
|
|
+ int nchargs;
|
|
|
+ Argtypes *at;
|
|
|
+ Atype *a;
|
|
|
+ extern int init_ac[TYSUBR+1];
|
|
|
+
|
|
|
+ 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 listargs(outfile, entryp, add_n_, lengths)
|
|
|
+ FILE *outfile;
|
|
|
+ struct Entrypoint *entryp;
|
|
|
+ int add_n_;
|
|
|
+ chainp lengths;
|
|
|
+{
|
|
|
+ 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
|
|
|
+ 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 list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
|
|
|
+FILE *outfile;
|
|
|
+struct Entrypoint *entryp;
|
|
|
+chainp lengths;
|
|
|
+int add_n_;
|
|
|
+char *finalnl;
|
|
|
+{
|
|
|
+ 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, class = arg -> vclass;
|
|
|
+
|
|
|
+ if (class == CLPROC)
|
|
|
+ if (arg->vimpltype)
|
|
|
+ type = Castargs ? TYUNKNOWN : TYSUBR;
|
|
|
+ else if (type == TYREAL && forcedouble && !Castargs)
|
|
|
+ type = TYDREAL;
|
|
|
+
|
|
|
+ if (type == last_type && class == last_class && did_one)
|
|
|
+ nice_printf (outfile, ", ");
|
|
|
+ else
|
|
|
+ if ((is_ext = class == 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 (class == 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 = class;
|
|
|
+ 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
|
|
|
+write_formats(outfile)
|
|
|
+ FILE *outfile;
|
|
|
+{
|
|
|
+ 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
|
|
|
+write_ioblocks(outfile)
|
|
|
+ FILE *outfile;
|
|
|
+{
|
|
|
+ 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
|
|
|
+write_assigned_fmts(outfile)
|
|
|
+ FILE *outfile;
|
|
|
+{
|
|
|
+ register chainp cp;
|
|
|
+ Namep np;
|
|
|
+ int did_one = 0;
|
|
|
+
|
|
|
+ cp = assigned_fmts = revchain(assigned_fmts);
|
|
|
+ nice_printf(outfile, "/* Assigned format variables */\nchar ");
|
|
|
+ do {
|
|
|
+ np = (Namep)cp->datap;
|
|
|
+ if (did_one)
|
|
|
+ nice_printf(outfile, ", ");
|
|
|
+ did_one = 1;
|
|
|
+ nice_printf(outfile, "*%s_fmt", np->fvarname);
|
|
|
+ }
|
|
|
+ while(cp = cp->nextp);
|
|
|
+ nice_printf(outfile, ";\n\n");
|
|
|
+ }
|
|
|
+
|
|
|
+ static char *
|
|
|
+to_upper(s)
|
|
|
+ register char *s;
|
|
|
+{
|
|
|
+ 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
|
|
|
+write_namelists(nmch, outfile)
|
|
|
+ chainp nmch;
|
|
|
+ FILE *outfile;
|
|
|
+{
|
|
|
+ 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(name),
|
|
|
+ type == TYCHAR ? "" : dimp ? "(char *)" : "(char *)&");
|
|
|
+ out_name(outfile, v);
|
|
|
+ nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
|
|
|
+ nice_printf(outfile, ", %ld };\n",
|
|
|
+ type != TYCHAR ? (long)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(name), 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
|
|
|
+fixexttype(var)
|
|
|
+ Namep var;
|
|
|
+{
|
|
|
+ Extsym *e;
|
|
|
+ int type, type1;
|
|
|
+ extern void changedtype();
|
|
|
+
|
|
|
+ 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;
|
|
|
+ }
|
|
|
+
|
|
|
+list_decls (outfile)
|
|
|
+FILE *outfile;
|
|
|
+{
|
|
|
+ extern chainp used_builtins;
|
|
|
+ extern struct Hashentry *hashtab;
|
|
|
+ extern ftnint wr_char_len();
|
|
|
+ struct Hashentry *entry;
|
|
|
+ int write_header = 1;
|
|
|
+ int last_class = -1, last_stg = -1;
|
|
|
+ Namep var;
|
|
|
+ int Alias, Define, did_one, last_type, type;
|
|
|
+ extern int def_equivs, useauto;
|
|
|
+ extern chainp new_vars; /* Compiler-generated locals */
|
|
|
+ chainp namelists = 0;
|
|
|
+ char *ctype;
|
|
|
+ long lineno_save = lineno;
|
|
|
+ int useauto1 = useauto && !saveall;
|
|
|
+ long x;
|
|
|
+ extern int hsize;
|
|
|
+
|
|
|
+ lineno = old_lineno;
|
|
|
+
|
|
|
+/* 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;
|
|
|
+ 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))
|
|
|
+ && (i = Var->vleng->constblock.Const.ci) > 0)
|
|
|
+ nice_printf (outfile, "[%d]", i);
|
|
|
+
|
|
|
+ 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 stg = var -> vstg;
|
|
|
+ int class = var -> vclass;
|
|
|
+ type = var -> vtype;
|
|
|
+
|
|
|
+ if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
|
|
|
+ continue;
|
|
|
+
|
|
|
+ if (useauto1 && stg == STGBSS && !var->vsave)
|
|
|
+ stg = STGAUTO;
|
|
|
+
|
|
|
+ switch (class) {
|
|
|
+ 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",
|
|
|
+ class);
|
|
|
+ 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 && class == 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 && class != 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);
|
|
|
+ ind_printf(0, outfile, "_st.val\n");
|
|
|
+ last_type = -1;
|
|
|
+ write_header = 2;
|
|
|
+ continue;
|
|
|
+ }
|
|
|
+ nice_printf(outfile, "%s ",
|
|
|
+ c_type_decl(type, class == CLPROC));
|
|
|
+ } /* else */
|
|
|
+
|
|
|
+/* Character type is really a string type. Put out a '*' for variable
|
|
|
+ length strings, and also for equivalences */
|
|
|
+
|
|
|
+ if (type == TYCHAR && class != 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 (class == CLPROC)
|
|
|
+ proto(outfile, var->arginfo, var->fvarname);
|
|
|
+ else if (type == TYCHAR && ISICON ((var -> vleng)))
|
|
|
+ wr_char_len(outfile, var->vdim,
|
|
|
+ (int)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;
|
|
|
+ char *equiv_name ();
|
|
|
+ ftnint voff = var -> voffset;
|
|
|
+ int et0, expr_type, k;
|
|
|
+ Extsym *E;
|
|
|
+ struct Equivblock *eb;
|
|
|
+ char buf[16];
|
|
|
+
|
|
|
+/* 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) {
|
|
|
+ ind_printf(0, outfile, ")\n");
|
|
|
+ write_header = 2;
|
|
|
+ }
|
|
|
+ continue;
|
|
|
+ }
|
|
|
+ write_header = 0;
|
|
|
+ last_type = type;
|
|
|
+ last_class = class;
|
|
|
+ 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);
|
|
|
+ lineno = lineno_save;
|
|
|
+} /* list_decls */
|
|
|
+
|
|
|
+do_uninit_equivs (outfile, did_one)
|
|
|
+FILE *outfile;
|
|
|
+int *did_one;
|
|
|
+{
|
|
|
+ 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 *wr_ardecls(outfile, dimp, size)
|
|
|
+FILE *outfile;
|
|
|
+struct Dimblock *dimp;
|
|
|
+long size;
|
|
|
+{
|
|
|
+ int i, k;
|
|
|
+ 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 (!ISICON (this_size))
|
|
|
+ err ("wr_ardecls: nonconstant array size");
|
|
|
+ else {
|
|
|
+ size *= this_size -> constblock.Const.ci;
|
|
|
+ sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci);
|
|
|
+ k += strlen(buf+k); /* BSD prevents combining this with prev stmt */
|
|
|
+ } /* else */
|
|
|
+ } /* 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 get_p1_token (infile)
|
|
|
+FILE *infile;
|
|
|
+{
|
|
|
+ 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 p1gets (fp, str, size)
|
|
|
+FILE *fp;
|
|
|
+char *str;
|
|
|
+int size;
|
|
|
+{
|
|
|
+ char *fgets ();
|
|
|
+ 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 */
|
|
|
+
|
|
|
+
|
|
|
+static int p1get_const (infile, type, resultp)
|
|
|
+FILE *infile;
|
|
|
+int type;
|
|
|
+struct Constblock **resultp;
|
|
|
+{
|
|
|
+ int status;
|
|
|
+ struct Constblock *result;
|
|
|
+
|
|
|
+ if (type != TYCHAR) {
|
|
|
+ *resultp = result = ALLOC(Constblock);
|
|
|
+ result -> tag = TCONST;
|
|
|
+ result -> vtype = type;
|
|
|
+ }
|
|
|
+
|
|
|
+ switch (type) {
|
|
|
+ case TYSHORT:
|
|
|
+ case TYLONG:
|
|
|
+ case TYLOGICAL:
|
|
|
+ status = p1getd (infile, &(result -> Const.ci));
|
|
|
+ break;
|
|
|
+ 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", resultp);
|
|
|
+ break;
|
|
|
+ default:
|
|
|
+ erri ("p1get_const: bad constant type '%d'", type);
|
|
|
+ status = 0;
|
|
|
+ break;
|
|
|
+ } /* switch */
|
|
|
+
|
|
|
+ return status;
|
|
|
+} /* p1get_const */
|
|
|
+
|
|
|
+static int p1getd (infile, result)
|
|
|
+FILE *infile;
|
|
|
+long *result;
|
|
|
+{
|
|
|
+ return fscanf (infile, "%ld", result);
|
|
|
+} /* p1getd */
|
|
|
+
|
|
|
+ static int
|
|
|
+p1getf(infile, result)
|
|
|
+ FILE *infile;
|
|
|
+ char **result;
|
|
|
+{
|
|
|
+
|
|
|
+ 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 p1getn (infile, count, result)
|
|
|
+FILE *infile;
|
|
|
+int count;
|
|
|
+char **result;
|
|
|
+{
|
|
|
+
|
|
|
+ char *bufptr;
|
|
|
+ extern ptr ckalloc ();
|
|
|
+
|
|
|
+ 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
|
|
|
+proto(outfile, at, fname)
|
|
|
+ FILE *outfile;
|
|
|
+ Argtypes *at;
|
|
|
+ char *fname;
|
|
|
+{
|
|
|
+ int i, j, k, n;
|
|
|
+ char *comma;
|
|
|
+ Atype *atypes;
|
|
|
+ Namep np;
|
|
|
+ chainp cp;
|
|
|
+ extern void bad_atypes();
|
|
|
+
|
|
|
+ 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->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 {
|
|
|
+ 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->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;
|
|
|
+ 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
|
|
|
+protowrite(protofile, type, name, e, lengths)
|
|
|
+ FILE *protofile;
|
|
|
+ char *name;
|
|
|
+ struct Entrypoint *e;
|
|
|
+ chainp lengths;
|
|
|
+{
|
|
|
+ extern char used_rets[];
|
|
|
+
|
|
|
+ nice_printf(protofile, "extern %s %s", protorettypes[type], name);
|
|
|
+ list_arg_types(protofile, e, lengths, 0, ";\n");
|
|
|
+ used_rets[type] = 1;
|
|
|
+ }
|
|
|
+
|
|
|
+ static void
|
|
|
+do_p1_1while(outfile)
|
|
|
+ FILE *outfile;
|
|
|
+{
|
|
|
+ if (*wh_next) {
|
|
|
+ nice_printf(outfile,
|
|
|
+ "for(;;) { /* while(complicated condition) */\n" /*}*/ );
|
|
|
+ next_tab(outfile);
|
|
|
+ }
|
|
|
+ else
|
|
|
+ nice_printf(outfile, "while(" /*)*/ );
|
|
|
+ }
|
|
|
+
|
|
|
+ static void
|
|
|
+do_p1_2while(infile, outfile)
|
|
|
+ FILE *infile, *outfile;
|
|
|
+{
|
|
|
+ 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
|
|
|
+do_p1_elseifstart(outfile)
|
|
|
+ FILE *outfile;
|
|
|
+{
|
|
|
+ if (*ei_next++) {
|
|
|
+ prev_tab(outfile);
|
|
|
+ nice_printf(outfile, /*{*/
|
|
|
+ "} else /* if(complicated condition) */ {\n" /*}*/ );
|
|
|
+ next_tab(outfile);
|
|
|
+ }
|
|
|
+ }
|