diff options
Diffstat (limited to 'usr.bin/f2c/format.c')
| -rw-r--r-- | usr.bin/f2c/format.c | 2225 |
1 files changed, 0 insertions, 2225 deletions
diff --git a/usr.bin/f2c/format.c b/usr.bin/f2c/format.c deleted file mode 100644 index 80faacc..0000000 --- a/usr.bin/f2c/format.c +++ /dev/null @@ -1,2225 +0,0 @@ -/**************************************************************** -Copyright 1990, 1991, 1992, 1993 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 char filename[P1_FILENAME_MAX]; -extern int gflag; -int gflag1; -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; - 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 = 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 -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 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 = 0; - retval = do_p1_head (infile, outfile); - gflag1 = 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 -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); - - gflag1 = 0; - 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; - gflag1 = gflag; -} /* 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; - } -} /* 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, (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 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]; - - 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 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 { - 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 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; - extern int typeconv[]; - - 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 -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; - } - - static void -ref_defs(outfile, refdefs) FILE *outfile; chainp refdefs; -{ - chainp cp; - int eb, i, j, n; - struct Dimblock *dimp; - long L; - expptr b, vl; - Namep var; - char *amp, *comma; - - ind_printf(0, 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 && (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)) { - ind_printf(0, 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, ")"); - } - ind_printf(0, outfile, "]\n" + eb); - } - nice_printf(outfile, "\n"); - frchain(&refdefs); - } - -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, 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; - 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 (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 (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) { - 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, - (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); - - if (refdefs) - ref_defs(outfile, refdefs); - -} /* 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 TYINT1: - case TYSHORT: - case TYLONG: - case TYLOGICAL: -#ifdef TYQUAD - case TYQUAD: -#endif - case TYLOGICAL1: - case TYLOGICAL2: - 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->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; - 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[]; - 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 -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); - } - } |
