2518 lines
56 KiB
C
2518 lines
56 KiB
C
/****************************************************************
|
|
Copyright 1990 - 1995 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 tagptr do_format Argdcl((FILEP, FILEP));
|
|
static void do_p1_1while Argdcl((FILEP));
|
|
static void do_p1_2while Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_addr Argdcl((FILEP, FILEP));
|
|
static void do_p1_asgoto Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_charp Argdcl((FILEP));
|
|
static void do_p1_comment Argdcl((FILEP, FILEP));
|
|
static void do_p1_comp_goto Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_const Argdcl((FILEP));
|
|
static void do_p1_elif Argdcl((FILEP, FILEP));
|
|
static void do_p1_else Argdcl((FILEP));
|
|
static void do_p1_elseifstart Argdcl((FILEP));
|
|
static void do_p1_end_for Argdcl((FILEP));
|
|
static void do_p1_endelse Argdcl((FILEP));
|
|
static void do_p1_endif Argdcl((FILEP));
|
|
static tagptr do_p1_expr Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_extern Argdcl((FILEP));
|
|
static void do_p1_for Argdcl((FILEP, FILEP));
|
|
static void do_p1_fortran Argdcl((FILEP, FILEP));
|
|
static void do_p1_goto Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_head Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_ident Argdcl((FILEP));
|
|
static void do_p1_if Argdcl((FILEP, FILEP));
|
|
static void do_p1_label Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_list Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_literal Argdcl((FILEP));
|
|
static tagptr do_p1_name_pointer Argdcl((FILEP));
|
|
static void do_p1_set_line Argdcl((FILEP));
|
|
static void do_p1_subr_ret Argdcl((FILEP, FILEP));
|
|
static int get_p1_token Argdcl((FILEP));
|
|
static int p1get_const Argdcl((FILEP, int, Constp*));
|
|
static int p1getd Argdcl((FILEP, long int*));
|
|
static int p1getf Argdcl((FILEP, char**));
|
|
static int p1getn Argdcl((FILEP, int, char**));
|
|
static int p1gets Argdcl((FILEP, char*, int));
|
|
static void proto Argdcl((FILEP, Argtypes*, char*));
|
|
|
|
extern chainp assigned_fmts;
|
|
char filename[P1_FILENAME_MAX];
|
|
extern int gflag, sharp_line;
|
|
int gflag1;
|
|
extern char *parens;
|
|
|
|
void
|
|
start_formatting(Void)
|
|
{
|
|
FILE *infile;
|
|
static int wrote_one = 0;
|
|
extern int usedefsforcommon;
|
|
extern char *p1_file, *p1_bakfile;
|
|
|
|
this_proc_name[0] = '\0';
|
|
last_was_label = 0;
|
|
ei_next = ei_first;
|
|
wh_next = wh_first;
|
|
|
|
(void) fclose (pass1_file);
|
|
if ((infile = fopen (p1_file, binread)) == NULL)
|
|
Fatal("start_formatting: couldn't open the intermediate file\n");
|
|
|
|
if (wrote_one)
|
|
nice_printf (c_file, "\n");
|
|
|
|
while (!feof (infile)) {
|
|
expptr this_expr;
|
|
|
|
this_expr = do_format (infile, c_file);
|
|
if (this_expr) {
|
|
out_and_free_statement (c_file, this_expr);
|
|
} /* if this_expr */
|
|
} /* while !feof infile */
|
|
|
|
(void) fclose (infile);
|
|
|
|
if (last_was_label)
|
|
nice_printf (c_file, ";\n");
|
|
|
|
prev_tab (c_file);
|
|
gflag1 = sharp_line = 0;
|
|
if (this_proc_name[0])
|
|
nice_printf (c_file, "} /* %s */\n", this_proc_name);
|
|
|
|
|
|
/* Write the #undefs for common variable reference */
|
|
|
|
if (usedefsforcommon) {
|
|
Extsym *ext;
|
|
int did_one = 0;
|
|
|
|
for (ext = extsymtab; ext < nextext; ext++)
|
|
if (ext -> extstg == STGCOMMON && ext -> used_here) {
|
|
ext -> used_here = 0;
|
|
if (!did_one)
|
|
nice_printf (c_file, "\n");
|
|
wr_abbrevs(c_file, 0, ext->extp);
|
|
did_one = 1;
|
|
ext -> extp = CHNULL;
|
|
} /* if */
|
|
|
|
if (did_one)
|
|
nice_printf (c_file, "\n");
|
|
} /* if usedefsforcommon */
|
|
|
|
other_undefs(c_file);
|
|
|
|
wrote_one = 1;
|
|
|
|
/* For debugging only */
|
|
|
|
if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
|
|
if (infile = fopen (p1_file, binread)) {
|
|
ffilecopy (infile, pass1_file);
|
|
fclose (infile);
|
|
fclose (pass1_file);
|
|
} /* if infile */
|
|
|
|
/* End of "debugging only" */
|
|
|
|
scrub(p1_file); /* optionally unlink */
|
|
|
|
if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
|
|
err ("start_formatting: couldn't reopen the pass1 file");
|
|
|
|
} /* start_formatting */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
put_semi(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
put_semi(FILE *outfile)
|
|
#endif
|
|
{
|
|
nice_printf (outfile, ";\n");
|
|
last_was_label = 0;
|
|
}
|
|
|
|
#define SEM_CHECK(x) if (last_was_label) put_semi(x)
|
|
|
|
/* do_format -- takes an input stream (a file in pass1 format) and writes
|
|
the appropriate C code to outfile when possible. When reading an
|
|
expression, the expression tree is returned instead. */
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_format(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_format(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
int token_type, was_c_token;
|
|
expptr retval = ENULL;
|
|
|
|
token_type = get_p1_token (infile);
|
|
was_c_token = 1;
|
|
switch (token_type) {
|
|
case P1_COMMENT:
|
|
do_p1_comment (infile, outfile);
|
|
was_c_token = 0;
|
|
break;
|
|
case P1_SET_LINE:
|
|
do_p1_set_line (infile);
|
|
was_c_token = 0;
|
|
break;
|
|
case P1_FILENAME:
|
|
p1gets(infile, filename, P1_FILENAME_MAX);
|
|
was_c_token = 0;
|
|
break;
|
|
case P1_NAME_POINTER:
|
|
retval = do_p1_name_pointer (infile);
|
|
break;
|
|
case P1_CONST:
|
|
retval = do_p1_const (infile);
|
|
break;
|
|
case P1_EXPR:
|
|
retval = do_p1_expr (infile, outfile);
|
|
break;
|
|
case P1_IDENT:
|
|
retval = do_p1_ident(infile);
|
|
break;
|
|
case P1_CHARP:
|
|
retval = do_p1_charp(infile);
|
|
break;
|
|
case P1_EXTERN:
|
|
retval = do_p1_extern (infile);
|
|
break;
|
|
case P1_HEAD:
|
|
gflag1 = sharp_line = 0;
|
|
retval = do_p1_head (infile, outfile);
|
|
gflag1 = sharp_line = gflag;
|
|
break;
|
|
case P1_LIST:
|
|
retval = do_p1_list (infile, outfile);
|
|
break;
|
|
case P1_LITERAL:
|
|
retval = do_p1_literal (infile);
|
|
break;
|
|
case P1_LABEL:
|
|
do_p1_label (infile, outfile);
|
|
/* last_was_label = 1; -- now set in do_p1_label */
|
|
was_c_token = 0;
|
|
break;
|
|
case P1_ASGOTO:
|
|
do_p1_asgoto (infile, outfile);
|
|
break;
|
|
case P1_GOTO:
|
|
do_p1_goto (infile, outfile);
|
|
break;
|
|
case P1_IF:
|
|
do_p1_if (infile, outfile);
|
|
break;
|
|
case P1_ELSE:
|
|
SEM_CHECK(outfile);
|
|
do_p1_else (outfile);
|
|
break;
|
|
case P1_ELIF:
|
|
SEM_CHECK(outfile);
|
|
do_p1_elif (infile, outfile);
|
|
break;
|
|
case P1_ENDIF:
|
|
SEM_CHECK(outfile);
|
|
do_p1_endif (outfile);
|
|
break;
|
|
case P1_ENDELSE:
|
|
SEM_CHECK(outfile);
|
|
do_p1_endelse (outfile);
|
|
break;
|
|
case P1_ADDR:
|
|
retval = do_p1_addr (infile, outfile);
|
|
break;
|
|
case P1_SUBR_RET:
|
|
do_p1_subr_ret (infile, outfile);
|
|
break;
|
|
case P1_COMP_GOTO:
|
|
do_p1_comp_goto (infile, outfile);
|
|
break;
|
|
case P1_FOR:
|
|
do_p1_for (infile, outfile);
|
|
break;
|
|
case P1_ENDFOR:
|
|
SEM_CHECK(outfile);
|
|
do_p1_end_for (outfile);
|
|
break;
|
|
case P1_WHILE1START:
|
|
do_p1_1while(outfile);
|
|
break;
|
|
case P1_WHILE2START:
|
|
do_p1_2while(infile, outfile);
|
|
break;
|
|
case P1_PROCODE:
|
|
procode(outfile);
|
|
break;
|
|
case P1_ELSEIFSTART:
|
|
SEM_CHECK(outfile);
|
|
do_p1_elseifstart(outfile);
|
|
break;
|
|
case P1_FORTRAN:
|
|
do_p1_fortran(infile, outfile);
|
|
/* no break; */
|
|
case P1_EOF:
|
|
was_c_token = 0;
|
|
break;
|
|
case P1_UNKNOWN:
|
|
Fatal("do_format: Unknown token type in intermediate file");
|
|
break;
|
|
default:
|
|
Fatal("do_format: Bad token type in intermediate file");
|
|
break;
|
|
} /* switch */
|
|
|
|
if (was_c_token)
|
|
last_was_label = 0;
|
|
return retval;
|
|
} /* do_format */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_comment(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_comment(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
extern int 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 = sharp_line = 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 = sharp_line = gflag;
|
|
} /* do_p1_comment */
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_set_line(infile)
|
|
FILE *infile;
|
|
#else
|
|
do_p1_set_line(FILE *infile)
|
|
#endif
|
|
{
|
|
int status;
|
|
long new_line_number = -1;
|
|
|
|
status = p1getd (infile, &new_line_number);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_set_line: Missing line number at end of file\n");
|
|
else if (status == 0 || new_line_number == -1)
|
|
errl("do_p1_set_line: Illegal line number in intermediate file: %ld\n",
|
|
new_line_number);
|
|
else {
|
|
lineno = new_line_number;
|
|
}
|
|
} /* do_p1_set_line */
|
|
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_name_pointer(infile)
|
|
FILE *infile;
|
|
#else
|
|
do_p1_name_pointer(FILE *infile)
|
|
#endif
|
|
{
|
|
Namep namep = (Namep) NULL;
|
|
int status;
|
|
|
|
status = p1getd (infile, (long *) &namep);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_name_pointer: Missing pointer at end of file\n");
|
|
else if (status == 0 || namep == (Namep) NULL)
|
|
erri ("do_p1_name_pointer: Illegal name pointer in p1 file: '%x'\n",
|
|
(int) namep);
|
|
|
|
return (expptr) namep;
|
|
} /* do_p1_name_pointer */
|
|
|
|
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_const(infile)
|
|
FILE *infile;
|
|
#else
|
|
do_p1_const(FILE *infile)
|
|
#endif
|
|
{
|
|
struct Constblock *c = (struct Constblock *) NULL;
|
|
long type = -1;
|
|
int status;
|
|
|
|
status = p1getd (infile, &type);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_const: Missing constant type at end of file\n");
|
|
else if (status == 0)
|
|
errl("do_p1_const: Illegal constant type in p1 file: %ld\n", type);
|
|
else {
|
|
status = p1get_const (infile, (int)type, &c);
|
|
|
|
if (status == EOF) {
|
|
err ("do_p1_const: Missing constant value at end of file\n");
|
|
c = (struct Constblock *) NULL;
|
|
} else if (status == 0) {
|
|
err ("do_p1_const: Illegal constant value in p1 file\n");
|
|
c = (struct Constblock *) NULL;
|
|
} /* else */
|
|
} /* else */
|
|
return (expptr) c;
|
|
} /* do_p1_const */
|
|
|
|
void
|
|
#ifdef KR_headers
|
|
addrlit(addrp)
|
|
Addrp addrp;
|
|
#else
|
|
addrlit(Addrp addrp)
|
|
#endif
|
|
{
|
|
int memno = addrp->memno;
|
|
struct Literal *litp, *lastlit;
|
|
|
|
lastlit = litpool + nliterals;
|
|
for (litp = litpool; litp < lastlit; litp++)
|
|
if (litp->litnum == memno) {
|
|
addrp->vtype = litp->littype;
|
|
*((union Constant *) &(addrp->user)) =
|
|
*((union Constant *) &(litp->litval));
|
|
addrp->vstg = STGMEMNO;
|
|
return;
|
|
}
|
|
err("addrlit failure!");
|
|
}
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_literal(infile)
|
|
FILE *infile;
|
|
#else
|
|
do_p1_literal(FILE *infile)
|
|
#endif
|
|
{
|
|
int status;
|
|
long memno;
|
|
Addrp addrp;
|
|
|
|
status = p1getd (infile, &memno);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_literal: Missing memno at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_literal: Missing memno in p1 file");
|
|
else {
|
|
addrp = ALLOC (Addrblock);
|
|
addrp -> tag = TADDR;
|
|
addrp -> vtype = TYUNKNOWN;
|
|
addrp -> Field = NULL;
|
|
addrp -> memno = memno;
|
|
addrlit(addrp);
|
|
addrp -> uname_tag = UNAM_CONST;
|
|
} /* else */
|
|
|
|
return (expptr) addrp;
|
|
} /* do_p1_literal */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_label(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_label(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
int status;
|
|
ftnint stateno;
|
|
struct Labelblock *L;
|
|
char *fmt;
|
|
|
|
status = p1getd (infile, &stateno);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_label: Missing label at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_label: Missing label in p1 file ");
|
|
else if (stateno < 0) { /* entry */
|
|
margin_printf(outfile, "\n%s:\n", user_label(stateno));
|
|
last_was_label = 1;
|
|
}
|
|
else {
|
|
L = labeltab + stateno;
|
|
if (L->labused) {
|
|
fmt = "%s:\n";
|
|
last_was_label = 1;
|
|
}
|
|
else
|
|
fmt = "/* %s: */\n";
|
|
margin_printf(outfile, fmt, user_label(L->stateno));
|
|
} /* else */
|
|
} /* do_p1_label */
|
|
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_asgoto(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_asgoto(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr expr;
|
|
|
|
expr = do_format (infile, outfile);
|
|
out_asgoto (outfile, expr);
|
|
|
|
} /* do_p1_asgoto */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_goto(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_goto(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
int status;
|
|
long stateno;
|
|
|
|
status = p1getd (infile, &stateno);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_goto: Missing goto label at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_goto: Missing goto label in p1 file");
|
|
else {
|
|
nice_printf (outfile, "goto %s;\n", user_label (stateno));
|
|
} /* else */
|
|
} /* do_p1_goto */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_if(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_if(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr cond;
|
|
|
|
do {
|
|
cond = do_format (infile, outfile);
|
|
} while (cond == ENULL);
|
|
|
|
out_if (outfile, cond);
|
|
} /* do_p1_if */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_else(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_else(FILE *outfile)
|
|
#endif
|
|
{
|
|
out_else (outfile);
|
|
} /* do_p1_else */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_elif(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_elif(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr cond;
|
|
|
|
do {
|
|
cond = do_format (infile, outfile);
|
|
} while (cond == ENULL);
|
|
|
|
elif_out (outfile, cond);
|
|
} /* do_p1_elif */
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_endif(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_endif(FILE *outfile)
|
|
#endif
|
|
{
|
|
endif_out (outfile);
|
|
} /* do_p1_endif */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_endelse(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_endelse(FILE *outfile)
|
|
#endif
|
|
{
|
|
end_else_out (outfile);
|
|
} /* do_p1_endelse */
|
|
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_addr(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_addr(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
Addrp addrp = (Addrp) NULL;
|
|
int status;
|
|
|
|
status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_addr: Missing Addrp at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_addr: Missing Addrp in p1 file");
|
|
else if (addrp == (Addrp) NULL)
|
|
err ("do_p1_addr: Null addrp in p1 file");
|
|
else if (addrp -> tag != TADDR)
|
|
erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
|
|
else {
|
|
addrp -> vleng = do_format (infile, outfile);
|
|
addrp -> memoffset = do_format (infile, outfile);
|
|
}
|
|
|
|
return (expptr) addrp;
|
|
} /* do_p1_addr */
|
|
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_subr_ret(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_subr_ret(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr retval;
|
|
|
|
nice_printf (outfile, "return ");
|
|
retval = do_format (infile, outfile);
|
|
if (!multitype)
|
|
if (retval)
|
|
expr_out (outfile, retval);
|
|
|
|
nice_printf (outfile, ";\n");
|
|
} /* do_p1_subr_ret */
|
|
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_comp_goto(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_comp_goto(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr index;
|
|
expptr labels;
|
|
|
|
index = do_format (infile, outfile);
|
|
|
|
if (index == ENULL) {
|
|
err ("do_p1_comp_goto: no expression for computed goto");
|
|
return;
|
|
} /* if index == ENULL */
|
|
|
|
labels = do_format (infile, outfile);
|
|
|
|
if (labels && labels -> tag != TLIST)
|
|
erri ("do_p1_comp_goto: expected list, got tag '%d'", labels -> tag);
|
|
else
|
|
compgoto_out (outfile, index, labels);
|
|
} /* do_p1_comp_goto */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_for(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_for(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr init, test, inc;
|
|
|
|
init = do_format (infile, outfile);
|
|
test = do_format (infile, outfile);
|
|
inc = do_format (infile, outfile);
|
|
|
|
out_for (outfile, init, test, inc);
|
|
} /* do_p1_for */
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_end_for(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_end_for(FILE *outfile)
|
|
#endif
|
|
{
|
|
out_end_for (outfile);
|
|
} /* do_p1_end_for */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_fortran(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_fortran(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
char buf[P1_STMTBUFSIZE];
|
|
if (!p1gets(infile, buf, P1_STMTBUFSIZE))
|
|
return;
|
|
/* bypass nice_printf nonsense */
|
|
fprintf(outfile, "/*< %s >*/\n", buf+1); /* + 1 to skip by '$' */
|
|
}
|
|
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_expr(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_expr(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
int status;
|
|
long opcode, type;
|
|
struct Exprblock *result = (struct Exprblock *) NULL;
|
|
|
|
status = p1getd (infile, &opcode);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_expr: Missing expr opcode at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_expr: Missing expr opcode in p1 file");
|
|
else {
|
|
|
|
status = p1getd (infile, &type);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_expr: Missing expr type at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_expr: Missing expr type in p1 file");
|
|
else if (opcode == 0)
|
|
return ENULL;
|
|
else {
|
|
result = ALLOC (Exprblock);
|
|
|
|
result -> tag = TEXPR;
|
|
result -> vtype = 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
|
|
#ifdef KR_headers
|
|
do_p1_ident(infile)
|
|
FILE *infile;
|
|
#else
|
|
do_p1_ident(FILE *infile)
|
|
#endif
|
|
{
|
|
Addrp addrp;
|
|
int status;
|
|
long vtype, vstg;
|
|
|
|
addrp = ALLOC (Addrblock);
|
|
addrp -> tag = TADDR;
|
|
|
|
status = p1getd (infile, &vtype);
|
|
if (status == EOF)
|
|
err ("do_p1_ident: Missing identifier type at end of file\n");
|
|
else if (status == 0 || vtype < 0 || vtype >= NTYPES)
|
|
errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype);
|
|
else
|
|
addrp -> vtype = 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
|
|
#ifdef KR_headers
|
|
do_p1_charp(infile)
|
|
FILE *infile;
|
|
#else
|
|
do_p1_charp(FILE *infile)
|
|
#endif
|
|
{
|
|
Addrp addrp;
|
|
int status;
|
|
long vtype, vstg;
|
|
char buf[64];
|
|
|
|
addrp = ALLOC (Addrblock);
|
|
addrp -> tag = TADDR;
|
|
|
|
status = p1getd (infile, &vtype);
|
|
if (status == EOF)
|
|
err ("do_p1_ident: Missing identifier type at end of file\n");
|
|
else if (status == 0 || vtype < 0 || vtype >= NTYPES)
|
|
errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype);
|
|
else
|
|
addrp -> vtype = 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
|
|
#ifdef KR_headers
|
|
do_p1_extern(infile)
|
|
FILE *infile;
|
|
#else
|
|
do_p1_extern(FILE *infile)
|
|
#endif
|
|
{
|
|
Addrp addrp;
|
|
|
|
addrp = ALLOC (Addrblock);
|
|
if (addrp) {
|
|
int status;
|
|
|
|
addrp->tag = TADDR;
|
|
addrp->vstg = STGEXT;
|
|
addrp->uname_tag = UNAM_EXTERN;
|
|
status = p1getd (infile, &(addrp -> memno));
|
|
if (status == EOF)
|
|
err ("do_p1_extern: Missing memno at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_extern: Missing memno in intermediate file");
|
|
if (addrp->vtype = extsymtab[addrp->memno].extype)
|
|
addrp->vclass = CLPROC;
|
|
} /* if addrp */
|
|
|
|
return (expptr) addrp;
|
|
} /* do_p1_extern */
|
|
|
|
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_head(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_head(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
int status;
|
|
int add_n_;
|
|
long class;
|
|
char storage[256];
|
|
|
|
status = p1getd (infile, &class);
|
|
if (status == EOF)
|
|
err ("do_p1_head: missing header class at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_head: missing header class in p1 file");
|
|
else {
|
|
status = p1gets (infile, storage, (int)sizeof(storage));
|
|
if (status == EOF || status == 0)
|
|
storage[0] = '\0';
|
|
} /* else */
|
|
|
|
if (class == CLPROC || class == CLMAIN) {
|
|
chainp lengths;
|
|
|
|
add_n_ = nentry > 1;
|
|
lengths = length_comp(entries, add_n_);
|
|
|
|
if (!add_n_ && protofile && class != CLMAIN)
|
|
protowrite(protofile, proctype, storage, entries, lengths);
|
|
|
|
if (class == CLMAIN)
|
|
nice_printf (outfile, "/* Main program */ ");
|
|
else
|
|
nice_printf(outfile, "%s ", multitype ? "VOID"
|
|
: c_type_decl(proctype, 1));
|
|
|
|
nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
|
|
if (!Ansi) {
|
|
listargs(outfile, entries, add_n_, lengths);
|
|
nice_printf (outfile, "\n");
|
|
}
|
|
list_arg_types (outfile, entries, lengths, add_n_, "\n");
|
|
nice_printf (outfile, "{\n");
|
|
frchain(&lengths);
|
|
next_tab (outfile);
|
|
strcpy(this_proc_name, storage);
|
|
list_decls (outfile);
|
|
|
|
} else if (class == CLBLOCK)
|
|
next_tab (outfile);
|
|
else
|
|
errl("do_p1_head: got class %ld", class);
|
|
|
|
return NULL;
|
|
} /* do_p1_head */
|
|
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_list(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_list(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
long tag, type, count;
|
|
int status;
|
|
expptr result;
|
|
|
|
status = p1getd (infile, &tag);
|
|
if (status == EOF)
|
|
err ("do_p1_list: missing list tag at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_list: missing list tag in p1 file");
|
|
else {
|
|
status = p1getd (infile, &type);
|
|
if (status == EOF)
|
|
err ("do_p1_list: missing list type at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_list: missing list type in p1 file");
|
|
else {
|
|
status = p1getd (infile, &count);
|
|
if (status == EOF)
|
|
err ("do_p1_list: missing count at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_list: missing count in p1 file");
|
|
} /* else */
|
|
} /* else */
|
|
|
|
result = (expptr) ALLOC (Listblock);
|
|
if (result) {
|
|
chainp pointer;
|
|
|
|
result -> tag = 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
|
|
#ifdef KR_headers
|
|
length_comp(e, add_n)
|
|
struct Entrypoint *e;
|
|
int add_n;
|
|
#else
|
|
length_comp(struct Entrypoint *e, int add_n)
|
|
#endif
|
|
/* get lengths of characters args */
|
|
{
|
|
chainp lengths;
|
|
chainp args, args1;
|
|
Namep arg, np;
|
|
int nchargs;
|
|
Argtypes *at;
|
|
Atype *a;
|
|
extern int init_ac[TYSUBR+1];
|
|
|
|
if (!e)
|
|
return 0; /* possible only with errors */
|
|
args = args1 = add_n ? allargs : e->arglist;
|
|
nchargs = 0;
|
|
for (lengths = NULL; args; args = args -> nextp)
|
|
if (arg = (Namep)args->datap) {
|
|
if (arg->vclass == CLUNKNOWN)
|
|
arg->vclass = CLVAR;
|
|
if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
|
|
lengths = mkchain((char *)arg, lengths);
|
|
nchargs++;
|
|
}
|
|
}
|
|
if (!add_n && (np = e->enamep)) {
|
|
/* one last check -- by now we know all we ever will
|
|
* about external args...
|
|
*/
|
|
save_argtypes(e->arglist, &e->entryname->arginfo,
|
|
&np->arginfo, 0, np->fvarname, STGEXT, nchargs,
|
|
np->vtype, 1);
|
|
at = e->entryname->arginfo;
|
|
a = at->atypes + init_ac[np->vtype];
|
|
for(; args1; a++, args1 = args1->nextp) {
|
|
frchain(&a->cp);
|
|
if (arg = (Namep)args1->datap)
|
|
switch(arg->vclass) {
|
|
case CLPROC:
|
|
if (arg->vimpltype
|
|
&& a->type >= 300)
|
|
a->type = TYUNKNOWN + 200;
|
|
break;
|
|
case CLUNKNOWN:
|
|
a->type %= 100;
|
|
}
|
|
}
|
|
}
|
|
return revchain(lengths);
|
|
}
|
|
|
|
void
|
|
#ifdef KR_headers
|
|
listargs(outfile, entryp, add_n_, lengths)
|
|
FILE *outfile;
|
|
struct Entrypoint *entryp;
|
|
int add_n_;
|
|
chainp lengths;
|
|
#else
|
|
listargs(FILE *outfile, struct Entrypoint *entryp, int add_n_, chainp lengths)
|
|
#endif
|
|
{
|
|
chainp args;
|
|
char *s;
|
|
Namep arg;
|
|
int did_one = 0;
|
|
|
|
nice_printf (outfile, "(");
|
|
|
|
if (add_n_) {
|
|
nice_printf(outfile, "n__");
|
|
did_one = 1;
|
|
args = allargs;
|
|
}
|
|
else {
|
|
if (!entryp)
|
|
return; /* possible only with errors */
|
|
args = entryp->arglist;
|
|
}
|
|
|
|
if (multitype)
|
|
{
|
|
nice_printf(outfile, ", ret_val");
|
|
did_one = 1;
|
|
args = allargs;
|
|
}
|
|
else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
|
|
{
|
|
s = xretslot[proctype]->user.ident;
|
|
nice_printf(outfile, did_one ? ", %s" : "%s",
|
|
*s == '(' /*)*/ ? "r_v" : s);
|
|
did_one = 1;
|
|
if (proctype == TYCHAR)
|
|
nice_printf (outfile, ", ret_val_len");
|
|
}
|
|
for (; args; args = args -> nextp)
|
|
if (arg = (Namep)args->datap) {
|
|
nice_printf (outfile, "%s", did_one ? ", " : "");
|
|
out_name (outfile, arg);
|
|
did_one = 1;
|
|
}
|
|
|
|
for (args = lengths; args; args = args -> nextp)
|
|
nice_printf(outfile, ", %s",
|
|
new_arg_length((Namep)args->datap));
|
|
nice_printf (outfile, ")");
|
|
} /* listargs */
|
|
|
|
|
|
void
|
|
#ifdef KR_headers
|
|
list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
|
|
FILE *outfile;
|
|
struct Entrypoint *entryp;
|
|
chainp lengths;
|
|
int add_n_;
|
|
char *finalnl;
|
|
#else
|
|
list_arg_types(FILE *outfile, struct Entrypoint *entryp, chainp lengths, int add_n_, char *finalnl)
|
|
#endif
|
|
{
|
|
chainp args;
|
|
int last_type = -1, last_class = -1;
|
|
int did_one = 0, done_one, is_ext;
|
|
char *s, *sep = "", *sep1;
|
|
|
|
if (outfile == (FILE *) NULL) {
|
|
err ("list_arg_types: null output file");
|
|
return;
|
|
} else if (entryp == (struct Entrypoint *) NULL) {
|
|
err ("list_arg_types: null procedure entry pointer");
|
|
return;
|
|
} /* else */
|
|
|
|
if (Ansi) {
|
|
done_one = 0;
|
|
sep1 = ", ";
|
|
nice_printf(outfile, "(" /*)*/);
|
|
}
|
|
else {
|
|
done_one = 1;
|
|
sep1 = ";\n";
|
|
}
|
|
args = entryp->arglist;
|
|
if (add_n_) {
|
|
nice_printf(outfile, "int n__");
|
|
did_one = done_one;
|
|
sep = sep1;
|
|
args = allargs;
|
|
}
|
|
if (multitype) {
|
|
nice_printf(outfile, "%sMultitype *ret_val", sep);
|
|
did_one = done_one;
|
|
sep = sep1;
|
|
}
|
|
else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
|
|
s = xretslot[proctype]->user.ident;
|
|
nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
|
|
*s == '(' /*)*/ ? "r_v" : s);
|
|
did_one = done_one;
|
|
sep = sep1;
|
|
if (proctype == TYCHAR)
|
|
nice_printf (outfile, "%sftnlen ret_val_len", sep);
|
|
} /* if ONEOF proctype */
|
|
for (; args; args = args -> nextp) {
|
|
Namep arg = (Namep) args->datap;
|
|
|
|
/* Scalars are passed by reference, and arrays will have their lower bound
|
|
adjusted, so nearly everything is printed with a star in front. The
|
|
exception is character lengths, which are passed by value. */
|
|
|
|
if (arg) {
|
|
int type = arg -> vtype, 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
|
|
#ifdef KR_headers
|
|
write_formats(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
write_formats(FILE *outfile)
|
|
#endif
|
|
{
|
|
register struct Labelblock *lp;
|
|
int first = 1;
|
|
char *fs;
|
|
|
|
for(lp = labeltab ; lp < highlabtab ; ++lp)
|
|
if (lp->fmtlabused) {
|
|
if (first) {
|
|
first = 0;
|
|
nice_printf(outfile, "/* Format strings */\n");
|
|
}
|
|
nice_printf(outfile, "static char fmt_%ld[] = \"",
|
|
lp->stateno);
|
|
if (!(fs = lp->fmtstring))
|
|
fs = "";
|
|
nice_printf(outfile, "%s\";\n", fs);
|
|
}
|
|
if (!first)
|
|
nice_printf(outfile, "\n");
|
|
}
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
write_ioblocks(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
write_ioblocks(FILE *outfile)
|
|
#endif
|
|
{
|
|
register iob_data *L;
|
|
register char *f, **s, *sep;
|
|
|
|
nice_printf(outfile, "/* Fortran I/O blocks */\n");
|
|
L = iob_list = (iob_data *)revchain((chainp)iob_list);
|
|
do {
|
|
nice_printf(outfile, "static %s %s = { ",
|
|
L->type, L->name);
|
|
sep = 0;
|
|
for(s = L->fields; f = *s; s++) {
|
|
if (sep)
|
|
nice_printf(outfile, sep);
|
|
sep = ", ";
|
|
if (*f == '"') { /* kludge */
|
|
nice_printf(outfile, "\"");
|
|
nice_printf(outfile, "%s\"", f+1);
|
|
}
|
|
else
|
|
nice_printf(outfile, "%s", f);
|
|
}
|
|
nice_printf(outfile, " };\n");
|
|
}
|
|
while(L = L->next);
|
|
nice_printf(outfile, "\n\n");
|
|
}
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
write_assigned_fmts(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
write_assigned_fmts(FILE *outfile)
|
|
#endif
|
|
{
|
|
register chainp cp;
|
|
Namep np;
|
|
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 *
|
|
#ifdef KR_headers
|
|
to_upper(s)
|
|
register char *s;
|
|
#else
|
|
to_upper(register char *s)
|
|
#endif
|
|
{
|
|
static char buf[64];
|
|
register char *t = buf;
|
|
register int c;
|
|
while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
|
|
return buf;
|
|
}
|
|
|
|
|
|
/* This routine creates static structures representing a namelist.
|
|
Declarations of the namelist and related structures are:
|
|
|
|
struct Vardesc {
|
|
char *name;
|
|
char *addr;
|
|
ftnlen *dims; /* laid out as struct dimensions below *//*
|
|
int type;
|
|
};
|
|
typedef struct Vardesc Vardesc;
|
|
|
|
struct Namelist {
|
|
char *name;
|
|
Vardesc **vars;
|
|
int nvars;
|
|
};
|
|
|
|
struct dimensions
|
|
{
|
|
ftnlen numberofdimensions;
|
|
ftnlen numberofelements
|
|
ftnlen baseoffset;
|
|
ftnlen span[numberofdimensions-1];
|
|
};
|
|
|
|
If dims is not null, then the corner element of the array is at
|
|
addr. However, the element with subscripts (i1,...,in) is at
|
|
addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
|
|
*/
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
write_namelists(nmch, outfile)
|
|
chainp nmch;
|
|
FILE *outfile;
|
|
#else
|
|
write_namelists(chainp nmch, FILE *outfile)
|
|
#endif
|
|
{
|
|
Namep var;
|
|
struct Hashentry *entry;
|
|
struct Dimblock *dimp;
|
|
int i, nd, type;
|
|
char *comma, *name;
|
|
register chainp q;
|
|
register Namep v;
|
|
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
|
|
#ifdef KR_headers
|
|
fixexttype(var)
|
|
Namep var;
|
|
#else
|
|
fixexttype(Namep var)
|
|
#endif
|
|
{
|
|
Extsym *e;
|
|
int type, type1;
|
|
|
|
type = var->vtype;
|
|
e = &extsymtab[var->vardesc.varno];
|
|
if ((type1 = e->extype) && type == TYUNKNOWN)
|
|
return var->vtype = type1;
|
|
if (var->visused) {
|
|
if (e->exused && type != type1)
|
|
changedtype(var);
|
|
e->exused = 1;
|
|
e->extype = type;
|
|
}
|
|
return type;
|
|
}
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
ref_defs(outfile, refdefs)
|
|
FILE *outfile;
|
|
chainp refdefs;
|
|
#else
|
|
ref_defs(FILE *outfile, chainp refdefs)
|
|
#endif
|
|
{
|
|
chainp cp;
|
|
int eb, i, j, n;
|
|
struct Dimblock *dimp;
|
|
expptr b, vl;
|
|
Namep var;
|
|
char *amp, *comma;
|
|
|
|
margin_printf(outfile, "\n");
|
|
for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) {
|
|
var = (Namep)cp->datap;
|
|
cp->datap = 0;
|
|
amp = "_subscr";
|
|
if (!(eb = var->vsubscrused)) {
|
|
var->vrefused = 0;
|
|
if (!ISCOMPLEX(var->vtype))
|
|
amp = "_ref";
|
|
}
|
|
def_start(outfile, var->cvarname, amp, CNULL);
|
|
dimp = var->vdim;
|
|
vl = 0;
|
|
comma = "(";
|
|
amp = "";
|
|
if (var->vtype == TYCHAR) {
|
|
amp = "&";
|
|
vl = var->vleng;
|
|
if (ISCONST(vl) && vl->constblock.Const.ci == 1)
|
|
vl = 0;
|
|
nice_printf(outfile, "%sa_0", comma);
|
|
comma = ",";
|
|
}
|
|
n = dimp->ndim;
|
|
for(i = 1; i <= n; i++, comma = ",")
|
|
nice_printf(outfile, "%sa_%d", comma, i);
|
|
nice_printf(outfile, ") %s", amp);
|
|
if (var->vsubscrused)
|
|
var->vsubscrused = 0;
|
|
else if (!ISCOMPLEX(var->vtype)) {
|
|
out_name(outfile, var);
|
|
nice_printf(outfile, "[%s", vl ? "(" : "");
|
|
}
|
|
for(j = 2; j < n; j++)
|
|
nice_printf(outfile, "(");
|
|
while(--i > 1) {
|
|
nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")");
|
|
expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize));
|
|
nice_printf(outfile, " + ");
|
|
}
|
|
nice_printf(outfile, "a_1");
|
|
if (var->vtype == TYCHAR) {
|
|
if (vl) {
|
|
nice_printf(outfile, ")*");
|
|
expr_out(outfile, cpexpr(vl));
|
|
}
|
|
nice_printf(outfile, " + a_0");
|
|
}
|
|
if ((var->vstg != STGARG /* || checksubs */ )
|
|
&& (b = dimp->baseoffset)) {
|
|
b = cpexpr(b);
|
|
if (var->vtype == TYCHAR)
|
|
b = mkexpr(OPSTAR, cpexpr(var->vleng), b);
|
|
nice_printf(outfile, " - ");
|
|
expr_out(outfile, b);
|
|
}
|
|
if (ISCOMPLEX(var->vtype)) {
|
|
margin_printf(outfile, "\n");
|
|
def_start(outfile, var->cvarname, "_ref", CNULL);
|
|
comma = "(";
|
|
for(i = 1; i <= n; i++, comma = ",")
|
|
nice_printf(outfile, "%sa_%d", comma, i);
|
|
nice_printf(outfile, ") %s[%s_subscr",
|
|
var->cvarname, var->cvarname);
|
|
comma = "(";
|
|
for(i = 1; i <= n; i++, comma = ",")
|
|
nice_printf(outfile, "%sa_%d", comma, i);
|
|
nice_printf(outfile, ")");
|
|
}
|
|
margin_printf(outfile, "]\n" + eb);
|
|
}
|
|
nice_printf(outfile, "\n");
|
|
frchain(&refdefs);
|
|
}
|
|
|
|
void
|
|
#ifdef KR_headers
|
|
list_decls(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
list_decls(FILE *outfile)
|
|
#endif
|
|
{
|
|
extern chainp used_builtins;
|
|
extern struct Hashentry *hashtab;
|
|
struct Hashentry *entry;
|
|
int write_header = 1;
|
|
int last_class = -1, last_stg = -1;
|
|
Namep var;
|
|
int Alias, Define, did_one, last_type, 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);
|
|
margin_printf(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;
|
|
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) {
|
|
margin_printf(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 */
|
|
|
|
void
|
|
#ifdef KR_headers
|
|
do_uninit_equivs(outfile, did_one)
|
|
FILE *outfile;
|
|
int *did_one;
|
|
#else
|
|
do_uninit_equivs(FILE *outfile, int *did_one)
|
|
#endif
|
|
{
|
|
extern int nequiv;
|
|
struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
|
|
int k, last_type = -1, t;
|
|
|
|
for (eqv = eqvclass; eqv < lasteqv; eqv++)
|
|
if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
|
|
if (!*did_one)
|
|
nice_printf (outfile, "/* System generated locals */\n");
|
|
t = eqv->eqvtype;
|
|
if (last_type == t)
|
|
nice_printf (outfile, ", ");
|
|
else {
|
|
if (*did_one)
|
|
nice_printf (outfile, ";\n");
|
|
nice_printf (outfile, "static %s ", c_type_decl(t, 0));
|
|
k = typesize[t];
|
|
} /* else */
|
|
nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
|
|
nice_printf(outfile, "[%ld]",
|
|
(eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
|
|
last_type = t;
|
|
*did_one = 1;
|
|
} /* if !eqv -> eqvinit */
|
|
} /* do_uninit_equivs */
|
|
|
|
|
|
/* wr_ardecls -- Writes the brackets and size for an array
|
|
declaration. Because of the inner workings of the compiler,
|
|
multi-dimensional arrays get mapped directly into a one-dimensional
|
|
array, so we have to compute the size of the array here. When the
|
|
dimension is greater than 1, a string comment about the original size
|
|
is returned */
|
|
|
|
char *
|
|
#ifdef KR_headers
|
|
wr_ardecls(outfile, dimp, size)
|
|
FILE *outfile;
|
|
struct Dimblock *dimp;
|
|
long size;
|
|
#else
|
|
wr_ardecls(FILE *outfile, struct Dimblock *dimp, long size)
|
|
#endif
|
|
{
|
|
int i, k;
|
|
ftnint j;
|
|
static char buf[1000];
|
|
|
|
if (dimp == (struct Dimblock *) NULL)
|
|
return NULL;
|
|
|
|
sprintf(buf, "\t/* was "); /* would like to say k = sprintf(...), but */
|
|
k = strlen(buf); /* BSD doesn't return char transmitted count */
|
|
|
|
for (i = 0; i < dimp -> ndim; i++) {
|
|
expptr this_size = dimp -> dims[i].dimsize;
|
|
|
|
if (ISCONST(this_size)) {
|
|
if (ISINT(this_size->constblock.vtype))
|
|
j = this_size -> constblock.Const.ci;
|
|
else if (ISREAL(this_size->constblock.vtype))
|
|
j = (ftnint)this_size -> constblock.Const.cd[0];
|
|
else
|
|
goto non_const;
|
|
size *= j;
|
|
sprintf(buf+k, "[%ld]", j);
|
|
k += strlen(buf+k);
|
|
/* BSD prevents getting strlen from sprintf */
|
|
}
|
|
else {
|
|
non_const:
|
|
err ("wr_ardecls: nonconstant array size");
|
|
}
|
|
} /* for i = 0 */
|
|
|
|
nice_printf (outfile, "[%ld]", size);
|
|
strcat(buf+k, " */");
|
|
|
|
return (i > 1) ? buf : NULL;
|
|
} /* wr_ardecls */
|
|
|
|
|
|
|
|
/* ----------------------------------------------------------------------
|
|
|
|
The following routines read from the p1 intermediate file. If
|
|
that format changes, only these routines need be changed
|
|
|
|
---------------------------------------------------------------------- */
|
|
|
|
static int
|
|
#ifdef KR_headers
|
|
get_p1_token(infile)
|
|
FILE *infile;
|
|
#else
|
|
get_p1_token(FILE *infile)
|
|
#endif
|
|
{
|
|
int token = P1_UNKNOWN;
|
|
|
|
/* NOT PORTABLE!! */
|
|
|
|
if (fscanf (infile, "%d", &token) == EOF)
|
|
return P1_EOF;
|
|
|
|
/* Skip over the ": " */
|
|
|
|
if (getc (infile) != '\n')
|
|
getc (infile);
|
|
|
|
return token;
|
|
} /* get_p1_token */
|
|
|
|
|
|
|
|
/* Returns a (null terminated) string from the input file */
|
|
|
|
static int
|
|
#ifdef KR_headers
|
|
p1gets(fp, str, size)
|
|
FILE *fp;
|
|
char *str;
|
|
int size;
|
|
#else
|
|
p1gets(FILE *fp, char *str, int size)
|
|
#endif
|
|
{
|
|
char c;
|
|
|
|
if (str == NULL)
|
|
return 0;
|
|
|
|
if ((c = getc (fp)) != ' ')
|
|
ungetc (c, fp);
|
|
|
|
if (fgets (str, size, fp)) {
|
|
int length;
|
|
|
|
str[size - 1] = '\0';
|
|
length = strlen (str);
|
|
|
|
/* Get rid of the newline */
|
|
|
|
if (str[length - 1] == '\n')
|
|
str[length - 1] = '\0';
|
|
return 1;
|
|
|
|
} else if (feof (fp))
|
|
return EOF;
|
|
else
|
|
return 0;
|
|
} /* p1gets */
|
|
|
|
|
|
static int
|
|
#ifdef KR_headers
|
|
p1get_const(infile, type, resultp)
|
|
FILE *infile;
|
|
int type;
|
|
struct Constblock **resultp;
|
|
#else
|
|
p1get_const(FILE *infile, int type, struct Constblock **resultp)
|
|
#endif
|
|
{
|
|
int status;
|
|
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
|
|
#ifdef KR_headers
|
|
p1getd(infile, result)
|
|
FILE *infile;
|
|
long *result;
|
|
#else
|
|
p1getd(FILE *infile, long *result)
|
|
#endif
|
|
{
|
|
return fscanf (infile, "%ld", result);
|
|
} /* p1getd */
|
|
|
|
static int
|
|
#ifdef KR_headers
|
|
p1getf(infile, result)
|
|
FILE *infile;
|
|
char **result;
|
|
#else
|
|
p1getf(FILE *infile, char **result)
|
|
#endif
|
|
{
|
|
|
|
char buf[1324];
|
|
register int k;
|
|
|
|
k = fscanf (infile, "%s", buf);
|
|
if (k < 1)
|
|
k = EOF;
|
|
else
|
|
strcpy(*result = mem(strlen(buf)+1,0), buf);
|
|
return k;
|
|
}
|
|
|
|
static int
|
|
#ifdef KR_headers
|
|
p1getn(infile, count, result)
|
|
FILE *infile;
|
|
int count;
|
|
char **result;
|
|
#else
|
|
p1getn(FILE *infile, int count, char **result)
|
|
#endif
|
|
{
|
|
|
|
char *bufptr;
|
|
|
|
bufptr = (char *) ckalloc (count);
|
|
|
|
if (result)
|
|
*result = bufptr;
|
|
|
|
for (; !feof (infile) && count > 0; count--)
|
|
*bufptr++ = getc (infile);
|
|
|
|
return feof (infile) ? EOF : 1;
|
|
} /* p1getn */
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
proto(outfile, at, fname)
|
|
FILE *outfile;
|
|
Argtypes *at;
|
|
char *fname;
|
|
#else
|
|
proto(FILE *outfile, Argtypes *at, char *fname)
|
|
#endif
|
|
{
|
|
int i, j, k, n;
|
|
char *comma;
|
|
Atype *atypes;
|
|
Namep np;
|
|
chainp cp;
|
|
|
|
if (at) {
|
|
/* Correct types that we learn on the fly, e.g.
|
|
subroutine gotcha(foo)
|
|
external foo
|
|
call zap(...,foo,...)
|
|
call foo(...)
|
|
*/
|
|
atypes = at->atypes;
|
|
n = at->defined ? at->dnargs : at->nargs;
|
|
for(i = 0; i++ < n; atypes++) {
|
|
if (!(cp = atypes->cp))
|
|
continue;
|
|
j = atypes->type;
|
|
do {
|
|
np = (Namep)cp->datap;
|
|
k = np->vtype;
|
|
if (np->vclass == CLPROC) {
|
|
if (!np->vimpltype && k)
|
|
k += 200;
|
|
else {
|
|
if (j >= 300)
|
|
j = TYUNKNOWN + 200;
|
|
continue;
|
|
}
|
|
}
|
|
if (j == k)
|
|
continue;
|
|
if (j >= 300
|
|
|| j == 200 && k >= 200)
|
|
j = k;
|
|
else {
|
|
if (at->nargs >= 0)
|
|
bad_atypes(at,fname,i,j,k,""," and");
|
|
goto break2;
|
|
}
|
|
}
|
|
while(cp = cp->nextp);
|
|
atypes->type = j;
|
|
frchain(&atypes->cp);
|
|
}
|
|
}
|
|
break2:
|
|
if (parens) {
|
|
nice_printf(outfile, parens);
|
|
return;
|
|
}
|
|
|
|
if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) {
|
|
nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
|
|
return;
|
|
}
|
|
|
|
if (n == 0) {
|
|
nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
|
|
return;
|
|
}
|
|
|
|
atypes = at->atypes;
|
|
nice_printf(outfile, "(");
|
|
comma = "";
|
|
for(; --n >= 0; atypes++) {
|
|
k = atypes->type;
|
|
if (k == TYADDR)
|
|
nice_printf(outfile, "%schar **", comma);
|
|
else if (k >= 200) {
|
|
k -= 200;
|
|
nice_printf(outfile, "%s%s", comma,
|
|
usedcasts[k] = casttypes[k]);
|
|
}
|
|
else if (k >= 100)
|
|
nice_printf(outfile,
|
|
k == TYCHAR + 100 ? "%s%s *" : "%s%s",
|
|
comma, c_type_decl(k-100, 0));
|
|
else
|
|
nice_printf(outfile, "%s%s *", comma,
|
|
c_type_decl(k, 0));
|
|
comma = ", ";
|
|
}
|
|
nice_printf(outfile, ")");
|
|
}
|
|
|
|
void
|
|
#ifdef KR_headers
|
|
protowrite(protofile, type, name, e, lengths)
|
|
FILE *protofile;
|
|
int type;
|
|
char *name;
|
|
struct Entrypoint *e;
|
|
chainp lengths;
|
|
#else
|
|
protowrite(FILE *protofile, int type, char *name, struct Entrypoint *e, chainp lengths)
|
|
#endif
|
|
{
|
|
extern char used_rets[];
|
|
int asave;
|
|
|
|
if (!(asave = Ansi))
|
|
Castargs = Ansi = 1;
|
|
nice_printf(protofile, "extern %s %s", protorettypes[type], name);
|
|
list_arg_types(protofile, e, lengths, 0, ";\n");
|
|
used_rets[type] = 1;
|
|
if (!(Ansi = asave))
|
|
Castargs = 0;
|
|
}
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_1while(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_1while(FILE *outfile)
|
|
#endif
|
|
{
|
|
if (*wh_next) {
|
|
nice_printf(outfile,
|
|
"for(;;) { /* while(complicated condition) */\n" /*}*/ );
|
|
next_tab(outfile);
|
|
}
|
|
else
|
|
nice_printf(outfile, "while(" /*)*/ );
|
|
}
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_2while(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_2while(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr test;
|
|
|
|
test = do_format(infile, outfile);
|
|
if (*wh_next)
|
|
nice_printf(outfile, "if (!(");
|
|
expr_out(outfile, test);
|
|
if (*wh_next++)
|
|
nice_printf(outfile, "))\n\tbreak;\n");
|
|
else {
|
|
nice_printf(outfile, /*(*/ ") {\n");
|
|
next_tab(outfile);
|
|
}
|
|
}
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_elseifstart(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_elseifstart(FILE *outfile)
|
|
#endif
|
|
{
|
|
if (*ei_next++) {
|
|
prev_tab(outfile);
|
|
nice_printf(outfile, /*{*/
|
|
"} else /* if(complicated condition) */ {\n" /*}*/ );
|
|
next_tab(outfile);
|
|
}
|
|
}
|