1 /*-
2 * Copyright (c) 1980 The Regents of the University of California.
3 * All rights reserved.
4 *
5 * %sccs.include.proprietary.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)init.c 5.5 (Berkeley) 04/12/91";
10 #endif /* not lint */
11
12 /*
13 * init.c
14 *
15 * Initializations for f77 compiler, pass 1.
16 *
17 * University of Utah CS Dept modification history:
18 *
19 * $Header: init.c,v 5.2 85/08/10 04:30:57 donn Exp $
20 * $Log: init.c,v $
21 * Revision 5.2 85/08/10 04:30:57 donn
22 * Jerry Berkman's changes to ifdef 66 code and handle -r8/double flag.
23 *
24 * Revision 5.1 85/08/10 03:47:33 donn
25 * 4.3 alpha
26 *
27 * Revision 2.1 84/07/19 12:03:26 donn
28 * Changed comment headers for UofU.
29 *
30 * Revision 1.3 84/02/28 21:07:53 donn
31 * Added Berkeley changes for call argument temporaries fix.
32 *
33 * Fixed incorrect check of 'cdatafile' when 'cchkfile' is opened. -- Donn
34 */
35
36 #include "defs.h"
37 #include "io.h"
38 #include <sys/file.h>
39 #include "pathnames.h"
40
41
42 FILEP infile = { stdin };
43 FILEP diagfile = { stderr };
44
45 FILEP textfile;
46 FILEP asmfile;
47 FILEP initfile;
48 long int headoffset;
49
50 char token[1321];
51 int toklen;
52 int lineno;
53 char *infname;
54 int needkwd;
55 struct Labelblock *thislabel = NULL;
56 flag nowarnflag = NO;
57 flag ftn66flag = NO;
58 #ifdef ONLY66
59 flag no66flag = NO;
60 flag noextflag = NO;
61 #endif
62 flag dblflag = NO;
63 flag profileflag = NO;
64 flag optimflag = NO;
65 flag shiftcase = YES;
66 flag undeftype = NO;
67 flag shortsubs = YES;
68 flag onetripflag = NO;
69 flag checksubs = NO;
70 flag debugflag [MAXDEBUGFLAG] = { NO };
71 flag equivdcl = NO;
72 int nerr;
73 int nwarn;
74 int ndata;
75
76 flag saveall;
77 flag substars;
78 int parstate = OUTSIDE;
79 flag headerdone = NO;
80 int blklevel;
81 int impltype[26];
82 int implleng[26];
83 int implstg[26];
84
85 int tyint = TYLONG ;
86 int tylogical = TYLONG;
87 ftnint typesize[NTYPES]
88 = { 1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG,
89 2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 1};
90 int typealign[NTYPES]
91 = { 1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE,
92 ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1};
93 int procno;
94 int lwmno;
95 int proctype = TYUNKNOWN;
96 char *procname;
97 int rtvlabel[NTYPES];
98 int fudgelabel;
99 Addrp typeaddr;
100 Addrp retslot;
101 int cxslot = -1;
102 int chslot = -1;
103 int chlgslot = -1;
104 int procclass = CLUNKNOWN;
105 int nentry;
106 flag multitype;
107 ftnint procleng;
108 int lastlabno = 10;
109 int lastvarno;
110 int lastargslot;
111 int argloc;
112 ftnint autoleng;
113 ftnint bssleng = 0;
114 int retlabel;
115 int ret0label;
116 ftnint lowbss = 0;
117 ftnint highbss = 0;
118 int bsslabel;
119 flag anyinits = NO;
120 flag anylocals = NO;
121
122 int maxctl = MAXCTL;
123 struct Ctlframe *ctls;
124 struct Ctlframe *ctlstack;
125 struct Ctlframe *lastctl;
126
127 Namep regnamep[MAXREGVAR];
128 int highregvar;
129 int nregvar;
130
131 int maxext = MAXEXT;
132 struct Extsym *extsymtab;
133 struct Extsym *nextext;
134 struct Extsym *lastext;
135
136 int maxequiv = MAXEQUIV;
137 struct Equivblock *eqvclass;
138
139 int maxhash = MAXHASH;
140 struct Hashentry *hashtab;
141 struct Hashentry *lasthash;
142
143 int maxstno = MAXSTNO;
144 struct Labelblock *labeltab;
145 struct Labelblock *labtabend;
146 struct Labelblock *highlabtab;
147
148 int maxdim = MAXDIM;
149 struct Rplblock *rpllist = NULL;
150 struct Chain *curdtp = NULL;
151 flag toomanyinit;
152 ftnint curdtelt;
153 chainp templist = NULL;
154 chainp argtemplist = CHNULL;
155 chainp activearglist = CHNULL;
156 chainp holdtemps = NULL;
157 int dorange = 0;
158 struct Entrypoint *entries = NULL;
159
160 chainp chains = NULL;
161
162 flag inioctl;
163 Addrp ioblkp;
164 int iostmt;
165 int nioctl;
166 int nequiv = 0;
167 int eqvstart = 0;
168 int nintnames = 0;
169
170 #ifdef SDB
171 int dbglabel = 0;
172 flag sdbflag = NO;
173 #endif
174
175 struct Literal litpool[MAXLITERALS];
176 int nliterals;
177
178 int cdatafile;
179 int cchkfile;
180 int vdatafile;
181 int vchkfile;
182
183 char cdatafname[44] = "";
184 char cchkfname[44] = "";
185 char vdatafname[44] = "";
186 char vchkfname[44] = "";
187
188 long cdatahwm = 0;
189 long vdatahwm = 0;
190
191 ioblock *iodata = NULL;
192
193
194
fileinit()195 fileinit()
196 {
197 int pid;
198
199 pid = getpid();
200 sprintf(cdatafname, "%s/fortcd.%d", _PATH_TMP, pid);
201 sprintf(cchkfname, "%s/fortcc.%d", _PATH_TMP, pid);
202 sprintf(vdatafname, "%s/fortvd.%d", _PATH_TMP, pid);
203 sprintf(vchkfname, "%s/fortvc.%d", _PATH_TMP, pid);
204
205 cdatafile = open(cdatafname, O_CREAT | O_RDWR, 0600);
206 if (cdatafile < 0)
207 fatalstr("cannot open tmp file %s", cdatafname);
208
209 cchkfile = open(cchkfname, O_CREAT | O_RDWR, 0600);
210 if (cchkfile < 0)
211 fatalstr("cannot open tmp file %s", cchkfname);
212
213 pruse(initfile, USEINIT);
214
215 procno = 0;
216 lwmno = 0;
217 lastlabno = 10;
218 lastvarno = 0;
219 nliterals = 0;
220 nerr = 0;
221 ndata = 0;
222
223 ctls = ALLOCN(maxctl, Ctlframe);
224 extsymtab = ALLOCN(maxext, Extsym);
225 eqvclass = ALLOCN(maxequiv, Equivblock);
226 hashtab = ALLOCN(maxhash, Hashentry);
227 labeltab = ALLOCN(maxstno, Labelblock);
228
229 ctlstack = ctls - 1;
230 lastctl = ctls + maxctl;
231 nextext = extsymtab;
232 lastext = extsymtab + maxext;
233 lasthash = hashtab + maxhash;
234 labtabend = labeltab + maxstno;
235 highlabtab = labeltab;
236 }
237
238
239
240
241
procinit()242 procinit()
243 {
244 register Namep p;
245 register struct Dimblock *q;
246 register struct Hashentry *hp;
247 register struct Labelblock *lp;
248 struct Chain *cp;
249 int i;
250
251 vdatafile = open(vdatafname, O_CREAT | O_RDWR, 0600);
252 if (vdatafile < 0)
253 fatalstr("cannot open tmp file %s", vdatafname);
254
255 vchkfile = open(vchkfname, O_CREAT | O_RDWR, 0600);
256 if (vchkfile < 0)
257 fatalstr("cannot open tmp file %s", vchkfname);
258
259 pruse(asmfile, USECONST);
260 #if FAMILY == PCC
261 p2pass(USETEXT);
262 #endif
263 parstate = OUTSIDE;
264 headerdone = NO;
265 blklevel = 1;
266 saveall = NO;
267 substars = NO;
268 nwarn = 0;
269 thislabel = NULL;
270 needkwd = 0;
271
272 ++procno;
273 proctype = TYUNKNOWN;
274 procname = "MAIN ";
275 procclass = CLUNKNOWN;
276 nentry = 0;
277 multitype = NO;
278 typeaddr = NULL;
279 retslot = NULL;
280 cxslot = -1;
281 chslot = -1;
282 chlgslot = -1;
283 procleng = 0;
284 blklevel = 1;
285 lastargslot = 0;
286 #if TARGET==PDP11
287 autoleng = 6;
288 #else
289 autoleng = 0;
290 #endif
291
292 for(lp = labeltab ; lp < labtabend ; ++lp)
293 lp->stateno = 0;
294
295 for(hp = hashtab ; hp < lasthash ; ++hp)
296 if(p = hp->varp)
297 {
298 frexpr(p->vleng);
299 if(q = p->vdim)
300 {
301 for(i = 0 ; i < q->ndim ; ++i)
302 {
303 frexpr(q->dims[i].dimsize);
304 frexpr(q->dims[i].dimexpr);
305 }
306 frexpr(q->nelt);
307 frexpr(q->baseoffset);
308 frexpr(q->basexpr);
309 free( (charptr) q);
310 }
311 if(p->vclass == CLNAMELIST)
312 frchain( &(p->varxptr.namelist) );
313 free( (charptr) p);
314 hp->varp = NULL;
315 }
316 nintnames = 0;
317 highlabtab = labeltab;
318
319 ctlstack = ctls - 1;
320 for(cp = templist ; cp ; cp = cp->nextp)
321 free( (charptr) (cp->datap) );
322 frchain(&templist);
323 for (cp = argtemplist; cp; cp = cp->nextp)
324 free((char *) (cp->datap));
325 frchain(&argtemplist);
326 holdtemps = NULL;
327 dorange = 0;
328 nregvar = 0;
329 highregvar = 0;
330 entries = NULL;
331 rpllist = NULL;
332 inioctl = NO;
333 ioblkp = NULL;
334 eqvstart += nequiv;
335 nequiv = 0;
336
337 for(i = 0 ; i<NTYPES ; ++i)
338 rtvlabel[i] = 0;
339 fudgelabel = 0;
340
341 if(undeftype)
342 setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
343 else
344 {
345 setimpl(dblflag ? TYDREAL : TYREAL, (ftnint) 0, 'a', 'z');
346 setimpl(tyint, (ftnint) 0, 'i', 'n');
347 }
348 setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
349 setlog();
350 setopt();
351
352 bsslabel = ++lastvarno;
353 anylocals = NO;
354 anyinits = NO;
355 }
356
357
358
359
setimpl(type,length,c1,c2)360 setimpl(type, length, c1, c2)
361 int type;
362 ftnint length;
363 int c1, c2;
364 {
365 int i;
366 char buff[100];
367
368 if(c1==0 || c2==0)
369 return;
370
371 if(c1 > c2)
372 {
373 sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
374 err(buff);
375 }
376 else
377 if(type < 0)
378 for(i = c1 ; i<=c2 ; ++i)
379 implstg[i-'a'] = - type;
380 else
381 {
382 type = lengtype(type, (int) length);
383 if(type != TYCHAR)
384 length = 0;
385 for(i = c1 ; i<=c2 ; ++i)
386 {
387 impltype[i-'a'] = type;
388 implleng[i-'a'] = length;
389 }
390 }
391 }
392