![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to proc.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 proc.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1991, 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 "names.h"
26: #include "output.h"
27: #include "p1defs.h"
28:
29: #define EXNULL (union Expression *)0
30:
31: LOCAL dobss(), docomleng(), docommon(), doentry(),
32: epicode(), nextarg(), retval();
33:
34: static char Blank[] = BLANKCOMMON;
35:
36: static char *postfix[] = { "g", "h", "i",
37: #ifdef TYQUAD
38: "j",
39: #endif
40: "r", "d", "c", "z", "g", "h", "i" };
41:
42: chainp new_procs;
43: int prev_proc, proc_argchanges, proc_protochanges;
44:
45: void
46: changedtype(q)
47: Namep q;
48: {
49: char buf[200];
50: int qtype, type1;
51: register Extsym *e;
52: Argtypes *at;
53:
54: if (q->vtypewarned)
55: return;
56: q->vtypewarned = 1;
57: qtype = q->vtype;
58: e = &extsymtab[q->vardesc.varno];
59: if (!(at = e->arginfo)) {
60: if (!e->exused)
61: return;
62: }
63: else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
64: proc_protochanges++;
65: type1 = e->extype;
66: if (type1 == TYUNKNOWN)
67: return;
68: if (qtype == TYUNKNOWN)
69: /* e.g.,
70: subroutine foo
71: end
72: external foo
73: call goo(foo)
74: end
75: */
76: return;
77: sprintf(buf, "%.90s: inconsistent declarations:\n\
78: here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
79: qtype == TYSUBR ? "" : " function",
80: ftn_types[type1], type1 == TYSUBR ? "" : " function");
81: warn(buf);
82: }
83:
84: void
85: unamstring(q, s)
86: register Addrp q;
87: register char *s;
88: {
89: register int k;
90: register char *t;
91:
92: k = strlen(s);
93: if (k < IDENT_LEN) {
94: q->uname_tag = UNAM_IDENT;
95: t = q->user.ident;
96: }
97: else {
98: q->uname_tag = UNAM_CHARP;
99: q->user.Charp = t = mem(k+1, 0);
100: }
101: strcpy(t, s);
102: }
103:
104: static void
105: fix_entry_returns() /* for multiple entry points */
106: {
107: Addrp a;
108: int i;
109: struct Entrypoint *e;
110: Namep np;
111:
112: e = entries = (struct Entrypoint *)revchain((chainp)entries);
113: allargs = revchain(allargs);
114: if (!multitype)
115: return;
116:
117: /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
118:
119: for(i = TYINT1; i <= TYLOGICAL; i++)
120: if (a = xretslot[i])
121: sprintf(a->user.ident, "(*ret_val).%s",
122: postfix[i-TYINT1]);
123:
124: do {
125: np = e->enamep;
126: switch(np->vtype) {
127: case TYINT1:
128: case TYSHORT:
129: case TYLONG:
130: #ifdef TYQUAD
131: case TYQUAD:
132: #endif
133: case TYREAL:
134: case TYDREAL:
135: case TYCOMPLEX:
136: case TYDCOMPLEX:
137: case TYLOGICAL1:
138: case TYLOGICAL2:
139: case TYLOGICAL:
140: np->vstg = STGARG;
141: }
142: }
143: while(e = e->entnextp);
144: }
145:
146: static void
147: putentries(outfile) /* put out wrappers for multiple entries */
148: FILE *outfile;
149: {
150: char base[IDENT_LEN];
151: struct Entrypoint *e;
152: Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
153: chainp args, lengths, length_comp();
154: void listargs(), list_arg_types();
155: int i, k, mt, nL, type;
156: extern char *dfltarg[], **dfltproc;
157:
158: e = entries;
159: if (!e->enamep) /* only possible with erroneous input */
160: return;
161: nL = (nallargs + nallchargs) * sizeof(Namep *);
162: A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
163: Ae = A + nallargs;
164: Alp = (Namep **)(Ae1 = Ae + nallchargs);
165: i = k = 0;
166: for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
167: np = (Namep)args->datap;
168: if (np->vtype == TYCHAR && np->vclass != CLPROC)
169: *a1 = &Ae[i++];
170: }
171:
172: mt = multitype;
173: multitype = 0;
174: sprintf(base, "%s0_", e->enamep->cvarname);
175: do {
176: np = e->enamep;
177: lengths = length_comp(e, 0);
178: proctype = type = np->vtype;
179: if (protofile)
180: protowrite(protofile, type, np->cvarname, e, lengths);
181: nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
182: nice_printf(outfile, "%s", np->cvarname);
183: if (!Ansi) {
184: listargs(outfile, e, 0, lengths);
185: nice_printf(outfile, "\n");
186: }
187: list_arg_types(outfile, e, lengths, 0, "\n");
188: nice_printf(outfile, "{\n");
189: frchain(&lengths);
190: next_tab(outfile);
191: if (mt)
192: nice_printf(outfile,
193: "Multitype ret_val;\n%s(%d, &ret_val",
194: base, k); /*)*/
195: else if (ISCOMPLEX(type))
196: nice_printf(outfile, "%s(%d,%s", base, k,
197: xretslot[type]->user.ident); /*)*/
198: else if (type == TYCHAR)
199: nice_printf(outfile,
200: "%s(%d, ret_val, ret_val_len", base, k); /*)*/
201: else
202: nice_printf(outfile, "return %s(%d", base, k); /*)*/
203: k++;
204: memset((char *)A, 0, nL);
205: for(args = e->arglist; args; args = args->nextp) {
206: np = (Namep)args->datap;
207: A[np->argno] = np;
208: if (np->vtype == TYCHAR && np->vclass != CLPROC)
209: *Alp[np->argno] = np;
210: }
211: args = allargs;
212: for(a = A; a < Ae; a++, args = args->nextp)
213: nice_printf(outfile, ", %s", (np = *a)
214: ? np->cvarname
215: : ((Namep)args->datap)->vclass == CLPROC
216: ? dfltproc[((Namep)args->datap)->vtype]
217: : dfltarg[((Namep)args->datap)->vtype]);
218: for(; a < Ae1; a++)
219: if (np = *a)
220: nice_printf(outfile, ", %s_len", np->fvarname);
221: else
222: nice_printf(outfile, ", (ftnint)0");
223: nice_printf(outfile, /*(*/ ");\n");
224: if (mt) {
225: if (type == TYCOMPLEX)
226: nice_printf(outfile,
227: "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\nreturn 0;\n");
228: else if (type == TYDCOMPLEX)
229: nice_printf(outfile,
230: "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\nreturn 0;\n");
231: else nice_printf(outfile, "return ret_val.%s;\n",
232: postfix[type-TYINT1]);
233: }
234: nice_printf(outfile, "}\n");
235: prev_tab(outfile);
236: }
237: while(e = e->entnextp);
238: free((char *)A);
239: }
240:
241: static void
242: entry_goto(outfile)
243: FILEP outfile;
244: {
245: struct Entrypoint *e = entries;
246: int k = 0;
247:
248: nice_printf(outfile, "switch(n__) {\n");
249: next_tab(outfile);
250: while(e = e->entnextp)
251: nice_printf(outfile, "case %d: goto %s;\n", ++k,
252: user_label((long)(extsymtab - e->entryname - 1)));
253: nice_printf(outfile, "}\n\n");
254: prev_tab(outfile);
255: }
256:
257: /* start a new procedure */
258:
259: newproc()
260: {
261: if(parstate != OUTSIDE)
262: {
263: execerr("missing end statement", CNULL);
264: endproc();
265: }
266:
267: parstate = INSIDE;
268: procclass = CLMAIN; /* default */
269: }
270:
271: static void
272: zap_changes()
273: {
274: register chainp cp;
275: register Argtypes *at;
276:
277: /* arrange to get correct count of prototypes that would
278: change by running f2c again */
279:
280: if (prev_proc && proc_argchanges)
281: proc_protochanges++;
282: prev_proc = proc_argchanges = 0;
283: for(cp = new_procs; cp; cp = cp->nextp)
284: if (at = ((Namep)cp->datap)->arginfo)
285: at->changes &= ~1;
286: frchain(&new_procs);
287: }
288:
289: /* end of procedure. generate variables, epilogs, and prologs */
290:
291: endproc()
292: {
293: struct Labelblock *lp;
294: Extsym *ext;
295:
296: if(parstate < INDATA)
297: enddcl();
298: if(ctlstack >= ctls)
299: err("DO loop or BLOCK IF not closed");
300: for(lp = labeltab ; lp < labtabend ; ++lp)
301: if(lp->stateno!=0 && lp->labdefined==NO)
302: errstr("missing statement label %s",
303: convic(lp->stateno) );
304:
305: /* Save copies of the common variables in extptr -> allextp */
306:
307: for (ext = extsymtab; ext < nextext; ext++)
308: if (ext -> extstg == STGCOMMON && ext -> extp) {
309: extern int usedefsforcommon;
310:
311: /* Write out the abbreviations for common block reference */
312:
313: copy_data (ext -> extp);
314: if (usedefsforcommon) {
315: wr_abbrevs (c_file, 1, ext -> extp);
316: ext -> used_here = 1;
317: }
318: else
319: ext -> extp = CHNULL;
320:
321: }
322:
323: if (nentry > 1)
324: fix_entry_returns();
325: epicode();
326: donmlist();
327: dobss();
328: start_formatting ();
329: if (nentry > 1)
330: putentries(c_file);
331:
332: zap_changes();
333: procinit(); /* clean up for next procedure */
334: }
335:
336:
337:
338: /* End of declaration section of procedure. Allocate storage. */
339:
340: enddcl()
341: {
342: register struct Entrypoint *ep;
343: struct Entrypoint *ep0;
344: extern void freetemps();
345: chainp cp;
346: extern char *err_proc;
347: static char comblks[] = "common blocks";
348:
349: err_proc = comblks;
350: docommon();
351:
352: /* Now the hash table entries for fields of common blocks have STGCOMMON,
353: vdcldone, voffset, and varno. And the common blocks themselves have
354: their full sizes in extleng. */
355:
356: err_proc = "equivalences";
357: doequiv();
358:
359: err_proc = comblks;
360: docomleng();
361:
362: /* This implies that entry points in the declarations are buffered in
363: entries but not written out */
364:
365: err_proc = "entries";
366: if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
367: /* entries could be 0 in case of an error */
368: do doentry(ep);
369: while(ep = ep->entnextp);
370: entries = (struct Entrypoint *)revchain((chainp)ep0);
371: }
372:
373: err_proc = 0;
374: parstate = INEXEC;
375: p1put(P1_PROCODE);
376: freetemps();
377: if (earlylabs) {
378: for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
379: p1_label((long)cp->datap);
380: frchain(&earlylabs);
381: }
382: }
383:
384: /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
385:
386: /* Main program or Block data */
387:
388: startproc(progname, class)
389: Extsym * progname;
390: int class;
391: {
392: register struct Entrypoint *p;
393:
394: p = ALLOC(Entrypoint);
395: if(class == CLMAIN) {
396: puthead(CNULL, CLMAIN);
397: if (progname)
398: strcpy (main_alias, progname->cextname);
399: } else
400: puthead(CNULL, CLBLOCK);
401: if(class == CLMAIN)
402: newentry( mkname(" MAIN"), 0 )->extinit = 1;
403: p->entryname = progname;
404: entries = p;
405:
406: procclass = class;
407: fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
408: if(progname) {
409: fprintf(diagfile, " %s", progname->fextname);
410: procname = progname->cextname;
411: }
412: fprintf(diagfile, ":\n");
413: fflush(diagfile);
414: }
415:
416: /* subroutine or function statement */
417:
418: Extsym *newentry(v, substmsg)
419: register Namep v;
420: int substmsg;
421: {
422: register Extsym *p;
423: char buf[128], badname[64];
424: static int nbad = 0;
425: static char already[] = "external name already used";
426:
427: p = mkext(v->fvarname, addunder(v->cvarname));
428:
429: if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
430: {
431: sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
432: if (substmsg) {
433: sprintf(buf,"%s\n\tsubstituting \"%s\"",
434: already, badname);
435: dclerr(buf, v);
436: }
437: else
438: dclerr(already, v);
439: p = mkext(v->fvarname, badname);
440: }
441: v->vstg = STGAUTO;
442: v->vprocclass = PTHISPROC;
443: v->vclass = CLPROC;
444: if (p->extstg == STGEXT)
445: prev_proc = 1;
446: else
447: p->extstg = STGEXT;
448: p->extinit = YES;
449: v->vardesc.varno = p - extsymtab;
450: return(p);
451: }
452:
453:
454: entrypt(class, type, length, entry, args)
455: int class, type;
456: ftnint length;
457: Extsym *entry;
458: chainp args;
459: {
460: register Namep q;
461: register struct Entrypoint *p;
462:
463: if(class != CLENTRY)
464: puthead( procname = entry->cextname, class);
465: else
466: fprintf(diagfile, " entry ");
467: fprintf(diagfile, " %s:\n", entry->fextname);
468: fflush(diagfile);
469: q = mkname(entry->fextname);
470: if (type == TYSUBR)
471: q->vstg = STGEXT;
472:
473: type = lengtype(type, length);
474: if(class == CLPROC)
475: {
476: procclass = CLPROC;
477: proctype = type;
478: procleng = type == TYCHAR ? length : 0;
479: }
480:
481: p = ALLOC(Entrypoint);
482:
483: p->entnextp = entries;
484: entries = p;
485:
486: p->entryname = entry;
487: p->arglist = revchain(args);
488: p->enamep = q;
489:
490: if(class == CLENTRY)
491: {
492: class = CLPROC;
493: if(proctype == TYSUBR)
494: type = TYSUBR;
495: }
496:
497: q->vclass = class;
498: q->vprocclass = 0;
499: settype(q, type, length);
500: q->vprocclass = PTHISPROC;
501: /* hold all initial entry points till end of declarations */
502: if(parstate >= INDATA)
503: doentry(p);
504: }
505:
506: /* generate epilogs */
507:
508: /* epicode -- write out the proper function return mechanism at the end of
509: the procedure declaration. Handles multiple return value types, as
510: well as cooercion into the proper value */
511:
512: LOCAL epicode()
513: {
514: extern int lastwasbranch;
515:
516: if(procclass==CLPROC)
517: {
518: if(proctype==TYSUBR)
519: {
520:
521: /* Return a zero only when the alternate return mechanism has been
522: specified in the function header */
523:
524: if ((substars || Ansi) && lastwasbranch != YES)
525: p1_subr_ret (ICON(0));
526: }
527: else if (!multitype && lastwasbranch != YES)
528: retval(proctype);
529: }
530: else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
531: p1_subr_ret (ICON(0));
532: lastwasbranch = NO;
533: }
534:
535:
536: /* generate code to return value of type t */
537:
538: LOCAL retval(t)
539: register int t;
540: {
541: register Addrp p;
542:
543: switch(t)
544: {
545: case TYCHAR:
546: case TYCOMPLEX:
547: case TYDCOMPLEX:
548: break;
549:
550: case TYLOGICAL:
551: t = tylogical;
552: case TYINT1:
553: case TYADDR:
554: case TYSHORT:
555: case TYLONG:
556: #ifdef TYQUAD
557: case TYQUAD:
558: #endif
559: case TYREAL:
560: case TYDREAL:
561: case TYLOGICAL1:
562: case TYLOGICAL2:
563: p = (Addrp) cpexpr((expptr)retslot);
564: p->vtype = t;
565: p1_subr_ret (mkconv (t, fixtype((expptr)p)));
566: break;
567:
568: default:
569: badtype("retval", t);
570: }
571: }
572:
573:
574: /* Do parameter adjustments */
575:
576: procode(outfile)
577: FILE *outfile;
578: {
579: prolog(outfile, allargs);
580:
581: if (nentry > 1)
582: entry_goto(outfile);
583: }
584:
585: /* Finish bound computations now that all variables are declared.
586: * This used to be in setbound(), but under -u the following incurred
587: * an erroneous error message:
588: * subroutine foo(x,n)
589: * real x(n)
590: * integer n
591: */
592:
593: static void
594: dim_finish(v)
595: Namep v;
596: {
597: register struct Dimblock *p;
598: register expptr q;
599: register int i, nd;
600: extern expptr make_int_expr();
601:
602: p = v->vdim;
603: v->vdimfinish = 0;
604: nd = p->ndim;
605: doin_setbound = 1;
606: for(i = 0; i < nd; i++)
607: if (q = p->dims[i].dimexpr) {
608: q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
609: if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
610: errstr("bad dimension type for %.70s",
611: v->fvarname);
612: }
613: if (q = p->basexpr)
614: p->basexpr = make_int_expr(putx(fixtype(q)));
615: doin_setbound = 0;
616: }
617:
618: static void
619: duparg(q)
620: Namep q;
621: { errstr("duplicate argument %.80s", q->fvarname); }
622:
623: /*
624: manipulate argument lists (allocate argument slot positions)
625: * keep track of return types and labels
626: */
627:
628: LOCAL doentry(ep)
629: struct Entrypoint *ep;
630: {
631: register int type;
632: register Namep np;
633: chainp p, p1;
634: register Namep q;
635: Addrp mkarg(), rs;
636: int it, k;
637: extern char dflttype[26];
638: Extsym *entryname = ep->entryname;
639:
640: if (++nentry > 1)
641: p1_label((long)(extsymtab - entryname - 1));
642:
643: /* The main program isn't allowed to have parameters, so any given
644: parameters are ignored */
645:
646: if(procclass == CLMAIN || procclass == CLBLOCK)
647: return;
648:
649: /* So now we're working with something other than CLMAIN or CLBLOCK.
650: Determine the type of its return value. */
651:
652: impldcl( np = mkname(entryname->fextname) );
653: type = np->vtype;
654: proc_argchanges = prev_proc && type != entryname->extype;
655: entryname->extseen = 1;
656: if(proctype == TYUNKNOWN)
657: if( (proctype = type) == TYCHAR)
658: procleng = np->vleng ? np->vleng->constblock.Const.ci
659: : (ftnint) (-1);
660:
661: if(proctype == TYCHAR)
662: {
663: if(type != TYCHAR)
664: err("noncharacter entry of character function");
665:
666: /* Functions returning type char can only have multiple entries if all
667: entries return the same length */
668:
669: else if( (np->vleng ? np->vleng->constblock.Const.ci :
670: (ftnint) (-1)) != procleng)
671: err("mismatched character entry lengths");
672: }
673: else if(type == TYCHAR)
674: err("character entry of noncharacter function");
675: else if(type != proctype)
676: multitype = YES;
677: if(rtvlabel[type] == 0)
678: rtvlabel[type] = newlabel();
679: ep->typelabel = rtvlabel[type];
680:
681: if(type == TYCHAR)
682: {
683: if(chslot < 0)
684: {
685: chslot = nextarg(TYADDR);
686: chlgslot = nextarg(TYLENG);
687: }
688: np->vstg = STGARG;
689:
690: /* Put a new argument in the function, one which will hold the result of
691: a character function. This will have to be named sometime, probably in
692: mkarg(). */
693:
694: if(procleng < 0) {
695: np->vleng = (expptr) mkarg(TYLENG, chlgslot);
696: np->vleng->addrblock.uname_tag = UNAM_IDENT;
697: strcpy (np -> vleng -> addrblock.user.ident,
698: new_func_length());
699: }
700: if (!xretslot[TYCHAR]) {
701: xretslot[TYCHAR] = rs =
702: autovar(0, type, ISCONST(np->vleng)
703: ? np->vleng : ICON(0), "");
704: strcpy(rs->user.ident, "ret_val");
705: }
706: }
707:
708: /* Handle a complex return type -- declare a new parameter (pointer to
709: a complex value) */
710:
711: else if( ISCOMPLEX(type) ) {
712: if (!xretslot[type])
713: xretslot[type] =
714: autovar(0, type, EXNULL, " ret_val");
715: /* the blank is for use in out_addr */
716: np->vstg = STGARG;
717: if(cxslot < 0)
718: cxslot = nextarg(TYADDR);
719: }
720: else if (type != TYSUBR) {
721: if (type == TYUNKNOWN) {
722: dclerr("untyped function", np);
723: proctype = type = np->vtype =
724: dflttype[letter(np->fvarname[0])];
725: }
726: if (!xretslot[type])
727: xretslot[type] = retslot =
728: autovar(1, type, EXNULL, " ret_val");
729: /* the blank is for use in out_addr */
730: np->vstg = STGAUTO;
731: }
732:
733: for(p = ep->arglist ; p ; p = p->nextp)
734: if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
735: q->vknownarg = 1;
736: q->vardesc.varno = nextarg(TYADDR);
737: allargs = mkchain((char *)q, allargs);
738: q->argno = nallargs++;
739: }
740: else if (nentry == 1)
741: duparg(q);
742: else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
743: if ((Namep)p1->datap == q)
744: duparg(q);
745:
746: k = 0;
747: for(p = ep->arglist ; p ; p = p->nextp) {
748: if(! (( q = (Namep) (p->datap) )->vdcldone) )
749: {
750: impldcl(q);
751: q->vdcldone = YES;
752: if(q->vtype == TYCHAR)
753: {
754:
755: /* If we don't know the length of a char*(*) (i.e. a string), we must add
756: in this additional length argument. */
757:
758: ++nallchargs;
759: if (q->vclass == CLPROC)
760: nallchargs--;
761: else if (q->vleng == NULL) {
762: /* character*(*) */
763: q->vleng = (expptr)
764: mkarg(TYLENG, nextarg(TYLENG) );
765: unamstring((Addrp)q->vleng,
766: new_arg_length(q));
767: }
768: }
769: }
770: if (q->vdimfinish)
771: dim_finish(q);
772: if (q->vtype == TYCHAR && q->vclass != CLPROC)
773: k++;
774: }
775:
776: if (entryname->extype != type)
777: changedtype(np);
778:
779: /* save information for checking consistency of arg lists */
780:
781: it = infertypes;
782: if (entryname->exproto)
783: infertypes = 1;
784: save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
785: 0, np->fvarname, STGEXT, k, np->vtype, 2);
786: infertypes = it;
787: }
788:
789:
790:
791: LOCAL nextarg(type)
792: int type;
793: {
794: int k;
795: k = lastargslot;
796: lastargslot += typesize[type];
797: return(k);
798: }
799:
800: LOCAL
801: dim_check(q)
802: Namep q;
803: {
804: register struct Dimblock *vdim = q->vdim;
805:
806: if(!vdim->nelt || !ISICON(vdim->nelt))
807: dclerr("adjustable dimension on non-argument", q);
808: else if (vdim->nelt->constblock.Const.ci <= 0)
809: dclerr("nonpositive dimension", q);
810: }
811:
812: LOCAL dobss()
813: {
814: register struct Hashentry *p;
815: register Namep q;
816: int qstg, qclass, qtype;
817: Extsym *e;
818:
819: for(p = hashtab ; p<lasthash ; ++p)
820: if(q = p->varp)
821: {
822: qstg = q->vstg;
823: qtype = q->vtype;
824: qclass = q->vclass;
825:
826: if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
827: (qclass==CLVAR && qstg==STGUNKNOWN) ) {
828: if (!(q->vis_assigned | q->vimpldovar))
829: warn1("local variable %s never used",
830: q->fvarname);
831: }
832: else if(qclass==CLVAR && qstg==STGBSS)
833: { ; }
834:
835: /* Give external procedures the proper storage class */
836:
837: else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
838: && qstg!=STGARG) {
839: e = mkext(q->fvarname,addunder(q->cvarname));
840: e->extstg = STGEXT;
841: q->vardesc.varno = e - extsymtab;
842: if (e->extype != qtype)
843: changedtype(q);
844: }
845: if(qclass==CLVAR) {
846: if (qstg != STGARG && q->vdim)
847: dim_check(q);
848: } /* if qclass == CLVAR */
849: }
850:
851: }
852:
853:
854:
855: donmlist()
856: {
857: register struct Hashentry *p;
858: register Namep q;
859:
860: for(p=hashtab; p<lasthash; ++p)
861: if( (q = p->varp) && q->vclass==CLNAMELIST)
862: namelist(q);
863: }
864:
865:
866: /* iarrlen -- Returns the size of the array in bytes, or -1 */
867:
868: ftnint iarrlen(q)
869: register Namep q;
870: {
871: ftnint leng;
872:
873: leng = typesize[q->vtype];
874: if(leng <= 0)
875: return(-1);
876: if(q->vdim)
877: if( ISICON(q->vdim->nelt) )
878: leng *= q->vdim->nelt->constblock.Const.ci;
879: else return(-1);
880: if(q->vleng)
881: if( ISICON(q->vleng) )
882: leng *= q->vleng->constblock.Const.ci;
883: else return(-1);
884: return(leng);
885: }
886:
887: namelist(np)
888: Namep np;
889: {
890: register chainp q;
891: register Namep v;
892: int y;
893:
894: if (!np->visused)
895: return;
896: y = 0;
897:
898: for(q = np->varxptr.namelist ; q ; q = q->nextp)
899: {
900: vardcl( v = (Namep) (q->datap) );
901: if( !ONEOF(v->vstg, MSKSTATIC) )
902: dclerr("may not appear in namelist", v);
903: else {
904: v->vnamelist = 1;
905: v->visused = 1;
906: v->vsave = 1;
907: y = 1;
908: }
909: np->visused = y;
910: }
911: }
912:
913: /* docommon -- called at the end of procedure declarations, before
914: equivalences and the procedure body */
915:
916: LOCAL docommon()
917: {
918: register Extsym *extptr;
919: register chainp q, q1;
920: struct Dimblock *t;
921: expptr neltp;
922: register Namep comvar;
923: ftnint size;
924: int i, k, pref, type;
925: extern int type_pref[];
926:
927: for(extptr = extsymtab ; extptr<nextext ; ++extptr)
928: if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
929:
930: /* If a common declaration also had a list of variables ... */
931:
932: q = extptr->extp = revchain(q);
933: pref = 1;
934: for(k = TYCHAR; q ; q = q->nextp)
935: {
936: comvar = (Namep) (q->datap);
937:
938: if(comvar->vdcldone == NO)
939: vardcl(comvar);
940: type = comvar->vtype;
941: if (pref < type_pref[type])
942: pref = type_pref[k = type];
943: if(extptr->extleng % typealign[type] != 0) {
944: dclerr("common alignment", comvar);
945: --nerr; /* don't give bad return code for this */
946: #if 0
947: extptr->extleng = roundup(extptr->extleng, typealign[type]);
948: #endif
949: } /* if extptr -> extleng % */
950:
951: /* Set the offset into the common block */
952:
953: comvar->voffset = extptr->extleng;
954: comvar->vardesc.varno = extptr - extsymtab;
955: if(type == TYCHAR)
956: size = comvar->vleng->constblock.Const.ci;
957: else
958: size = typesize[type];
959: if(t = comvar->vdim)
960: if( (neltp = t->nelt) && ISCONST(neltp) )
961: size *= neltp->constblock.Const.ci;
962: else
963: dclerr("adjustable array in common", comvar);
964:
965: /* Adjust the length of the common block so far */
966:
967: extptr->extleng += size;
968: } /* for */
969:
970: extptr->extype = k;
971:
972: /* Determine curno and, if new, save this identifier chain */
973:
974: q1 = extptr->extp;
975: for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
976: if (struct_eq((chainp)q->datap, q1))
977: break;
978: if (q)
979: extptr->curno = extptr->maxno - i;
980: else {
981: extptr->curno = ++extptr->maxno;
982: extptr->allextp = mkchain((char *)extptr->extp,
983: extptr->allextp);
984: }
985: } /* if extptr -> extstg == STGCOMMON */
986:
987: /* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
988: varno. And the common block itself has its full size in extleng. */
989:
990: } /* docommon */
991:
992:
993: /* copy_data -- copy the Namep entries so they are available even after
994: the hash table is empty */
995:
996: copy_data (list)
997: chainp list;
998: {
999: for (; list; list = list -> nextp) {
1000: Namep namep = ALLOC (Nameblock);
1001: int size, nd, i;
1002: struct Dimblock *dp;
1003:
1004: cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
1005: namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
1006: namep->fvarname);
1007: namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
1008: ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
1009: : namep->fvarname;
1010: if (namep -> vleng)
1011: namep -> vleng = (expptr) cpexpr (namep -> vleng);
1012: if (namep -> vdim) {
1013: nd = namep -> vdim -> ndim;
1014: size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
1015: dp = (struct Dimblock *) ckalloc (size);
1016: cpn(size, (char *)namep->vdim, (char *)dp);
1017: namep -> vdim = dp;
1018: dp->nelt = (expptr)cpexpr(dp->nelt);
1019: for (i = 0; i < nd; i++) {
1020: dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
1021: } /* for */
1022: } /* if */
1023: list -> datap = (char *) namep;
1024: } /* for */
1025: } /* copy_data */
1026:
1027:
1028:
1029: LOCAL docomleng()
1030: {
1031: register Extsym *p;
1032:
1033: for(p = extsymtab ; p < nextext ; ++p)
1034: if(p->extstg == STGCOMMON)
1035: {
1036: if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
1037: && strcmp(Blank, p->cextname) )
1038: warn1("incompatible lengths for common block %.60s",
1039: p->fextname);
1040: if(p->maxleng < p->extleng)
1041: p->maxleng = p->extleng;
1042: p->extleng = 0;
1043: }
1044: }
1045:
1046:
1047: /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
1048:
1049: frtemp(p)
1050: Addrp p;
1051: {
1052: /* put block on chain of temps to be reclaimed */
1053: holdtemps = mkchain((char *)p, holdtemps);
1054: }
1055:
1056: void
1057: freetemps()
1058: {
1059: register chainp p, p1;
1060: register Addrp q;
1061: register int t;
1062:
1063: p1 = holdtemps;
1064: while(p = p1) {
1065: q = (Addrp)p->datap;
1066: t = q->vtype;
1067: if (t == TYCHAR && q->varleng != 0) {
1068: /* restore clobbered character string lengths */
1069: frexpr(q->vleng);
1070: q->vleng = ICON(q->varleng);
1071: }
1072: p1 = p->nextp;
1073: p->nextp = templist[t];
1074: templist[t] = p;
1075: }
1076: holdtemps = 0;
1077: }
1078:
1079: /* allocate an automatic variable slot for each of nelt variables */
1080:
1081: Addrp autovar(nelt0, t, lengp, name)
1082: register int nelt0, t;
1083: expptr lengp;
1084: char *name;
1085: {
1086: ftnint leng;
1087: register Addrp q;
1088: char *temp_name ();
1089: register int nelt = nelt0 > 0 ? nelt0 : 1;
1090: extern char *av_pfix[];
1091:
1092: if(t == TYCHAR)
1093: if( ISICON(lengp) )
1094: leng = lengp->constblock.Const.ci;
1095: else {
1096: Fatal("automatic variable of nonconstant length");
1097: }
1098: else
1099: leng = typesize[t];
1100:
1101: q = ALLOC(Addrblock);
1102: q->tag = TADDR;
1103: q->vtype = t;
1104: if(t == TYCHAR)
1105: {
1106: q->vleng = ICON(leng);
1107: q->varleng = leng;
1108: }
1109: q->vstg = STGAUTO;
1110: q->ntempelt = nelt;
1111: q->isarray = (nelt > 1);
1112: q->memoffset = ICON(0);
1113:
1114: /* kludge for nls so we can have ret_val rather than ret_val_4 */
1115: if (*name == ' ')
1116: unamstring(q, name);
1117: else {
1118: q->uname_tag = UNAM_IDENT;
1119: temp_name(av_pfix[t], ++autonum[t], q->user.ident);
1120: }
1121: if (nelt0 > 0)
1122: declare_new_addr (q);
1123: return(q);
1124: }
1125:
1126:
1127: /* Returns a temporary of the appropriate type. Will reuse existing
1128: temporaries when possible */
1129:
1130: Addrp mktmpn(nelt, type, lengp)
1131: int nelt;
1132: register int type;
1133: expptr lengp;
1134: {
1135: ftnint leng;
1136: chainp p, oldp;
1137: register Addrp q;
1138:
1139: if(type==TYUNKNOWN || type==TYERROR)
1140: badtype("mktmpn", type);
1141:
1142: if(type==TYCHAR)
1143: if(lengp && ISICON(lengp) )
1144: leng = lengp->constblock.Const.ci;
1145: else {
1146: err("adjustable length");
1147: return( (Addrp) errnode() );
1148: }
1149: else if (type > TYCHAR || type < TYADDR) {
1150: erri("mktmpn: unexpected type %d", type);
1151: exit(1);
1152: }
1153: /*
1154: * if a temporary of appropriate shape is on the templist,
1155: * remove it from the list and return it
1156: */
1157: for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp)
1158: {
1159: q = (Addrp) (p->datap);
1160: if(q->ntempelt==nelt &&
1161: (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
1162: {
1163: if(oldp)
1164: oldp->nextp = p->nextp;
1165: else
1166: templist[type] = p->nextp;
1167: free( (charptr) p);
1168: return(q);
1169: }
1170: }
1171: q = autovar(nelt, type, lengp, "");
1172: return(q);
1173: }
1174:
1175:
1176:
1177:
1178: /* mktmp -- create new local variable; call it something like name
1179: lengp is taken directly, not copied */
1180:
1181: Addrp mktmp(type, lengp)
1182: int type;
1183: expptr lengp;
1184: {
1185: Addrp rv;
1186: /* arrange for temporaries to be recycled */
1187: /* at the end of this statement... */
1188: rv = mktmpn(1,type,lengp);
1189: frtemp((Addrp)cpexpr((expptr)rv));
1190: return rv;
1191: }
1192:
1193: /* mktmp0 omits frtemp() */
1194: Addrp mktmp0(type, lengp)
1195: int type;
1196: expptr lengp;
1197: {
1198: Addrp rv;
1199: /* arrange for temporaries to be recycled */
1200: /* when this Addrp is freed */
1201: rv = mktmpn(1,type,lengp);
1202: rv->istemp = YES;
1203: return rv;
1204: }
1205:
1206: /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
1207:
1208: /* comblock -- Declare a new common block. Input parameters name the block;
1209: s will be NULL if the block is unnamed */
1210:
1211: Extsym *comblock(s)
1212: register char *s;
1213: {
1214: Extsym *p;
1215: register char *t;
1216: register int c, i;
1217: char cbuf[256], *s0;
1218:
1219: /* Give the unnamed common block a unique name */
1220:
1221: if(*s == 0)
1222: p = mkext(Blank,Blank);
1223: else {
1224: s0 = s;
1225: t = cbuf;
1226: for(i = 0; c = *t = *s++; t++)
1227: if (c == '_')
1228: i = 1;
1229: if (i)
1230: *t++ = '_';
1231: t[0] = '_';
1232: t[1] = 0;
1233: p = mkext(s0,cbuf);
1234: }
1235: if(p->extstg == STGUNKNOWN)
1236: p->extstg = STGCOMMON;
1237: else if(p->extstg != STGCOMMON)
1238: {
1239: errstr("%.68s cannot be a common block name", s);
1240: return(0);
1241: }
1242:
1243: return( p );
1244: }
1245:
1246:
1247: /* incomm -- add a new variable to a common declaration */
1248:
1249: incomm(c, v)
1250: Extsym *c;
1251: Namep v;
1252: {
1253: if (!c)
1254: return;
1255: if(v->vstg != STGUNKNOWN && !v->vimplstg)
1256: dclerr(v->vstg == STGARG
1257: ? "dummy arguments cannot be in common"
1258: : "incompatible common declaration", v);
1259: else
1260: {
1261: v->vstg = STGCOMMON;
1262: c->extp = mkchain((char *)v, c->extp);
1263: }
1264: }
1265:
1266:
1267:
1268:
1269: /* settype -- set the type or storage class of a Namep object. If
1270: v -> vstg == STGUNKNOWN && type < 0, attempt to reset vstg to be
1271: -type. This function will not change any earlier definitions in v,
1272: in will only attempt to fill out more information give the other params */
1273:
1274: settype(v, type, length)
1275: register Namep v;
1276: register int type;
1277: register ftnint length;
1278: {
1279: int type1;
1280:
1281: if(type == TYUNKNOWN)
1282: return;
1283:
1284: if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
1285: {
1286: v->vtype = TYSUBR;
1287: frexpr(v->vleng);
1288: v->vleng = 0;
1289: v->vimpltype = 0;
1290: }
1291: else if(type < 0) /* storage class set */
1292: {
1293: if(v->vstg == STGUNKNOWN)
1294: v->vstg = - type;
1295: else if(v->vstg != -type)
1296: dclerr("incompatible storage declarations", v);
1297: }
1298: else if(v->vtype == TYUNKNOWN || v->vimpltype && v->vtype != type)
1299: {
1300: if( (v->vtype = lengtype(type, length))==TYCHAR )
1301: if (length>=0)
1302: v->vleng = ICON(length);
1303: else if (parstate >= INDATA)
1304: v->vleng = ICON(1); /* avoid a memory fault */
1305: v->vimpltype = 0;
1306:
1307: if (v->vclass == CLPROC) {
1308: if (v->vstg == STGEXT
1309: && (type1 = extsymtab[v->vardesc.varno].extype)
1310: && type1 != v->vtype)
1311: changedtype(v);
1312: else if (v->vprocclass == PTHISPROC
1313: && (parstate >= INDATA
1314: || procclass == CLMAIN)
1315: && !xretslot[type]) {
1316: xretslot[type] = autovar(ONEOF(type,
1317: MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
1318: v->vleng, " ret_val");
1319: if (procclass == CLMAIN)
1320: errstr(
1321: "illegal use of %.60s (main program name)",
1322: v->fvarname);
1323: /* not completely right, but enough to */
1324: /* avoid memory faults; we won't */
1325: /* emit any C as we have illegal Fortran */
1326: }
1327: }
1328: }
1329: else if(v->vtype!=type) {
1330: incompat:
1331: dclerr("incompatible type declarations", v);
1332: }
1333: else if (type==TYCHAR)
1334: if (v->vleng && v->vleng->constblock.Const.ci != length)
1335: goto incompat;
1336: else if (parstate >= INDATA)
1337: v->vleng = ICON(1); /* avoid a memory fault */
1338: }
1339:
1340:
1341:
1342:
1343:
1344: /* lengtype -- returns the proper compiler type, given input of Fortran
1345: type and length specifier */
1346:
1347: lengtype(type, len)
1348: register int type;
1349: ftnint len;
1350: {
1351: register int length = (int)len;
1352: switch(type)
1353: {
1354: case TYREAL:
1355: if(length == typesize[TYDREAL])
1356: return(TYDREAL);
1357: if(length == typesize[TYREAL])
1358: goto ret;
1359: break;
1360:
1361: case TYCOMPLEX:
1362: if(length == typesize[TYDCOMPLEX])
1363: return(TYDCOMPLEX);
1364: if(length == typesize[TYCOMPLEX])
1365: goto ret;
1366: break;
1367:
1368: case TYINT1:
1369: case TYSHORT:
1370: case TYDREAL:
1371: case TYDCOMPLEX:
1372: case TYCHAR:
1373: case TYLOGICAL1:
1374: case TYLOGICAL2:
1375: case TYUNKNOWN:
1376: case TYSUBR:
1377: case TYERROR:
1378: #ifdef TYQUAD
1379: case TYQUAD:
1380: #endif
1381: goto ret;
1382:
1383: case TYLOGICAL:
1384: switch(length) {
1385: case 0: return tylog;
1386: case 1: return TYLOGICAL1;
1387: case 2: return TYLOGICAL2;
1388: case 4: goto ret;
1389: }
1390: #if 0 /*!!??!!*/
1391: if(length == typesize[TYLOGICAL])
1392: goto ret;
1393: #endif
1394: break;
1395:
1396: case TYLONG:
1397: if(length == 0)
1398: return(tyint);
1399: if (length == 1)
1400: return TYINT1;
1401: if(length == typesize[TYSHORT])
1402: return(TYSHORT);
1403: #ifdef TYQUAD
1404: if(length == typesize[TYQUAD] && use_tyquad)
1405: return(TYQUAD);
1406: #endif
1407: if(length == typesize[TYLONG])
1408: goto ret;
1409: break;
1410: default:
1411: badtype("lengtype", type);
1412: }
1413:
1414: if(len != 0)
1415: err("incompatible type-length combination");
1416:
1417: ret:
1418: return(type);
1419: }
1420:
1421:
1422:
1423:
1424:
1425: /* setintr -- Set Intrinsic function */
1426:
1427: setintr(v)
1428: register Namep v;
1429: {
1430: int k;
1431:
1432: if(v->vstg == STGUNKNOWN)
1433: v->vstg = STGINTR;
1434: else if(v->vstg!=STGINTR)
1435: dclerr("incompatible use of intrinsic function", v);
1436: if(v->vclass==CLUNKNOWN)
1437: v->vclass = CLPROC;
1438: if(v->vprocclass == PUNKNOWN)
1439: v->vprocclass = PINTRINSIC;
1440: else if(v->vprocclass != PINTRINSIC)
1441: dclerr("invalid intrinsic declaration", v);
1442: if(k = intrfunct(v->fvarname)) {
1443: if ((*(struct Intrpacked *)&k).f4)
1444: if (noextflag)
1445: goto unknown;
1446: else
1447: dcomplex_seen++;
1448: v->vardesc.varno = k;
1449: }
1450: else {
1451: unknown:
1452: dclerr("unknown intrinsic function", v);
1453: }
1454: }
1455:
1456:
1457:
1458: /* setext -- Set External declaration -- assume that unknowns will become
1459: procedures */
1460:
1461: setext(v)
1462: register Namep v;
1463: {
1464: if(v->vclass == CLUNKNOWN)
1465: v->vclass = CLPROC;
1466: else if(v->vclass != CLPROC)
1467: dclerr("invalid external declaration", v);
1468:
1469: if(v->vprocclass == PUNKNOWN)
1470: v->vprocclass = PEXTERNAL;
1471: else if(v->vprocclass != PEXTERNAL)
1472: dclerr("invalid external declaration", v);
1473: } /* setext */
1474:
1475:
1476:
1477:
1478: /* create dimensions block for array variable */
1479:
1480: setbound(v, nd, dims)
1481: register Namep v;
1482: int nd;
1483: struct Dims dims[ ];
1484: {
1485: register expptr q, t;
1486: register struct Dimblock *p;
1487: int i;
1488: extern chainp new_vars;
1489: char buf[256];
1490:
1491: if(v->vclass == CLUNKNOWN)
1492: v->vclass = CLVAR;
1493: else if(v->vclass != CLVAR)
1494: {
1495: dclerr("only variables may be arrays", v);
1496: return;
1497: }
1498:
1499: v->vdim = p = (struct Dimblock *)
1500: ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
1501: p->ndim = nd--;
1502: p->nelt = ICON(1);
1503: doin_setbound = 1;
1504:
1505: for(i = 0; i <= nd; ++i)
1506: {
1507: if( (q = dims[i].ub) == NULL)
1508: {
1509: if(i == nd)
1510: {
1511: frexpr(p->nelt);
1512: p->nelt = NULL;
1513: }
1514: else
1515: err("only last bound may be asterisk");
1516: p->dims[i].dimsize = ICON(1);
1517: ;
1518: p->dims[i].dimexpr = NULL;
1519: }
1520: else
1521: {
1522:
1523: if(dims[i].lb)
1524: {
1525: q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
1526: q = mkexpr(OPPLUS, q, ICON(1) );
1527: }
1528: if( ISCONST(q) )
1529: {
1530: p->dims[i].dimsize = q;
1531: p->dims[i].dimexpr = (expptr) PNULL;
1532: }
1533: else {
1534: sprintf(buf, " %s_dim%d", v->fvarname, i+1);
1535: p->dims[i].dimsize = (expptr)
1536: autovar(1, tyint, EXNULL, buf);
1537: p->dims[i].dimexpr = q;
1538: if (i == nd)
1539: v->vlastdim = new_vars;
1540: v->vdimfinish = 1;
1541: }
1542: if(p->nelt)
1543: p->nelt = mkexpr(OPSTAR, p->nelt,
1544: cpexpr(p->dims[i].dimsize) );
1545: }
1546: }
1547:
1548: q = dims[nd].lb;
1549: if(q == NULL)
1550: q = ICON(1);
1551:
1552: for(i = nd-1 ; i>=0 ; --i)
1553: {
1554: t = dims[i].lb;
1555: if(t == NULL)
1556: t = ICON(1);
1557: if(p->dims[i].dimsize)
1558: q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
1559: }
1560:
1561: if( ISCONST(q) )
1562: {
1563: p->baseoffset = q;
1564: p->basexpr = NULL;
1565: }
1566: else
1567: {
1568: sprintf(buf, " %s_offset", v->fvarname);
1569: p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
1570: p->basexpr = q;
1571: v->vdimfinish = 1;
1572: }
1573: doin_setbound = 0;
1574: }
1575:
1576:
1577:
1578: wr_abbrevs (outfile, function_head, vars)
1579: FILE *outfile;
1580: int function_head;
1581: chainp vars;
1582: {
1583: for (; vars; vars = vars -> nextp) {
1584: Namep name = (Namep) vars -> datap;
1585: if (!name->visused)
1586: continue;
1587:
1588: if (function_head)
1589: nice_printf (outfile, "#define ");
1590: else
1591: nice_printf (outfile, "#undef ");
1592: out_name (outfile, name);
1593:
1594: if (function_head) {
1595: Extsym *comm = &extsymtab[name -> vardesc.varno];
1596:
1597: nice_printf (outfile, " (");
1598: extern_out (outfile, comm);
1599: nice_printf (outfile, "%d.", comm->curno);
1600: nice_printf (outfile, "%s)", name->cvarname);
1601: } /* if function_head */
1602: nice_printf (outfile, "\n");
1603: } /* for */
1604: } /* wr_abbrevs */
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.