![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dclgen.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / usr.bin / efl|
Return to dclgen.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / usr.bin / efl |
1.1 root 1: #include "defs"
2:
3: #define DOCOMMON 1
4: #define NOCOMMON 0
5:
6: dclgen()
7: {
8: register ptr p, q;
9: ptr q1;
10: chainp *y, z;
11: register struct stentry *s;
12: struct stentry **hp;
13: int first;
14: int i, j;
15: extern char *types[];
16: char *sp;
17:
18: /* print procedure statement and argument list */
19:
20: for(p = prevcomments ; p ; p = p->nextp)
21: {
22: sp = p->datap;
23: fprintf(codefile, "%s\n", sp+1);
24: cfree(sp);
25: }
26: frchain(&prevcomments);
27:
28: if(tailor.procheader)
29: fprintf(codefile, "%s\n", tailor.procheader);
30:
31: if(procname)
32: {
33: p2str(" ");
34: if(procname->vtype==TYSUBR || procname->vtype==TYUNDEFINED)
35: p2key(FSUBROUTINE);
36: else {
37: p2str(types[procname->vtype]);
38: p2key(FFUNCTION);
39: }
40:
41: p2str(procname->sthead->namep);
42: }
43: else if(procclass == PRBLOCK)
44: {
45: p2stmt(0);
46: p2key(FBLOCKDATA);
47: }
48: else {
49: p2str("c main program");
50: if(tailor.ftnsys == CRAY)
51: {
52: p2stmt(0);
53: p2key(FPROGRAM);
54: }
55: }
56:
57: if(thisargs)
58: {
59: p2str( "(" );
60: first = 1;
61:
62: for(p = thisargs ; p ; p = p->nextp)
63: if( (q=p->datap)->vextbase)
64: {
65: if(first) first = 0;
66: else p2str(", ");
67: p2str(ftnames[q->vextbase]);
68: }
69: else for(i=0 ; i<NFTNTYPES ; ++i)
70: if(j = q->vbase[i])
71: {
72: if(first) first = 0;
73: else p2str( ", " );
74: p2str(ftnames[j]);
75: }
76: p2str( ")" );
77: }
78:
79: /* first put out declarations of variables that are used as
80: adjustable dimensions
81: */
82:
83: y = 0;
84: z = & y;
85: for(hp = hashtab ; hp<hashend; ++hp)
86: if( *hp && (q = (*hp)->varp) )
87: if(q->tag==TNAME && q->vadjdim && q!=procname)
88: z = z->nextp = mkchain(q,CHNULL);
89:
90: dclchain(y, NOCOMMON);
91: frchain(&y);
92:
93: /* then declare the rest of the arguments */
94: z = & y;
95: for(p = thisargs ; p ; p = p->nextp)
96: if(p->datap->vadjdim == 0)
97: z = z->nextp = mkchain(p->datap,CHNULL);
98: dclchain(y, NOCOMMON);
99: frchain(&y);
100: frchain(&thisargs);
101:
102:
103: /* now put out declarations for common blocks */
104: for(p = commonlist ; p ; p = p->nextp)
105: prcomm(p->datap);
106:
107: TEST fprintf(diagfile, "\nend of common declarations");
108: z = &y;
109:
110: /* next the other variables that are in the symbol table */
111:
112: for(hp = hashtab ; hp<hashend ; ++hp)
113: if( *hp && (q = (*hp)->varp) )
114: if(q->tag==TNAME && q->vadjdim==0 && q->vclass!=CLCOMMON &&
115: q->vclass!=CLARG && q!=procname &&
116: (tailor.dclintrinsics || q->vproc!=PROCINTRINSIC) )
117: z = z->nextp = mkchain(q,CHNULL);
118:
119: dclchain(y, NOCOMMON);
120: frchain(&y);
121:
122: TEST fprintf(diagfile, "\nend of symbol table, start of gonelist");
123:
124: /* now declare variables that are no longer in the symbol table */
125:
126: dclchain(gonelist, NOCOMMON);
127:
128: TEST fprintf(diagfile, "\nbeginning of hidlist");
129: dclchain(hidlist, NOCOMMON);
130:
131: dclchain(tempvarlist, NOCOMMON);
132:
133:
134: /* finally put out equivalence statements that are generated
135: because of structure and character variables
136: */
137: for(p = genequivs; p ; p = p->nextp)
138: {
139: q = p->datap;
140: p2stmt(0);
141: first = 1;
142: p2key(FEQUIVALENCE);
143: p2str( "(" );
144: for(i=0; i<NFTNTYPES; ++i)
145: if(q->vbase[i])
146: {
147: if(first) first = 0;
148: else p2str( ", " );
149: p2str(ftnames[ q->vbase[i] ]);
150: p2str( "(1" );
151: if(q1 = q->vdim)
152: for(q1 = q1->datap; q1 ; q1 = q1->nextp)
153: p2str( ",1" );
154: p2str( ")" );
155: }
156: p2str( ")" );
157: }
158: frchain(&genequivs);
159: }
160:
161:
162:
163:
164: prcomm(p)
165: register ptr p;
166: {
167: register int first;
168: register ptr q;
169:
170: p2stmt(0);
171: p2key(FCOMMON);
172: p2str( "/" );
173: p2str(p->comname);
174: p2str("/ ");
175: first = 1;
176: for(q = p->comchain ; q; q = q->nextp)
177: {
178: if(first) first=0;
179: else p2str(", ");
180: prname(q->datap);
181: }
182: dclchain(p->comchain, DOCOMMON);
183: }
184:
185:
186:
187: prname(p)
188: register ptr p;
189: {
190: register int i;
191:
192: switch(p->tag)
193: {
194: case TCONST:
195: p2str(p->leftp);
196: return;
197:
198: case TNAME:
199: if( ! p->vdcldone )
200: if(p->blklevel == 1)
201: dclit(p);
202: else mkftnp(p);
203: for(i=0; i<NFTNTYPES ; ++i)
204: if(p->vbase[i])
205: {
206: p2str(ftnames[p->vbase[i]]);
207: return;
208: }
209: fatal1("prname: no fortran types for name %s",
210: p->sthead->namep);
211:
212: case TFTNBLOCK:
213: for(i=0; i<NFTNTYPES ; ++i)
214: if(p->vbase[i])
215: {
216: p2str(ftnames[p->vbase[i]]);
217: return;
218: }
219: return;
220:
221: default:
222: badtag("prname", p->tag);
223: }
224: }
225:
226:
227:
228:
229: dclchain(chp, okcom)
230: ptr chp;
231: int okcom;
232: {
233: extern char *ftntypes[];
234: register ptr pn, p;
235: register int i;
236: int first, nline;
237: ptr q,v;
238: int ntypes;
239: int size,align,mask;
240: int subval;
241:
242: nline = 0;
243: for(pn = chp ; pn ; pn = pn->nextp)
244: {
245: p = pn->datap;
246: if( (p->tag==TNAME || p->tag==TTEMP) && p->vext!=0)
247: {
248: if(nline%NAMESPERLINE == 0)
249: {
250: p2stmt(0);
251: p2key(FEXTERNAL);
252: }
253: else p2str(", ");
254: ++nline;
255: p2str(ftnames[p->vextbase]);
256: }
257: }
258:
259:
260: for(pn = chp ; pn ; pn = pn->nextp)
261: {
262: p = pn->datap;
263: if( (p->tag==TNAME || p->tag==TTEMP) &&
264: p->vtype==TYSTRUCT && p->vclass!=CLARG)
265: {
266: ntypes = 0;
267: for(i=0; i<NFTNTYPES; ++i)
268: if(p->vbase[i])
269: ++ntypes;
270: if(ntypes > 1)
271: genequivs = mkchain(p, genequivs);
272: }
273: }
274:
275: for(i=0; i<NFTNTYPES; ++i)
276: {
277: nline = 0;
278: for(pn = chp; pn ; pn = pn->nextp)
279: {
280: p = pn->datap;
281: if( (p->tag==TNAME || p->tag==TTEMP) &&
282: p->vtype!=TYSUBR && p->vbase[i]!=0 &&
283: (okcom || p->vclass!=CLCOMMON) )
284: {
285: if(nline%NAMESPERLINE == 0)
286: {
287: p2stmt(0);
288: p2str(ftntypes[i]);
289: }
290: else p2str( ", " );
291: ++nline;
292: p2str(ftnames[p->vbase[i]]);
293: first = -1;
294:
295: if(p->vtype==TYCHAR || p->vtype==TYSTRUCT ||
296: (p->vtype==TYLCOMPLEX && tailor.lngcxtype==NULL))
297: {
298: p2str( "(" );
299: sizalign(p, &size,&align,&mask);
300: p2int( size/tailor.ftnsize[i] );
301: first = 0;
302: }
303: else if(p->vdim)
304: {
305: p2str( "(" );
306: first = 1;
307: }
308: if(first >=0)
309: {
310: if(q = p->vdim)
311: for(q = q->datap ; q ; q = q->nextp)
312: {
313: if(q->upperb == 0)
314: {
315: q->upperb = mkint(1);
316: if(q->lowerb)
317: {
318: frexpr(q->lowerb);
319: q->lowerb = 0;
320: }
321: }
322: else if(q->lowerb)
323: {
324: v = fold( mknode(TAROP,OPMINUS,
325: mkint(1),cpexpr(q->lowerb)) );
326: v = fold( mknode(TAROP,OPPLUS,
327: cpexpr(q->upperb),v) );
328: q->lowerb = 0;
329: q->upperb = v;
330: }
331: if(first) first = 0;
332: else p2str( ", " );
333: v = q->upperb = simple(RVAL,q->upperb);
334: if( (v->tag==TNAME && v->vclass==CLARG) ||
335: (isicon(v,&subval) && subval>0) )
336: prname(v);
337: else dclerr("invalid array bound",
338: p->sthead->namep);
339: }
340: p2str( ")" );
341: }
342: }
343: }
344: }
345: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.