[unix-history] / 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;
				}
			}
		}
	}
Commit	Line	Data
f1525c23 WH	1	/****************************************************************
	2	Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
	3
	4	Permission to use, copy, modify, and distribute this software
	5	and its documentation for any purpose and without fee is hereby
	6	granted, provided that the above copyright notice appear in all
	7	copies and that both that the copyright notice and this
	8	permission notice and warranty disclaimer appear in supporting
	9	documentation, and that the names of AT&T Bell Laboratories or
	10	Bellcore or any of their entities not be used in advertising or
	11	publicity pertaining to distribution of the software without
	12	specific, written prior permission.
	13
	14	AT&T and Bellcore disclaim all warranties with regard to this
	15	software, including all implied warranties of merchantability
	16	and fitness. In no event shall AT&T or Bellcore be liable for
	17	any special, indirect or consequential damages or any damages
	18	whatsoever resulting from loss of use, data or profits, whether
	19	in an action of contract, negligence or other tortious action,
	20	arising out of or in connection with the use or performance of
	21	this software.
	22	****************************************************************/
	23
	24	#include "defs.h"
	25	#include "output.h"
	26	#include "iob.h"
	27
	28	/* State required for the C output */
	29	char fl_fmt_string; / Float format string */
	30	char db_fmt_string; / Double format string */
	31	char cm_fmt_string; / Complex format string */
	32	char dcm_fmt_string; / Double complex format string */
	33
	34	chainp new_vars = CHNULL; /* List of newly created locals in this
	35	function. These may have identifiers
	36	which have underscores and more than VL
	37	characters */
	38	chainp used_builtins = CHNULL; /* List of builtins used by this function.
	39	These are all Addrps with UNAM_EXTERN
	40	*/
	41	chainp assigned_fmts = CHNULL; /* assigned formats */
	42	chainp allargs; /* union of args in all entry points */
	43	chainp earlylabs; /* labels seen before enddcl() */
	44	char main_alias[52]; /* PROGRAM name, if any is given */
	45	int tab_size = 4;
	46
	47
	48	FILEP infile;
	49	FILEP diagfile;
	50
	51	FILEP c_file;
	52	FILEP pass1_file;
	53	FILEP initfile;
	54	FILEP blkdfile;
	55
	56
	57	char token[MAXTOKENLEN+2];
	58	int toklen;
	59	long lineno; /* Current line in the input file, NOT the
	60	Fortran statement label number */
	61	char *infname;
	62	int needkwd;
	63	struct Labelblock *thislabel = NULL;
	64	int nerr;
65	int nwarn;
66
67	flag saveall;
68	flag substars;
69	int parstate = OUTSIDE;
70	flag headerdone = NO;
71	int blklevel;
72	int doin_setbound;
73	int impltype[26];
74	ftnint implleng[26];
75	int implstg[26];
76
77	int tyint = TYLONG ;
78	int tylogical = TYLONG;
79	int tylog = TYLOGICAL;
80	int typesize[NTYPES] = {
81	1, SZADDR, 1, SZSHORT, SZLONG,
82	#ifdef TYQUAD
83	2*SZLONG,
84	#endif
85	SZLONG, 2*SZLONG,
86	2SZLONG, 4SZLONG, 1, SZSHORT, SZLONG, 1, 1, 0,
87	4SZLONG + SZADDR, / sizeof(cilist) */
88	4SZLONG + 2SZADDR, /* sizeof(icilist) */
89	4SZLONG + 5SZADDR, /* sizeof(olist) */
90	2SZLONG + SZADDR, / sizeof(cllist) */
91	2SZLONG, / sizeof(alist) */
92	11SZLONG + 15SZADDR /* sizeof(inlist) */
93	};
94
95	int typealign[NTYPES] = {
96	1, ALIADDR, 1, ALISHORT, ALILONG,
97	#ifdef TYQUAD
98	ALIDOUBLE,
99	#endif
100	ALILONG, ALIDOUBLE,
101	ALILONG, ALIDOUBLE, 1, ALISHORT, ALILONG, 1, 1, 1,
102	ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
103
104	int type_choice[4] = { TYDREAL, TYSHORT, TYLONG, TYSHORT };
105
106	char *typename[] = {
107	"<<unknown>>",
108	"address",
109	"integer1",
110	"shortint",
111	"integer",
112	#ifdef TYQUAD
113	"longint",
114	#endif
115	"real",
116	"doublereal",
117	"complex",
118	"doublecomplex",
119	"logical1",
120	"shortlogical",
121	"logical",
122	"char" /* character */
123	};
124
125	int type_pref[NTYPES] = { 0, 0, 3, 5, 7,
126	#ifdef TYQUAD
127	10,
128	#endif
129	8, 11, 9, 12, 1, 4, 6, 2 };
130
131	char *protorettypes[] = {
132	"?", "??", "integer1", "shortint", "integer",
133	#ifdef TYQUAD
134	"longint",
135	#endif
136	"real", "doublereal",
137	"C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int"
138	};
139
140	char *casttypes[TYSUBR+1] = {
141	"U_fp", "??bug??", "I1_fp",
142	"J_fp", "I_fp",
143	#ifdef TYQUAD
144	"Q_fp",
145	#endif
146	"R_fp", "D_fp", "C_fp", "Z_fp",
147	"L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp"
148	};
149	char *usedcasts[TYSUBR+1];
150
151	char *dfltarg[] = {
152	0, 0, "(integer1 *)0",
153	"(shortint )0", "(integer )0",
154	#ifdef TYQUAD
155	"(longint *)0",
156	#endif
157	"(real *)0",
158	"(doublereal )0", "(complex )0", "(doublecomplex *)0",
159	"(logical1 )0","(shortlogical )0)", "(logical )0", "(char )0"
160	};
161
162	static char *dflt0proc[] = {
163	0, 0, "(integer1 (*)())0",
164	"(shortint ()())0", "(integer ()())0",
165	#ifdef TYQUAD
166	"(longint (*)())0",
167	#endif
168	"(real (*)())0",
169	"(doublereal ()())0", "(complex ()())0", "(doublecomplex (*)())0",
170	"(logical1 ()())0", "(shortlogical ()())0",
171	"(logical ()())0", "(char ()())0", "(int (*)())0"
172	};
173
174	char *dflt1proc[] = { "(U_fp)0", "(??bug??)0", "(I1_fp)0",
175	"(J_fp)0", "(I_fp)0",
176	#ifdef TYQUAD
177	"(Q_fp)0",
178	#endif
179	"(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0",
180	"(L1_fp)0","(L2_fp)0",
181	"(L_fp)0", "(H_fp)0", "(S_fp)0"
182	};
183
184	char **dfltproc = dflt0proc;
185
186	static char Bug[] = "bug";
187
188	char ftn_types[] = { "external", "??", "integer1",
189	"integer*2", "integer",
190	#ifdef TYQUAD
191	"integer*8",
192	#endif
193	"real",
194	"double precision", "complex", "double complex",
195	"logical1", "logical2",
196	"logical", "character", "subroutine",
197	Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
198	};
199
200	int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0,
201	#ifdef TYQUAD
202	0,
203	#endif
204	1, 1, 0, 0, 0, 2};
205
206	int proctype = TYUNKNOWN;
207	char *procname;
208	int rtvlabel[NTYPES0];
209	Addrp retslot; /* Holds automatic variable which was
210	allocated the function return value
211	*/
212	Addrp xretslot[NTYPES0]; /* for multiple entry points */
213	int cxslot = -1;
214	int chslot = -1;
215	int chlgslot = -1;
216	int procclass = CLUNKNOWN;
217	int nentry;
218	int nallargs;
219	int nallchargs;
220	flag multitype;
221	ftnint procleng;
222	long lastiolabno;
223	int lastlabno;
224	int lastvarno;
225	int lastargslot;
226	int autonum[TYVOID];
227	char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","i1","s","i",
228	#ifdef TYQUAD
229	"i8",
230	#endif
231	"r","d","q","z","L1","L2","L","ch",
232	"??TYSUBR??", "??TYERROR??","ci", "ici",
233	"o", "cl", "al", "ioin" };
234
235	extern int maxctl;
236	struct Ctlframe *ctls;
237	struct Ctlframe *ctlstack;
238	struct Ctlframe *lastctl;
239
240	Namep regnamep[MAXREGVAR];
241	int highregvar;
242	int nregvar;
243
244	extern int maxext;
245	Extsym *extsymtab;
246	Extsym *nextext;
247	Extsym *lastext;
248
249	extern int maxequiv;
250	struct Equivblock *eqvclass;
251
252	extern int maxhash;
253	struct Hashentry *hashtab;
254	struct Hashentry *lasthash;
255
256	extern int maxstno; /* Maximum number of statement labels */
257	struct Labelblock *labeltab;
258	struct Labelblock *labtabend;
259	struct Labelblock *highlabtab;
260
261	int maxdim = MAXDIM;
262	struct Rplblock *rpllist = NULL;
263	struct Chain *curdtp = NULL;
264	flag toomanyinit;
265	ftnint curdtelt;
266	chainp templist[TYVOID];
267	chainp holdtemps;
268	int dorange = 0;
269	struct Entrypoint *entries = NULL;
270
271	chainp chains = NULL;
272
273	flag inioctl;
274	int iostmt;
275	int nioctl;
276	int nequiv = 0;
277	int eqvstart = 0;
278	int nintnames = 0;
279	extern int maxlablist;
280	struct Labelblock **labarray;
281
282	struct Literal *litpool;
283	int nliterals;
284
285	char dflttype[26];
286	char hextoi_tab[Table_size], Letters[Table_size];
287	char ei_first, ei_next, *ei_last;
288	char wh_first, wh_next, *wh_last;
289
290	#define ALLOCN(n,x) (struct x ) ckalloc((n)sizeof(struct x))
291
292	fileinit()
293	{
294	register char *s;
295	register int i, j;
296	extern void fmt_init(), mem_init(), np_init();
297
298	lastiolabno = 100000;
299	lastlabno = 0;
300	lastvarno = 0;
301	nliterals = 0;
302	nerr = 0;
303
304	infile = stdin;
305
306	memset(dflttype, tyreal, 26);
307	memset(dflttype + 'i' - 'a', tyint, 6);
308	memset(hextoi_tab, 16, sizeof(hextoi_tab));
309	for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
310	hextoi(*s) = i;
311	for(i = 10, s = "ABCDEF"; *s; i++, s++)
312	hextoi(*s) = i;
313	for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
314	Letters[i] = Letters[i+'A'-'a'] = j;
315
316	ctls = ALLOCN(maxctl+1, Ctlframe);
317	extsymtab = ALLOCN(maxext, Extsym);
318	eqvclass = ALLOCN(maxequiv, Equivblock);
319	hashtab = ALLOCN(maxhash, Hashentry);
320	labeltab = ALLOCN(maxstno, Labelblock);
321	litpool = ALLOCN(maxliterals, Literal);
322	labarray = (struct Labelblock *)ckalloc(maxlablist
323	sizeof(struct Labelblock *));
324	fmt_init();
325	mem_init();
326	np_init();
327
328	ctlstack = ctls++;
329	lastctl = ctls + maxctl;
330	nextext = extsymtab;
331	lastext = extsymtab + maxext;
332	lasthash = hashtab + maxhash;
333	labtabend = labeltab + maxstno;
334	highlabtab = labeltab;
335	main_alias[0] = '\0';
336	if (forcedouble)
337	dfltproc[TYREAL] = dfltproc[TYDREAL];
338
339	/* Initialize the routines for providing C output */
340
341	out_init ();
342	}
343
344	hashclear() /* clear hash table */
345	{
346	register struct Hashentry *hp;
347	register Namep p;
348	register struct Dimblock *q;
349	register int i;
350
351	for(hp = hashtab ; hp < lasthash ; ++hp)
352	if(p = hp->varp)
353	{
354	frexpr(p->vleng);
355	if(q = p->vdim)
356	{
357	for(i = 0 ; i < q->ndim ; ++i)
358	{
359	frexpr(q->dims[i].dimsize);
360	frexpr(q->dims[i].dimexpr);
361	}
362	frexpr(q->nelt);
363	frexpr(q->baseoffset);
364	frexpr(q->basexpr);
365	free( (charptr) q);
366	}
367	if(p->vclass == CLNAMELIST)
368	frchain( &(p->varxptr.namelist) );
369	free( (charptr) p);
370	hp->varp = NULL;
371	}
372	}
373
374	procinit()
375	{
376	register struct Labelblock *lp;
377	struct Chain *cp;
378	int i;
379	struct memblock;
380	extern struct memblock curmemblock, firstmemblock;
381	extern char mem_first, mem_next, mem_last, mem0_last;
382	extern void frexchain();
383
384	curmemblock = firstmemblock;
385	mem_next = mem_first;
386	mem_last = mem0_last;
387	ei_next = ei_first = ei_last = 0;
388	wh_next = wh_first = wh_last = 0;
389	iob_list = 0;
390	for(i = 0; i < 9; i++)
391	io_structs[i] = 0;
392
393	parstate = OUTSIDE;
394	headerdone = NO;
395	blklevel = 1;
396	saveall = NO;
397	substars = NO;
398	nwarn = 0;
399	thislabel = NULL;
400	needkwd = 0;
401
402	proctype = TYUNKNOWN;
403	procname = "MAIN_";
404	procclass = CLUNKNOWN;
405	nentry = 0;
406	nallargs = nallchargs = 0;
407	multitype = NO;
408	retslot = NULL;
409	for(i = 0; i < NTYPES0; i++) {
410	frexpr((expptr)xretslot[i]);
411	xretslot[i] = 0;
412	}
413	cxslot = -1;
414	chslot = -1;
415	chlgslot = -1;
416	procleng = 0;
417	blklevel = 1;
418	lastargslot = 0;
419
420	for(lp = labeltab ; lp < labtabend ; ++lp)
421	lp->stateno = 0;
422
423	hashclear();
424
425	/* Clear the list of newly generated identifiers from the previous
426	function */
427
428	frexchain(&new_vars);
429	frexchain(&used_builtins);
430	frchain(&assigned_fmts);
431	frchain(&allargs);
432	frchain(&earlylabs);
433
434	nintnames = 0;
435	highlabtab = labeltab;
436
437	ctlstack = ctls - 1;
438	for(i = TYADDR; i < TYVOID; i++) {
439	for(cp = templist[i]; cp ; cp = cp->nextp)
440	free( (charptr) (cp->datap) );
441	frchain(templist + i);
442	autonum[i] = 0;
443	}
444	holdtemps = NULL;
445	dorange = 0;
446	nregvar = 0;
447	highregvar = 0;
448	entries = NULL;
449	rpllist = NULL;
450	inioctl = NO;
451	eqvstart += nequiv;
452	nequiv = 0;
453	dcomplex_seen = 0;
454
455	for(i = 0 ; i<NTYPES0 ; ++i)
456	rtvlabel[i] = 0;
457
458	if(undeftype)
459	setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
460	else
461	{
462	setimpl(tyreal, (ftnint) 0, 'a', 'z');
463	setimpl(tyint, (ftnint) 0, 'i', 'n');
464	}
465	setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
466	setlog();
467	}
468
469
470
471
472	setimpl(type, length, c1, c2)
473	int type;
474	ftnint length;
475	int c1, c2;
476	{
477	int i;
478	char buff[100];
479
480	if(c1==0 \|\| c2==0)
481	return;
482
483	if(c1 > c2) {
484	sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
485	err(buff);
486	}
487	else {
488	c1 = letter(c1);
489	c2 = letter(c2);
490	if(type < 0)
491	for(i = c1 ; i<=c2 ; ++i)
492	implstg[i] = - type;
493	else {
494	type = lengtype(type, length);
495	if(type == TYCHAR) {
496	if (length < 0) {
497	err("length (*) in implicit");
498	length = 1;
499	}
500	}
501	else if (type != TYLONG)
502	length = 0;
503	for(i = c1 ; i<=c2 ; ++i) {
504	impltype[i] = type;
505	implleng[i] = length;
506	}
507	}
508	}
509	}