freebsd-dev/usr.bin/f2c/init.c

/****************************************************************
Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore.

Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.

AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness.  In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/

#include "defs.h"
#include "output.h"
#include "iob.h"

/* State required for the C output */
char *fl_fmt_string;		/* Float format string */
char *db_fmt_string;	    	/* Double format string */
char *cm_fmt_string;		/* Complex format string */
char *dcm_fmt_string;		/* Double complex format string */

chainp new_vars = CHNULL;	/* List of newly created locals in this
				   function.  These may have identifiers
				   which have underscores and more than VL
				   characters */
chainp used_builtins = CHNULL;	/* List of builtins used by this function.
				   These are all Addrps with UNAM_EXTERN
				   */
chainp assigned_fmts = CHNULL;	/* assigned formats */
chainp allargs;			/* union of args in all entry points */
chainp earlylabs;		/* labels seen before enddcl() */
char main_alias[52];		/* PROGRAM name, if any is given */
int tab_size = 4;


FILEP infile;
FILEP diagfile;

FILEP c_file;
FILEP pass1_file;
FILEP initfile;
FILEP blkdfile;


char token[MAXTOKENLEN+2];
int toklen;
long lineno;			/* Current line in the input file, NOT the
				   Fortran statement label number */
char *infname;
int needkwd;
struct Labelblock *thislabel	= NULL;
int nerr;
int nwarn;

flag saveall;
flag substars;
int parstate	= OUTSIDE;
flag headerdone	= NO;
int blklevel;
int doin_setbound;
int impltype[26];
ftnint implleng[26];
int implstg[26];

int tyint	= TYLONG ;
int tylogical	= TYLONG;
int tylog	= TYLOGICAL;
int typesize[NTYPES] = {
	1, SZADDR, 1, SZSHORT, SZLONG,
#ifdef TYQUAD
		2*SZLONG,
#endif
		SZLONG, 2*SZLONG,
		2*SZLONG, 4*SZLONG, 1, SZSHORT, SZLONG, 1, 1, 0,
		4*SZLONG + SZADDR,	/* sizeof(cilist) */
		4*SZLONG + 2*SZADDR,	/* sizeof(icilist) */
		4*SZLONG + 5*SZADDR,	/* sizeof(olist) */
		2*SZLONG + SZADDR,	/* sizeof(cllist) */
		2*SZLONG,		/* sizeof(alist) */
		11*SZLONG + 15*SZADDR	/* sizeof(inlist) */
		};

int typealign[NTYPES] = {
	1, ALIADDR, 1, ALISHORT, ALILONG,
#ifdef TYQUAD
	ALIDOUBLE,
#endif
	ALILONG, ALIDOUBLE,
	ALILONG, ALIDOUBLE, 1, ALISHORT, ALILONG, 1, 1, 1,
	ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};

int type_choice[4] = { TYDREAL, TYSHORT, TYLONG,  TYSHORT };

char *typename[] = {
	"<<unknown>>",
	"address",
	"integer1",
	"shortint",
	"integer",
#ifdef TYQUAD
	"longint",
#endif
	"real",
	"doublereal",
	"complex",
	"doublecomplex",
	"logical1",
	"shortlogical",
	"logical",
	"char"	/* character */
	};

int type_pref[NTYPES] = { 0, 0, 3, 5, 7,
#ifdef TYQUAD
			 10,
#endif
				8, 11, 9, 12, 1, 4, 6, 2 };

char *protorettypes[] = {
	"?", "??", "integer1", "shortint", "integer",
#ifdef TYQUAD
	"longint",
#endif
	"real", "doublereal",
	"C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int"
	};

char *casttypes[TYSUBR+1] = {
	"U_fp", "??bug??", "I1_fp",
	"J_fp", "I_fp",
#ifdef TYQUAD
	"Q_fp",
#endif
	"R_fp", "D_fp", "C_fp", "Z_fp",
	"L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp"
	};
char *usedcasts[TYSUBR+1];

char *dfltarg[] = {
	0, 0, "(integer1 *)0",
	"(shortint *)0", "(integer *)0",
#ifdef TYQUAD
	"(longint *)0",
#endif
	"(real *)0",
	"(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
	"(logical1 *)0","(shortlogical *)0)", "(logical *)0", "(char *)0"
	};

static char *dflt0proc[] = {
	0, 0, "(integer1 (*)())0",
	"(shortint (*)())0", "(integer (*)())0",
#ifdef TYQUAD
	"(longint (*)())0",
#endif
	"(real (*)())0",
	"(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
	"(logical1 (*)())0", "(shortlogical (*)())0",
	"(logical (*)())0", "(char (*)())0", "(int (*)())0"
	};

char *dflt1proc[] = { "(U_fp)0", "(??bug??)0", "(I1_fp)0",
	"(J_fp)0", "(I_fp)0",
#ifdef TYQUAD
	"(Q_fp)0",
#endif
	"(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0",
	"(L1_fp)0","(L2_fp)0",
	"(L_fp)0", "(H_fp)0", "(S_fp)0"
	};

char **dfltproc = dflt0proc;

static char Bug[] = "bug";

char *ftn_types[] = { "external", "??", "integer*1",
	"integer*2", "integer",
#ifdef TYQUAD
	"integer*8",
#endif
	"real",
	"double precision", "complex", "double complex",
	"logical*1", "logical*2",
	"logical", "character", "subroutine",
	Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
	};

int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0,
#ifdef TYQUAD
			  0,
#endif
			  1, 1, 0, 0, 0, 2};

int proctype	= TYUNKNOWN;
char *procname;
int rtvlabel[NTYPES0];
Addrp retslot;			/* Holds automatic variable which was
				   allocated the function return value
				   */
Addrp xretslot[NTYPES0];	/* for multiple entry points */
int cxslot	= -1;
int chslot	= -1;
int chlgslot	= -1;
int procclass	= CLUNKNOWN;
int nentry;
int nallargs;
int nallchargs;
flag multitype;
ftnint procleng;
long lastiolabno;
int lastlabno;
int lastvarno;
int lastargslot;
int autonum[TYVOID];
char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","i1","s","i",
#ifdef TYQUAD
			 "i8",
#endif
			"r","d","q","z","L1","L2","L","ch",
			 "??TYSUBR??", "??TYERROR??","ci", "ici",
			 "o", "cl", "al", "ioin" };

extern int maxctl;
struct Ctlframe *ctls;
struct Ctlframe *ctlstack;
struct Ctlframe *lastctl;

Namep regnamep[MAXREGVAR];
int highregvar;
int nregvar;

extern int maxext;
Extsym *extsymtab;
Extsym *nextext;
Extsym *lastext;

extern int maxequiv;
struct Equivblock *eqvclass;

extern int maxhash;
struct Hashentry *hashtab;
struct Hashentry *lasthash;

extern int maxstno;		/* Maximum number of statement labels */
struct Labelblock *labeltab;
struct Labelblock *labtabend;
struct Labelblock *highlabtab;

int maxdim	= MAXDIM;
struct Rplblock *rpllist	= NULL;
struct Chain *curdtp	= NULL;
flag toomanyinit;
ftnint curdtelt;
chainp templist[TYVOID];
chainp holdtemps;
int dorange	= 0;
struct Entrypoint *entries	= NULL;

chainp chains	= NULL;

flag inioctl;
int iostmt;
int nioctl;
int nequiv	= 0;
int eqvstart	= 0;
int nintnames	= 0;
extern int maxlablist;
struct Labelblock **labarray;

struct Literal *litpool;
int nliterals;

char dflttype[26];
char hextoi_tab[Table_size], Letters[Table_size];
char *ei_first, *ei_next, *ei_last;
char *wh_first, *wh_next, *wh_last;

#define ALLOCN(n,x)	(struct x *) ckalloc((n)*sizeof(struct x))

fileinit()
{
	register char *s;
	register int i, j;
	extern void fmt_init(), mem_init(), np_init();

	lastiolabno = 100000;
	lastlabno = 0;
	lastvarno = 0;
	nliterals = 0;
	nerr = 0;

	infile = stdin;

	memset(dflttype, tyreal, 26);
	memset(dflttype + 'i' - 'a', tyint, 6);
	memset(hextoi_tab, 16, sizeof(hextoi_tab));
	for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
		hextoi(*s) = i;
	for(i = 10, s = "ABCDEF"; *s; i++, s++)
		hextoi(*s) = i;
	for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
		Letters[i] = Letters[i+'A'-'a'] = j;

	ctls = ALLOCN(maxctl+1, Ctlframe);
	extsymtab = ALLOCN(maxext, Extsym);
	eqvclass = ALLOCN(maxequiv, Equivblock);
	hashtab = ALLOCN(maxhash, Hashentry);
	labeltab = ALLOCN(maxstno, Labelblock);
	litpool = ALLOCN(maxliterals, Literal);
	labarray = (struct Labelblock **)ckalloc(maxlablist*
					sizeof(struct Labelblock *));
	fmt_init();
	mem_init();
	np_init();

	ctlstack = ctls++;
	lastctl = ctls + maxctl;
	nextext = extsymtab;
	lastext = extsymtab + maxext;
	lasthash = hashtab + maxhash;
	labtabend = labeltab + maxstno;
	highlabtab = labeltab;
	main_alias[0] = '\0';
	if (forcedouble)
		dfltproc[TYREAL] = dfltproc[TYDREAL];

/* Initialize the routines for providing C output */

	out_init ();
}

hashclear()	/* clear hash table */
{
	register struct Hashentry *hp;
	register Namep p;
	register struct Dimblock *q;
	register int i;

	for(hp = hashtab ; hp < lasthash ; ++hp)
		if(p = hp->varp)
		{
			frexpr(p->vleng);
			if(q = p->vdim)
			{
				for(i = 0 ; i < q->ndim ; ++i)
				{
					frexpr(q->dims[i].dimsize);
					frexpr(q->dims[i].dimexpr);
				}
				frexpr(q->nelt);
				frexpr(q->baseoffset);
				frexpr(q->basexpr);
				free( (charptr) q);
			}
			if(p->vclass == CLNAMELIST)
				frchain( &(p->varxptr.namelist) );
			free( (charptr) p);
			hp->varp = NULL;
		}
	}

procinit()
{
	register struct Labelblock *lp;
	struct Chain *cp;
	int i;
	struct memblock;
	extern struct memblock *curmemblock, *firstmemblock;
	extern char *mem_first, *mem_next, *mem_last, *mem0_last;
	extern void frexchain();

	curmemblock = firstmemblock;
	mem_next = mem_first;
	mem_last = mem0_last;
	ei_next = ei_first = ei_last = 0;
	wh_next = wh_first = wh_last = 0;
	iob_list = 0;
	for(i = 0; i < 9; i++)
		io_structs[i] = 0;

	parstate = OUTSIDE;
	headerdone = NO;
	blklevel = 1;
	saveall = NO;
	substars = NO;
	nwarn = 0;
	thislabel = NULL;
	needkwd = 0;

	proctype = TYUNKNOWN;
	procname = "MAIN_";
	procclass = CLUNKNOWN;
	nentry = 0;
	nallargs = nallchargs = 0;
	multitype = NO;
	retslot = NULL;
	for(i = 0; i < NTYPES0; i++) {
		frexpr((expptr)xretslot[i]);
		xretslot[i] = 0;
		}
	cxslot = -1;
	chslot = -1;
	chlgslot = -1;
	procleng = 0;
	blklevel = 1;
	lastargslot = 0;

	for(lp = labeltab ; lp < labtabend ; ++lp)
		lp->stateno = 0;

	hashclear();

/* Clear the list of newly generated identifiers from the previous
   function */

	frexchain(&new_vars);
	frexchain(&used_builtins);
	frchain(&assigned_fmts);
	frchain(&allargs);
	frchain(&earlylabs);

	nintnames = 0;
	highlabtab = labeltab;

	ctlstack = ctls - 1;
	for(i = TYADDR; i < TYVOID; i++) {
		for(cp = templist[i]; cp ; cp = cp->nextp)
			free( (charptr) (cp->datap) );
		frchain(templist + i);
		autonum[i] = 0;
		}
	holdtemps = NULL;
	dorange = 0;
	nregvar = 0;
	highregvar = 0;
	entries = NULL;
	rpllist = NULL;
	inioctl = NO;
	eqvstart += nequiv;
	nequiv = 0;
	dcomplex_seen = 0;

	for(i = 0 ; i<NTYPES0 ; ++i)
		rtvlabel[i] = 0;

	if(undeftype)
		setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
	else
	{
		setimpl(tyreal, (ftnint) 0, 'a', 'z');
		setimpl(tyint,  (ftnint) 0, 'i', 'n');
	}
	setimpl(-STGBSS, (ftnint) 0, 'a', 'z');	/* set class */
	setlog();
}




setimpl(type, length, c1, c2)
int type;
ftnint length;
int c1, c2;
{
	int i;
	char buff[100];

	if(c1==0 || c2==0)
		return;

	if(c1 > c2) {
		sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
		err(buff);
		}
	else {
		c1 = letter(c1);
		c2 = letter(c2);
		if(type < 0)
			for(i = c1 ; i<=c2 ; ++i)
				implstg[i] = - type;
		else {
			type = lengtype(type, length);
			if(type == TYCHAR) {
				if (length < 0) {
					err("length (*) in implicit");
					length = 1;
					}
				}
			else if (type != TYLONG)
				length = 0;
			for(i = c1 ; i<=c2 ; ++i) {
				impltype[i] = type;
				implleng[i] = length;
				}
			}
		}
	}