![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to init.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to init.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 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];
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: 2*SZLONG, 4*SZLONG, 1, SZSHORT, SZLONG, 1, 1, 0,
87: 4*SZLONG + SZADDR, /* sizeof(cilist) */
88: 4*SZLONG + 2*SZADDR, /* sizeof(icilist) */
89: 4*SZLONG + 5*SZADDR, /* sizeof(olist) */
90: 2*SZLONG + SZADDR, /* sizeof(cllist) */
91: 2*SZLONG, /* sizeof(alist) */
92: 11*SZLONG + 15*SZADDR /* 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", "??", "integer*1",
189: "integer*2", "integer",
190: #ifdef TYQUAD
191: "integer*8",
192: #endif
193: "real",
194: "double precision", "complex", "double complex",
195: "logical*1", "logical*2",
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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.