mirror of
https://github.com/freebsd/freebsd-src
synced 2024-11-05 18:22:52 +00:00
c3ad4b4583
the function naming problem for complex double function i've recently aksed for in -committers. (The recently committed rev 1.5 of proc.c was actually also part of this update.) Should the mailing lists come to an agreement that f2c better belongs into the ports, this could be done nevertheless. For the time being, we've at least got a current version now. Thanks, Steve! Submitted by: Steve Kargl <sgk@troutmask.apl.washington.edu>
2523 lines
56 KiB
C
2523 lines
56 KiB
C
/****************************************************************
|
|
Copyright 1990 - 1996 by AT&T, Lucent Technologies and Bellcore.
|
|
|
|
Permission to use, copy, modify, and distribute this software
|
|
and its documentation for any purpose and without fee is hereby
|
|
granted, provided that the above copyright notice appear in all
|
|
copies and that both that the copyright notice and this
|
|
permission notice and warranty disclaimer appear in supporting
|
|
documentation, and that the names of AT&T, Bell Laboratories,
|
|
Lucent or Bellcore or any of their entities not be used in
|
|
advertising or publicity pertaining to distribution of the
|
|
software without specific, written prior permission.
|
|
|
|
AT&T, Lucent and Bellcore disclaim all warranties with regard to
|
|
this software, including all implied warranties of
|
|
merchantability and fitness. In no event shall AT&T, Lucent or
|
|
Bellcore be liable for any special, indirect or consequential
|
|
damages or any damages whatsoever resulting from loss of use,
|
|
data or profits, whether in an action of contract, negligence or
|
|
other tortious action, arising out of or in connection with the
|
|
use or performance of this software.
|
|
****************************************************************/
|
|
|
|
/* Format.c -- this file takes an intermediate file (generated by pass 1
|
|
of the translator) and some state information about the contents of that
|
|
file, and generates C program text. */
|
|
|
|
#include "defs.h"
|
|
#include "p1defs.h"
|
|
#include "format.h"
|
|
#include "output.h"
|
|
#include "names.h"
|
|
#include "iob.h"
|
|
|
|
int c_output_line_length = DEF_C_LINE_LENGTH;
|
|
|
|
int last_was_label; /* Boolean used to generate semicolons
|
|
when a label terminates a block */
|
|
static char this_proc_name[52]; /* Name of the current procedure. This is
|
|
probably too simplistic to handle
|
|
multiple entry points */
|
|
|
|
static tagptr do_format Argdcl((FILEP, FILEP));
|
|
static void do_p1_1while Argdcl((FILEP));
|
|
static void do_p1_2while Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_addr Argdcl((FILEP, FILEP));
|
|
static void do_p1_asgoto Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_charp Argdcl((FILEP));
|
|
static void do_p1_comment Argdcl((FILEP, FILEP));
|
|
static void do_p1_comp_goto Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_const Argdcl((FILEP));
|
|
static void do_p1_elif Argdcl((FILEP, FILEP));
|
|
static void do_p1_else Argdcl((FILEP));
|
|
static void do_p1_elseifstart Argdcl((FILEP));
|
|
static void do_p1_end_for Argdcl((FILEP));
|
|
static void do_p1_endelse Argdcl((FILEP));
|
|
static void do_p1_endif Argdcl((FILEP));
|
|
static tagptr do_p1_expr Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_extern Argdcl((FILEP));
|
|
static void do_p1_for Argdcl((FILEP, FILEP));
|
|
static void do_p1_fortran Argdcl((FILEP, FILEP));
|
|
static void do_p1_goto Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_head Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_ident Argdcl((FILEP));
|
|
static void do_p1_if Argdcl((FILEP, FILEP));
|
|
static void do_p1_label Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_list Argdcl((FILEP, FILEP));
|
|
static tagptr do_p1_literal Argdcl((FILEP));
|
|
static tagptr do_p1_name_pointer Argdcl((FILEP));
|
|
static void do_p1_set_line Argdcl((FILEP));
|
|
static void do_p1_subr_ret Argdcl((FILEP, FILEP));
|
|
static int get_p1_token Argdcl((FILEP));
|
|
static int p1get_const Argdcl((FILEP, int, Constp*));
|
|
static int p1getd Argdcl((FILEP, long int*));
|
|
static int p1getf Argdcl((FILEP, char**));
|
|
static int p1getn Argdcl((FILEP, int, char**));
|
|
static int p1gets Argdcl((FILEP, char*, int));
|
|
static void proto Argdcl((FILEP, Argtypes*, char*));
|
|
|
|
extern chainp assigned_fmts;
|
|
char filename[P1_FILENAME_MAX];
|
|
extern int gflag, sharp_line;
|
|
int gflag1;
|
|
extern char *parens;
|
|
|
|
void
|
|
start_formatting(Void)
|
|
{
|
|
FILE *infile;
|
|
static int wrote_one = 0;
|
|
extern int usedefsforcommon;
|
|
extern char *p1_file, *p1_bakfile;
|
|
|
|
this_proc_name[0] = '\0';
|
|
last_was_label = 0;
|
|
ei_next = ei_first;
|
|
wh_next = wh_first;
|
|
|
|
(void) fclose (pass1_file);
|
|
if ((infile = fopen (p1_file, binread)) == NULL)
|
|
Fatal("start_formatting: couldn't open the intermediate file\n");
|
|
|
|
if (wrote_one)
|
|
nice_printf (c_file, "\n");
|
|
|
|
while (!feof (infile)) {
|
|
expptr this_expr;
|
|
|
|
this_expr = do_format (infile, c_file);
|
|
if (this_expr) {
|
|
out_and_free_statement (c_file, this_expr);
|
|
} /* if this_expr */
|
|
} /* while !feof infile */
|
|
|
|
(void) fclose (infile);
|
|
|
|
if (last_was_label)
|
|
nice_printf (c_file, ";\n");
|
|
|
|
prev_tab (c_file);
|
|
gflag1 = sharp_line = 0;
|
|
if (this_proc_name[0])
|
|
nice_printf (c_file, "} /* %s */\n", this_proc_name);
|
|
|
|
|
|
/* Write the #undefs for common variable reference */
|
|
|
|
if (usedefsforcommon) {
|
|
Extsym *ext;
|
|
int did_one = 0;
|
|
|
|
for (ext = extsymtab; ext < nextext; ext++)
|
|
if (ext -> extstg == STGCOMMON && ext -> used_here) {
|
|
ext -> used_here = 0;
|
|
if (!did_one)
|
|
nice_printf (c_file, "\n");
|
|
wr_abbrevs(c_file, 0, ext->extp);
|
|
did_one = 1;
|
|
ext -> extp = CHNULL;
|
|
} /* if */
|
|
|
|
if (did_one)
|
|
nice_printf (c_file, "\n");
|
|
} /* if usedefsforcommon */
|
|
|
|
other_undefs(c_file);
|
|
|
|
wrote_one = 1;
|
|
|
|
/* For debugging only */
|
|
|
|
if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
|
|
if (infile = fopen (p1_file, binread)) {
|
|
ffilecopy (infile, pass1_file);
|
|
fclose (infile);
|
|
fclose (pass1_file);
|
|
} /* if infile */
|
|
|
|
/* End of "debugging only" */
|
|
|
|
scrub(p1_file); /* optionally unlink */
|
|
|
|
if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
|
|
err ("start_formatting: couldn't reopen the pass1 file");
|
|
|
|
} /* start_formatting */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
put_semi(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
put_semi(FILE *outfile)
|
|
#endif
|
|
{
|
|
nice_printf (outfile, ";\n");
|
|
last_was_label = 0;
|
|
}
|
|
|
|
#define SEM_CHECK(x) if (last_was_label) put_semi(x)
|
|
|
|
/* do_format -- takes an input stream (a file in pass1 format) and writes
|
|
the appropriate C code to outfile when possible. When reading an
|
|
expression, the expression tree is returned instead. */
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_format(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_format(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
int token_type, was_c_token;
|
|
expptr retval = ENULL;
|
|
|
|
token_type = get_p1_token (infile);
|
|
was_c_token = 1;
|
|
switch (token_type) {
|
|
case P1_COMMENT:
|
|
do_p1_comment (infile, outfile);
|
|
was_c_token = 0;
|
|
break;
|
|
case P1_SET_LINE:
|
|
do_p1_set_line (infile);
|
|
was_c_token = 0;
|
|
break;
|
|
case P1_FILENAME:
|
|
p1gets(infile, filename, P1_FILENAME_MAX);
|
|
was_c_token = 0;
|
|
break;
|
|
case P1_NAME_POINTER:
|
|
retval = do_p1_name_pointer (infile);
|
|
break;
|
|
case P1_CONST:
|
|
retval = do_p1_const (infile);
|
|
break;
|
|
case P1_EXPR:
|
|
retval = do_p1_expr (infile, outfile);
|
|
break;
|
|
case P1_IDENT:
|
|
retval = do_p1_ident(infile);
|
|
break;
|
|
case P1_CHARP:
|
|
retval = do_p1_charp(infile);
|
|
break;
|
|
case P1_EXTERN:
|
|
retval = do_p1_extern (infile);
|
|
break;
|
|
case P1_HEAD:
|
|
gflag1 = sharp_line = 0;
|
|
retval = do_p1_head (infile, outfile);
|
|
gflag1 = sharp_line = gflag;
|
|
break;
|
|
case P1_LIST:
|
|
retval = do_p1_list (infile, outfile);
|
|
break;
|
|
case P1_LITERAL:
|
|
retval = do_p1_literal (infile);
|
|
break;
|
|
case P1_LABEL:
|
|
do_p1_label (infile, outfile);
|
|
/* last_was_label = 1; -- now set in do_p1_label */
|
|
was_c_token = 0;
|
|
break;
|
|
case P1_ASGOTO:
|
|
do_p1_asgoto (infile, outfile);
|
|
break;
|
|
case P1_GOTO:
|
|
do_p1_goto (infile, outfile);
|
|
break;
|
|
case P1_IF:
|
|
do_p1_if (infile, outfile);
|
|
break;
|
|
case P1_ELSE:
|
|
SEM_CHECK(outfile);
|
|
do_p1_else (outfile);
|
|
break;
|
|
case P1_ELIF:
|
|
SEM_CHECK(outfile);
|
|
do_p1_elif (infile, outfile);
|
|
break;
|
|
case P1_ENDIF:
|
|
SEM_CHECK(outfile);
|
|
do_p1_endif (outfile);
|
|
break;
|
|
case P1_ENDELSE:
|
|
SEM_CHECK(outfile);
|
|
do_p1_endelse (outfile);
|
|
break;
|
|
case P1_ADDR:
|
|
retval = do_p1_addr (infile, outfile);
|
|
break;
|
|
case P1_SUBR_RET:
|
|
do_p1_subr_ret (infile, outfile);
|
|
break;
|
|
case P1_COMP_GOTO:
|
|
do_p1_comp_goto (infile, outfile);
|
|
break;
|
|
case P1_FOR:
|
|
do_p1_for (infile, outfile);
|
|
break;
|
|
case P1_ENDFOR:
|
|
SEM_CHECK(outfile);
|
|
do_p1_end_for (outfile);
|
|
break;
|
|
case P1_WHILE1START:
|
|
do_p1_1while(outfile);
|
|
break;
|
|
case P1_WHILE2START:
|
|
do_p1_2while(infile, outfile);
|
|
break;
|
|
case P1_PROCODE:
|
|
procode(outfile);
|
|
break;
|
|
case P1_ELSEIFSTART:
|
|
SEM_CHECK(outfile);
|
|
do_p1_elseifstart(outfile);
|
|
break;
|
|
case P1_FORTRAN:
|
|
do_p1_fortran(infile, outfile);
|
|
/* no break; */
|
|
case P1_EOF:
|
|
was_c_token = 0;
|
|
break;
|
|
case P1_UNKNOWN:
|
|
Fatal("do_format: Unknown token type in intermediate file");
|
|
break;
|
|
default:
|
|
Fatal("do_format: Bad token type in intermediate file");
|
|
break;
|
|
} /* switch */
|
|
|
|
if (was_c_token)
|
|
last_was_label = 0;
|
|
return retval;
|
|
} /* do_format */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_comment(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_comment(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
extern int in_comment;
|
|
|
|
char storage[COMMENT_BUFFER_SIZE + 1];
|
|
int length;
|
|
|
|
if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
|
|
return;
|
|
|
|
length = strlen (storage);
|
|
|
|
gflag1 = sharp_line = 0;
|
|
in_comment = 1;
|
|
margin_printf(outfile, length ? "/* %s */\n" : "\n", storage);
|
|
in_comment = 0;
|
|
gflag1 = sharp_line = gflag;
|
|
} /* do_p1_comment */
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_set_line(infile)
|
|
FILE *infile;
|
|
#else
|
|
do_p1_set_line(FILE *infile)
|
|
#endif
|
|
{
|
|
int status;
|
|
long new_line_number = -1;
|
|
|
|
status = p1getd (infile, &new_line_number);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_set_line: Missing line number at end of file\n");
|
|
else if (status == 0 || new_line_number == -1)
|
|
errl("do_p1_set_line: Illegal line number in intermediate file: %ld\n",
|
|
new_line_number);
|
|
else {
|
|
lineno = new_line_number;
|
|
}
|
|
} /* do_p1_set_line */
|
|
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_name_pointer(infile)
|
|
FILE *infile;
|
|
#else
|
|
do_p1_name_pointer(FILE *infile)
|
|
#endif
|
|
{
|
|
Namep namep = (Namep) NULL;
|
|
int status;
|
|
|
|
status = p1getd (infile, (long *) &namep);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_name_pointer: Missing pointer at end of file\n");
|
|
else if (status == 0 || namep == (Namep) NULL)
|
|
erri ("do_p1_name_pointer: Illegal name pointer in p1 file: '%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
|
|
{
|
|
long memno = addrp->memno;
|
|
struct Literal *litp, *lastlit;
|
|
|
|
lastlit = litpool + nliterals;
|
|
for (litp = litpool; litp < lastlit; litp++)
|
|
if (litp->litnum == memno) {
|
|
addrp->vtype = litp->littype;
|
|
*((union Constant *) &(addrp->user)) =
|
|
*((union Constant *) &(litp->litval));
|
|
addrp->vstg = STGMEMNO;
|
|
return;
|
|
}
|
|
err("addrlit failure!");
|
|
}
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_literal(infile)
|
|
FILE *infile;
|
|
#else
|
|
do_p1_literal(FILE *infile)
|
|
#endif
|
|
{
|
|
int status;
|
|
long memno;
|
|
Addrp addrp;
|
|
|
|
status = p1getd (infile, &memno);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_literal: Missing memno at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_literal: Missing memno in p1 file");
|
|
else {
|
|
addrp = ALLOC (Addrblock);
|
|
addrp -> tag = TADDR;
|
|
addrp -> vtype = TYUNKNOWN;
|
|
addrp -> Field = NULL;
|
|
addrp -> memno = memno;
|
|
addrlit(addrp);
|
|
addrp -> uname_tag = UNAM_CONST;
|
|
} /* else */
|
|
|
|
return (expptr) addrp;
|
|
} /* do_p1_literal */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_label(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_label(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
int status;
|
|
ftnint stateno;
|
|
struct Labelblock *L;
|
|
char *fmt;
|
|
|
|
status = p1getd (infile, &stateno);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_label: Missing label at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_label: Missing label in p1 file ");
|
|
else if (stateno < 0) { /* entry */
|
|
margin_printf(outfile, "\n%s:\n", user_label(stateno));
|
|
last_was_label = 1;
|
|
}
|
|
else {
|
|
L = labeltab + stateno;
|
|
if (L->labused) {
|
|
fmt = "%s:\n";
|
|
last_was_label = 1;
|
|
}
|
|
else
|
|
fmt = "/* %s: */\n";
|
|
margin_printf(outfile, fmt, user_label(L->stateno));
|
|
} /* else */
|
|
} /* do_p1_label */
|
|
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_asgoto(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_asgoto(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr expr;
|
|
|
|
expr = do_format (infile, outfile);
|
|
out_asgoto (outfile, expr);
|
|
|
|
} /* do_p1_asgoto */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_goto(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_goto(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
int status;
|
|
long stateno;
|
|
|
|
status = p1getd (infile, &stateno);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_goto: Missing goto label at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_goto: Missing goto label in p1 file");
|
|
else {
|
|
nice_printf (outfile, "goto %s;\n", user_label (stateno));
|
|
} /* else */
|
|
} /* do_p1_goto */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_if(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_if(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr cond;
|
|
|
|
do {
|
|
cond = do_format (infile, outfile);
|
|
} while (cond == ENULL);
|
|
|
|
out_if (outfile, cond);
|
|
} /* do_p1_if */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_else(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_else(FILE *outfile)
|
|
#endif
|
|
{
|
|
out_else (outfile);
|
|
} /* do_p1_else */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_elif(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_elif(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr cond;
|
|
|
|
do {
|
|
cond = do_format (infile, outfile);
|
|
} while (cond == ENULL);
|
|
|
|
elif_out (outfile, cond);
|
|
} /* do_p1_elif */
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_endif(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_endif(FILE *outfile)
|
|
#endif
|
|
{
|
|
endif_out (outfile);
|
|
} /* do_p1_endif */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_endelse(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_endelse(FILE *outfile)
|
|
#endif
|
|
{
|
|
end_else_out (outfile);
|
|
} /* do_p1_endelse */
|
|
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_addr(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_addr(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
Addrp addrp = (Addrp) NULL;
|
|
int status;
|
|
|
|
status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_addr: Missing Addrp at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_addr: Missing Addrp in p1 file");
|
|
else if (addrp == (Addrp) NULL)
|
|
err ("do_p1_addr: Null addrp in p1 file");
|
|
else if (addrp -> tag != TADDR)
|
|
erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
|
|
else {
|
|
addrp -> vleng = do_format (infile, outfile);
|
|
addrp -> memoffset = do_format (infile, outfile);
|
|
}
|
|
|
|
return (expptr) addrp;
|
|
} /* do_p1_addr */
|
|
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_subr_ret(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_subr_ret(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr retval;
|
|
|
|
nice_printf (outfile, "return ");
|
|
retval = do_format (infile, outfile);
|
|
if (!multitype)
|
|
if (retval)
|
|
expr_out (outfile, retval);
|
|
|
|
nice_printf (outfile, ";\n");
|
|
} /* do_p1_subr_ret */
|
|
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_comp_goto(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_comp_goto(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr index;
|
|
expptr labels;
|
|
|
|
index = do_format (infile, outfile);
|
|
|
|
if (index == ENULL) {
|
|
err ("do_p1_comp_goto: no expression for computed goto");
|
|
return;
|
|
} /* if index == ENULL */
|
|
|
|
labels = do_format (infile, outfile);
|
|
|
|
if (labels && labels -> tag != TLIST)
|
|
erri ("do_p1_comp_goto: expected list, got tag '%d'", labels -> tag);
|
|
else
|
|
compgoto_out (outfile, index, labels);
|
|
} /* do_p1_comp_goto */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_for(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_for(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr init, test, inc;
|
|
|
|
init = do_format (infile, outfile);
|
|
test = do_format (infile, outfile);
|
|
inc = do_format (infile, outfile);
|
|
|
|
out_for (outfile, init, test, inc);
|
|
} /* do_p1_for */
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_end_for(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_end_for(FILE *outfile)
|
|
#endif
|
|
{
|
|
out_end_for (outfile);
|
|
} /* do_p1_end_for */
|
|
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_fortran(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_fortran(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
char buf[P1_STMTBUFSIZE];
|
|
if (!p1gets(infile, buf, P1_STMTBUFSIZE))
|
|
return;
|
|
/* bypass nice_printf nonsense */
|
|
fprintf(outfile, "/*< %s >*/\n", buf+1); /* + 1 to skip by '$' */
|
|
}
|
|
|
|
|
|
static expptr
|
|
#ifdef KR_headers
|
|
do_p1_expr(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_expr(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
int status;
|
|
long opcode, type;
|
|
struct Exprblock *result = (struct Exprblock *) NULL;
|
|
|
|
status = p1getd (infile, &opcode);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_expr: Missing expr opcode at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_expr: Missing expr opcode in p1 file");
|
|
else {
|
|
|
|
status = p1getd (infile, &type);
|
|
|
|
if (status == EOF)
|
|
err ("do_p1_expr: Missing expr type at end of file");
|
|
else if (status == 0)
|
|
err ("do_p1_expr: Missing expr type in p1 file");
|
|
else if (opcode == 0)
|
|
return ENULL;
|
|
else {
|
|
result = ALLOC (Exprblock);
|
|
|
|
result -> tag = TEXPR;
|
|
result -> vtype = 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;
|
|
char *comma, *type;
|
|
int did_one = 0;
|
|
|
|
cp = assigned_fmts = revchain(assigned_fmts);
|
|
nice_printf(outfile, "/* Assigned format variables */\n");
|
|
do {
|
|
np = (Namep)cp->datap;
|
|
if (did_one == np->vstg) {
|
|
comma = ", ";
|
|
type = "";
|
|
}
|
|
else {
|
|
comma = did_one ? ";\n" : "";
|
|
type = np->vstg == STGAUTO ? "char " : "static char ";
|
|
did_one = np->vstg;
|
|
}
|
|
nice_printf(outfile, "%s%s*%s_fmt", comma, type, np->fvarname);
|
|
}
|
|
while(cp = cp->nextp);
|
|
nice_printf(outfile, ";\n\n");
|
|
}
|
|
|
|
static char *
|
|
#ifdef KR_headers
|
|
to_upper(s)
|
|
register char *s;
|
|
#else
|
|
to_upper(register char *s)
|
|
#endif
|
|
{
|
|
static char buf[64];
|
|
register char *t = buf;
|
|
register int c;
|
|
while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
|
|
return buf;
|
|
}
|
|
|
|
|
|
/* This routine creates static structures representing a namelist.
|
|
Declarations of the namelist and related structures are:
|
|
|
|
struct Vardesc {
|
|
char *name;
|
|
char *addr;
|
|
ftnlen *dims; /* laid out as struct dimensions below *//*
|
|
int type;
|
|
};
|
|
typedef struct Vardesc Vardesc;
|
|
|
|
struct Namelist {
|
|
char *name;
|
|
Vardesc **vars;
|
|
int nvars;
|
|
};
|
|
|
|
struct dimensions
|
|
{
|
|
ftnlen numberofdimensions;
|
|
ftnlen numberofelements
|
|
ftnlen baseoffset;
|
|
ftnlen span[numberofdimensions-1];
|
|
};
|
|
|
|
If dims is not null, then the corner element of the array is at
|
|
addr. However, the element with subscripts (i1,...,in) is at
|
|
addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
|
|
*/
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
write_namelists(nmch, outfile)
|
|
chainp nmch;
|
|
FILE *outfile;
|
|
#else
|
|
write_namelists(chainp nmch, FILE *outfile)
|
|
#endif
|
|
{
|
|
Namep var;
|
|
struct Hashentry *entry;
|
|
struct Dimblock *dimp;
|
|
int i, nd, type;
|
|
char *comma, *name;
|
|
register chainp q;
|
|
register Namep v;
|
|
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;
|
|
if (k >= 100)
|
|
k -= 100;
|
|
nice_printf(outfile, "%s%s", comma,
|
|
usedcasts[k] = casttypes[k]);
|
|
}
|
|
else if (k >= 100)
|
|
nice_printf(outfile,
|
|
k == TYCHAR + 100 ? "%s%s *" : "%s%s",
|
|
comma, c_type_decl(k-100, 0));
|
|
else
|
|
nice_printf(outfile, "%s%s *", comma,
|
|
c_type_decl(k, 0));
|
|
comma = ", ";
|
|
}
|
|
nice_printf(outfile, ")");
|
|
}
|
|
|
|
void
|
|
#ifdef KR_headers
|
|
protowrite(protofile, type, name, e, lengths)
|
|
FILE *protofile;
|
|
int type;
|
|
char *name;
|
|
struct Entrypoint *e;
|
|
chainp lengths;
|
|
#else
|
|
protowrite(FILE *protofile, int type, char *name, struct Entrypoint *e, chainp lengths)
|
|
#endif
|
|
{
|
|
extern char used_rets[];
|
|
int asave;
|
|
|
|
if (!(asave = Ansi))
|
|
Castargs = Ansi = 1;
|
|
nice_printf(protofile, "extern %s %s", protorettypes[type], name);
|
|
list_arg_types(protofile, e, lengths, 0, ";\n");
|
|
used_rets[type] = 1;
|
|
if (!(Ansi = asave))
|
|
Castargs = 0;
|
|
}
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_1while(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_1while(FILE *outfile)
|
|
#endif
|
|
{
|
|
if (*wh_next) {
|
|
nice_printf(outfile,
|
|
"for(;;) { /* while(complicated condition) */\n" /*}*/ );
|
|
next_tab(outfile);
|
|
}
|
|
else
|
|
nice_printf(outfile, "while(" /*)*/ );
|
|
}
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_2while(infile, outfile)
|
|
FILE *infile;
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_2while(FILE *infile, FILE *outfile)
|
|
#endif
|
|
{
|
|
expptr test;
|
|
|
|
test = do_format(infile, outfile);
|
|
if (*wh_next)
|
|
nice_printf(outfile, "if (!(");
|
|
expr_out(outfile, test);
|
|
if (*wh_next++)
|
|
nice_printf(outfile, "))\n\tbreak;\n");
|
|
else {
|
|
nice_printf(outfile, /*(*/ ") {\n");
|
|
next_tab(outfile);
|
|
}
|
|
}
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
do_p1_elseifstart(outfile)
|
|
FILE *outfile;
|
|
#else
|
|
do_p1_elseifstart(FILE *outfile)
|
|
#endif
|
|
{ /* with sufficiently illegal input, ei_next == ei_last == 0 is possible */
|
|
if (ei_next < ei_last && *ei_next++) {
|
|
prev_tab(outfile);
|
|
nice_printf(outfile, /*{*/
|
|
"} else /* if(complicated condition) */ {\n" /*}*/ );
|
|
next_tab(outfile);
|
|
}
|
|
}
|