![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to namgen.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / usr.bin / efl|
Return to namgen.c CVS log | Up to [CSRG BSD Unix] / 42BSD / usr.bin / efl |
1.1 root 1: #include "defs"
2:
3: impldecl(p)
4: register ptr p;
5: {
6: extern char *types[];
7: register ptr q;
8: int n;
9:
10: if(p->vtype==TYSUBR) return;
11: if(p->tag == TCALL)
12: {
13: impldecl(p->leftp);
14: p->vtype = p->leftp->vtype;
15: p->vtypep = p->leftp->vtypep;
16: return;
17: }
18:
19: if(inbound)
20: n = TYINT;
21: else {
22: n = impltype[p->sthead->namep[0] - 'a' ];
23: if(n==TYREAL && p->vprec!=0)
24: n = TYLREAL;
25: sprintf(msg, "%s implicitly typed %s",p->sthead->namep, types[n]);
26: warn(msg);
27: }
28: q = p->sthead->varp;
29: p->vtype = q->vtype = n;
30: if(p->blklevel>1 && p->vdclstart==0)
31: {
32: p->blklevel = q->blklevel = p->sthead->blklevel = 1;
33: p->vdclstart = q->vdclstart = 1;
34: --ndecl[blklevel];
35: ++ndecl[1];
36: }
37: }
38:
39:
40:
41: extname(p)
42: register ptr p;
43: {
44: register int i;
45: register char *q, *s;
46:
47: /* if(p->vclass == CLARG) return; */
48: if(p->vextbase) return;
49: q = p->sthead->namep;
50: setvproc(p, PROCYES);
51:
52: /* external names are automatically at block level 1 */
53:
54: if( (i =p->blklevel) >1)
55: {
56: p->sthead->blklevel = 1;
57: p->blklevel = 1;
58: p->sthead->varp->blklevel = 1;
59: ++ndecl[1];
60: --ndecl[i];
61: }
62:
63: if(p->vclass!=CLUNDEFINED && p->vclass!=CLARG)
64: {
65: dclerr("illegal class for procedure", q);
66: return;
67: }
68: if(p->vclass!=CLARG && strlen(q)>XL)
69: {
70: if(! ioop(q) )
71: dclerr("procedure name too long", q);
72: return;
73: }
74: if(lookftn(q) > 0)
75: dclerr("procedure name already used", q);
76: else {
77: for(i=0 ; i<NFTNTYPES ; ++i)
78: if(p->vbase[i]) break;
79: if(i < NFTNTYPES)
80: p->vextbase = p->vbase[i];
81: else p->vextbase = nxtftn();
82:
83: if(p->vext==0 || p->vclass!=CLARG)
84: for(s = ftnames[ p->vextbase ]; *s++ = *q++ ; ) ;
85: return;
86: }
87: }
88:
89:
90:
91: dclit(p)
92: register ptr p;
93: {
94: register ptr q;
95:
96: if(p->tag == TERROR)
97: return;
98:
99: q = p->sthead->varp;
100:
101: if(p->tag == TCALL)
102: {
103: dclit(p->leftp);
104: if( ioop(p->leftp->sthead->namep) )
105: p->leftp->vtype = TYLOG;
106: p->vtype = p->leftp->vtype;
107: p->vtypep = p->leftp->vtypep;
108: return;
109: }
110:
111: if(q->vdcldone == 0)
112: mkftnp(q);
113: if(p != q)
114: cpblock(q,p, sizeof(struct exprblock));
115: }
116:
117:
118: mkftnp(p)
119: register ptr p;
120: {
121: int i,k;
122: if(inbound || p->vdcldone) return;
123: if(p == 0)
124: fatal("mkftnp: zero argument");
125: if(p->tag!=TNAME && p->tag!=TTEMP)
126: badtag("mkftnp", p->tag);
127:
128: if(p->vtype == TYUNDEFINED)
129: if(p->vextbase)
130: return;
131: else impldecl(p);
132: p->vdcldone = 1;
133:
134: switch(p->vtype)
135: {
136: case TYCHAR:
137: case TYINT:
138: case TYREAL:
139: case TYLREAL:
140: case TYLOG:
141: case TYCOMPLEX:
142: case TYLCOMPLEX:
143: p->vbase[ eflftn[p->vtype] ] = nxtftn();
144: break;
145:
146: case TYSTRUCT:
147: k = p->vtypep->basetypes;
148: for(i=0; i<NFTNTYPES ; ++i)
149: if(k & ftnmask[i])
150: p->vbase[i] = nxtftn();
151: break;
152:
153: case TYSUBR:
154: break;
155:
156: default:
157: fatal1("invalid type for %s", p->sthead->namep);
158: break;
159: }
160: }
161:
162:
163: namegen()
164: {
165: register ptr p;
166: register struct stentry **hp;
167: register int i;
168:
169: for(hp = hashtab ; hp<hashend ; ++hp)
170: if(*hp && (p = (*hp)->varp) )
171: if(p->tag == TNAME)
172: mkft(p);
173:
174: for(p = gonelist ; p ; p = p->nextp)
175: mkft(p->datap);
176:
177: for(p = hidlist ; p ; p = p->nextp)
178: if(p->datap->tag == TNAME) mkft(p->datap);
179:
180: for(p = tempvarlist ; p ; p = p->nextp)
181: mkft(p->datap);
182:
183: TEST fprintf(diagfile, "Fortran names:\n");
184: TEST for(i=1; i<=nftnames ; ++i) fprintf(diagfile, "%s\n", ftnames[i]);
185: }
186:
187:
188: mkft(p)
189: register ptr p;
190: {
191: int i;
192: register char *s, *t;
193:
194: if(p->vnamedone)
195: return;
196:
197: if(p->vdcldone==0 && p!=procname)
198: {
199: if(p->vext && p->vtype==TYUNDEFINED)
200: p->vtype = TYSUBR;
201: else if(p->vextbase==0 && p->vadjdim==0 && p->vclass!=CLCOMMON)
202: warn1("%s never used", p->sthead->namep);
203: mkftnp(p);
204: }
205:
206: if(p->vextbase)
207: mkftname(p->vextbase, p->sthead->namep);
208:
209: for(i=0; i<NFTNTYPES ; ++i)
210: if(p->vbase[i] != 0)
211: if(p!=procname && p->vextbase!=0)
212: {
213: s = ftnames[p->vextbase];
214: t = ftnames[p->vbase[i]];
215: while(*t++ = *s++ )
216: ;
217: }
218: else if(p->sthead)
219: mkftname(p->vbase[i], p->sthead->namep);
220: else
221: mkftname(p->vbase[i], CHNULL);
222: p->vnamedone = 1;
223: }
224:
225:
226:
227:
228:
229: mkftname(n,s)
230: int n;
231: char *s;
232: {
233: int i, j;
234: register int k;
235: char fn[7];
236: register char *c1, *c2;
237:
238: if(ftnames[n][0] != '\0') return;
239:
240: if(s==0 || *s=='\0')
241: s = "temp";
242: else if(*s == '_')
243: ++s;
244: k = strlen(s);
245:
246: for(i=0; i<k && i<(XL/2) ; ++i)
247: fn[i] = s[i];
248: if(k > XL)
249: {
250: s += (k-XL);
251: k = XL;
252: }
253:
254: for( ; i<k ; ++i)
255: fn[i] = s[i];
256: fn[i] = '\0';
257:
258: if( lookftn(fn) )
259: {
260: if(k < XL)
261: ++k;
262: fn[k] = '\0';
263: c1 = fn + k-1;
264: for(*c1 = '1' ; *c1 <= '9' ; *c1 += 1)
265: if(lookftn(fn) == 0)
266: goto nameok;
267:
268: if(k < XL)
269: ++k;
270: fn[k] = '\0';
271: c1 = fn + k-2;
272: c2 = c1 + 1;
273:
274: for(*c1 = '1' ; *c1 <= '9' ; *c1 += 1)
275: for(*c2 = '0' ; *c2 <= '9' ; *c2 += 1)
276: if(lookftn(fn) == 0)
277: goto nameok;
278: fatal1("mkftname: cannot generate fortran name for %s", s);
279: }
280:
281: nameok:
282: for(j=0; j<=k ; ++j)
283: ftnames[n][j] = fn[j];
284: }
285:
286:
287:
288: nxtftn()
289: {
290: if( ++nftnames < MAXFTNAMES)
291: {
292: ftnames[nftnames][0] = '\0';
293: return(nftnames);
294: }
295:
296: fatal("too many Fortran names generated");
297: /* NOTREACHED */
298: }
299:
300:
301:
302: lookftn(s)
303: char *s;
304: {
305: register int i;
306:
307: for(i=1 ; i<=nftnames ; ++i)
308: if(equals(ftnames[i],s)) return(i);
309: return(0);
310: }
311:
312:
313:
314: ptr mkftnblock(type, name)
315: int type;
316: char *name;
317: {
318: register struct varblock *p;
319: register int k;
320:
321: p = allexpblock();
322: p->tag = TFTNBLOCK;
323: p->vtype = type;
324: p->vdcldone = 1;
325:
326: if( (k = lookftn(name)) == 0)
327: {
328: k = nxtftn();
329: strcpy(ftnames[k], name);
330: }
331: p->vbase[ eflftn[type] ] = k;
332: p->vextbase = k;
333: return(p);
334: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.