![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to formatdata.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 formatdata.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1991, 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 "names.h"
27: #include "format.h"
28:
29: #define MAX_INIT_LINE 100
30: #define NAME_MAX 64
31:
32: static int memno2info();
33:
34: extern char *initbname;
35: extern void def_start();
36:
37: void list_init_data(Infile, Inname, outfile)
38: FILE **Infile, *outfile;
39: char *Inname;
40: {
41: FILE *sortfp;
42: int status;
43:
44: fclose(*Infile);
45: *Infile = 0;
46:
47: if (status = dsort(Inname, sortfname))
48: fatali ("sort failed, status %d", status);
49:
50: scrub(Inname); /* optionally unlink Inname */
51:
52: if ((sortfp = fopen(sortfname, textread)) == NULL)
53: Fatal("Couldn't open sorted initialization data");
54:
55: do_init_data(outfile, sortfp);
56: fclose(sortfp);
57: scrub(sortfname);
58:
59: /* Insert a blank line after any initialized data */
60:
61: nice_printf (outfile, "\n");
62:
63: if (debugflag && infname)
64: /* don't back block data file up -- it won't be overwritten */
65: backup(initfname, initbname);
66: } /* list_init_data */
67:
68:
69:
70: /* do_init_data -- returns YES when at least one declaration has been
71: written */
72:
73: int do_init_data(outfile, infile)
74: FILE *outfile, *infile;
75: {
76: char varname[NAME_MAX], ovarname[NAME_MAX];
77: ftnint offset;
78: ftnint type;
79: int vargroup; /* 0 --> init, 1 --> equiv, 2 --> common */
80: int did_one = 0; /* True when one has been output */
81: chainp values = CHNULL; /* Actual data values */
82: int keepit = 0;
83: Namep np;
84:
85: ovarname[0] = '\0';
86:
87: while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset)
88: && rdlong (infile, &type)) {
89: if (strcmp (varname, ovarname)) {
90:
91: /* If this is a new variable name, the old initialization has been
92: completed */
93:
94: wr_one_init(outfile, ovarname, &values, keepit);
95:
96: strcpy (ovarname, varname);
97: values = CHNULL;
98: if (vargroup == 0) {
99: if (memno2info(atoi(varname+2), &np)) {
100: if (((Addrp)np)->uname_tag != UNAM_NAME) {
101: err("do_init_data: expected NAME");
102: goto Keep;
103: }
104: np = ((Addrp)np)->user.name;
105: }
106: if (!(keepit = np->visused) && !np->vimpldovar)
107: warn1("local variable %s never used",
108: np->fvarname);
109: }
110: else {
111: Keep:
112: keepit = 1;
113: }
114: if (keepit && !did_one) {
115: nice_printf (outfile, "/* Initialized data */\n\n");
116: did_one = YES;
117: }
118: } /* if strcmp */
119:
120: values = mkchain((char *)data_value(infile, offset, (int)type), values);
121: } /* while */
122:
123: /* Write out the last declaration */
124:
125: wr_one_init (outfile, ovarname, &values, keepit);
126:
127: return did_one;
128: } /* do_init_data */
129:
130:
131: ftnint
132: wr_char_len(outfile, dimp, n, extra1)
133: FILE *outfile;
134: int n;
135: struct Dimblock *dimp;
136: int extra1;
137: {
138: int i, nd;
139: expptr e;
140: ftnint rv;
141:
142: if (!dimp) {
143: nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n);
144: return n + extra1;
145: }
146: nice_printf(outfile, "[%d", n);
147: nd = dimp->ndim;
148: rv = n;
149: for(i = 0; i < nd; i++) {
150: e = dimp->dims[i].dimsize;
151: if (!ISICON (e))
152: err ("wr_char_len: nonconstant array size");
153: else {
154: nice_printf(outfile, "*%ld", e->constblock.Const.ci);
155: rv *= e->constblock.Const.ci;
156: }
157: }
158: /* extra1 allows for stupid C compilers that complain about
159: * too many initializers in
160: * char x[2] = "ab";
161: */
162: nice_printf(outfile, extra1 ? "+1]" : "]");
163: return extra1 ? rv+1 : rv;
164: }
165:
166: static int ch_ar_dim = -1; /* length of each element of char string array */
167: static int eqvmemno; /* kludge */
168:
169: static void
170: write_char_init(outfile, Values, namep)
171: FILE *outfile;
172: chainp *Values;
173: Namep namep;
174: {
175: struct Equivblock *eqv;
176: long size;
177: struct Dimblock *dimp;
178: int i, nd, type;
179: expptr ds;
180:
181: if (!namep)
182: return;
183: if(nequiv >= maxequiv)
184: many("equivalences", 'q', maxequiv);
185: eqv = &eqvclass[nequiv];
186: eqv->eqvbottom = 0;
187: type = namep->vtype;
188: size = type == TYCHAR
189: ? namep->vleng->constblock.Const.ci
190: : typesize[type];
191: if (dimp = namep->vdim)
192: for(i = 0, nd = dimp->ndim; i < nd; i++) {
193: ds = dimp->dims[i].dimsize;
194: if (!ISICON(ds))
195: err("write_char_values: nonconstant array size");
196: else
197: size *= ds->constblock.Const.ci;
198: }
199: *Values = revchain(*Values);
200: eqv->eqvtop = size;
201: eqvmemno = ++lastvarno;
202: eqv->eqvtype = type;
203: wr_equiv_init(outfile, nequiv, Values, 0);
204: def_start(outfile, namep->cvarname, CNULL, "");
205: if (type == TYCHAR)
206: ind_printf(0, outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
207: else
208: ind_printf(0, outfile, dimp
209: ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n",
210: c_type_decl(type,0), eqvmemno);
211: }
212:
213: /* wr_one_init -- outputs the initialization of the variable pointed to
214: by info. When is_addr is true, info is an Addrp; otherwise,
215: treat it as a Namep */
216:
217: void wr_one_init (outfile, varname, Values, keepit)
218: FILE *outfile;
219: char *varname;
220: chainp *Values;
221: int keepit;
222: {
223: static int memno;
224: static union {
225: Namep name;
226: Addrp addr;
227: } info;
228: Namep namep;
229: int is_addr, size, type;
230: ftnint last, loc;
231: int is_scalar = 0;
232: char *array_comment = NULL, *name;
233: chainp cp, values;
234: extern char datachar[];
235: static int e1[3] = {1, 0, 1};
236: ftnint x;
237: extern int hsize;
238:
239: if (!keepit)
240: goto done;
241: if (varname == NULL || varname[1] != '.')
242: goto badvar;
243:
244: /* Get back to a meaningful representation; find the given memno in one
245: of the appropriate tables (user-generated variables in the hash table,
246: system-generated variables in a separate list */
247:
248: memno = atoi(varname + 2);
249: switch(varname[0]) {
250: case 'q':
251: /* Must subtract eqvstart when the source file
252: * contains more than one procedure.
253: */
254: wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0);
255: goto done;
256: case 'Q':
257: /* COMMON initialization (BLOCK DATA) */
258: wr_equiv_init(outfile, memno, Values, 1);
259: goto done;
260: case 'v':
261: break;
262: default:
263: badvar:
264: errstr("wr_one_init: unknown variable name '%s'", varname);
265: goto done;
266: }
267:
268: is_addr = memno2info (memno, &info.name);
269: if (info.name == (Namep) NULL) {
270: err ("wr_one_init -- unknown variable");
271: return;
272: }
273: if (is_addr) {
274: if (info.addr -> uname_tag != UNAM_NAME) {
275: erri ("wr_one_init -- couldn't get name pointer; tag is %d",
276: info.addr -> uname_tag);
277: namep = (Namep) NULL;
278: nice_printf (outfile, " /* bad init data */");
279: } else
280: namep = info.addr -> user.name;
281: } else
282: namep = info.name;
283:
284: /* check for character initialization */
285:
286: *Values = values = revchain(*Values);
287: type = info.name->vtype;
288: if (type == TYCHAR) {
289: for(last = 0; values; values = values->nextp) {
290: cp = (chainp)values->datap;
291: loc = (ftnint)cp->datap;
292: if (loc > last) {
293: write_char_init(outfile, Values, namep);
294: goto done;
295: }
296: last = (int)cp->nextp->datap == TYBLANK
297: ? loc + (int)cp->nextp->nextp->datap
298: : loc + 1;
299: }
300: if (halign && info.name->tag == TNAME) {
301: nice_printf(outfile, "static struct { %s fill; char val",
302: halign);
303: x = wr_char_len(outfile, namep->vdim, ch_ar_dim =
304: info.name -> vleng -> constblock.Const.ci, 1);
305: if (x %= hsize)
306: nice_printf(outfile, "; char fill2[%ld]", hsize - x);
307: name = info.name->cvarname;
308: nice_printf(outfile, "; } %s_st = { 0,", name);
309: wr_output_values(outfile, namep, *Values);
310: nice_printf(outfile, " };\n");
311: ch_ar_dim = -1;
312: def_start(outfile, name, CNULL, name);
313: ind_printf(0, outfile, "_st.val\n");
314: goto done;
315: }
316: }
317: else {
318: size = typesize[type];
319: loc = 0;
320: for(; values; values = values->nextp) {
321: if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) {
322: write_char_init(outfile, Values, namep);
323: goto done;
324: }
325: last = ((long) ((chainp) values->datap)->datap) / size;
326: if (last - loc > 4) {
327: write_char_init(outfile, Values, namep);
328: goto done;
329: }
330: loc = last;
331: }
332: }
333: values = *Values;
334:
335: nice_printf (outfile, "static %s ", c_type_decl (type, 0));
336:
337: if (is_addr)
338: write_nv_ident (outfile, info.addr);
339: else
340: out_name (outfile, info.name);
341:
342: if (namep)
343: is_scalar = namep -> vdim == (struct Dimblock *) NULL;
344:
345: if (namep && !is_scalar)
346: array_comment = type == TYCHAR
347: ? 0 : wr_ardecls(outfile, namep->vdim, 1L);
348:
349: if (type == TYCHAR)
350: if (ISICON (info.name -> vleng))
351:
352: /* We'll make single strings one character longer, so that we can use the
353: standard C initialization. All this does is pad an extra zero onto the
354: end of the string */
355: wr_char_len(outfile, namep->vdim, ch_ar_dim =
356: info.name -> vleng -> constblock.Const.ci, e1[Ansi]);
357: else
358: err ("variable length character initialization");
359:
360: if (array_comment)
361: nice_printf (outfile, "%s", array_comment);
362:
363: nice_printf (outfile, " = ");
364: wr_output_values (outfile, namep, values);
365: ch_ar_dim = -1;
366: nice_printf (outfile, ";\n");
367: done:
368: frchain(Values);
369: } /* wr_one_init */
370:
371:
372:
373:
374: chainp data_value (infile, offset, type)
375: FILE *infile;
376: ftnint offset;
377: int type;
378: {
379: char line[MAX_INIT_LINE + 1], *pointer;
380: chainp vals, prev_val;
381: long atol();
382: char *newval;
383:
384: if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
385: err ("data_value: error reading from intermediate file");
386: return CHNULL;
387: } /* if fgets */
388:
389: /* Get rid of the trailing newline */
390:
391: if (line[0])
392: line[strlen (line) - 1] = '\0';
393:
394: #define iswhite(x) (isspace (x) || (x) == ',')
395:
396: pointer = line;
397: prev_val = vals = CHNULL;
398:
399: while (*pointer) {
400: register char *end_ptr, old_val;
401:
402: /* Move pointer to the start of the next word */
403:
404: while (*pointer && iswhite (*pointer))
405: pointer++;
406: if (*pointer == '\0')
407: break;
408:
409: /* Move end_ptr to the end of the current word */
410:
411: for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
412: end_ptr++)
413: ;
414:
415: old_val = *end_ptr;
416: *end_ptr = '\0';
417:
418: /* Add this value to the end of the list */
419:
420: if (ONEOF(type, MSKREAL|MSKCOMPLEX))
421: newval = cpstring(pointer);
422: else
423: newval = (char *)atol(pointer);
424: if (vals) {
425: prev_val->nextp = mkchain(newval, CHNULL);
426: prev_val = prev_val -> nextp;
427: } else
428: prev_val = vals = mkchain(newval, CHNULL);
429: *end_ptr = old_val;
430: pointer = end_ptr;
431: } /* while *pointer */
432:
433: return mkchain((char *)offset, mkchain((char *)LONG_CAST type, vals));
434: } /* data_value */
435:
436: static void
437: overlapping()
438: {
439: extern char *filename0;
440: static int warned = 0;
441:
442: if (warned)
443: return;
444: warned = 1;
445:
446: fprintf(stderr, "Error");
447: if (filename0)
448: fprintf(stderr, " in file %s", filename0);
449: fprintf(stderr, ": overlapping initializations\n");
450: nerr++;
451: }
452:
453: static void make_one_const();
454: static long charlen;
455:
456: void wr_output_values (outfile, namep, values)
457: FILE *outfile;
458: Namep namep;
459: chainp values;
460: {
461: int type = TYUNKNOWN;
462: struct Constblock Const;
463: static expptr Vlen;
464:
465: if (namep)
466: type = namep -> vtype;
467:
468: /* Handle array initializations away from scalars */
469:
470: if (namep && namep -> vdim)
471: wr_array_init (outfile, namep -> vtype, values);
472:
473: else if (values->nextp && type != TYCHAR)
474: overlapping();
475:
476: else {
477: make_one_const(type, &Const.Const, values);
478: Const.vtype = type;
479: Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
480: if (type== TYCHAR) {
481: if (!Vlen)
482: Vlen = ICON(0);
483: Const.vleng = Vlen;
484: Vlen->constblock.Const.ci = charlen;
485: out_const (outfile, &Const);
486: free (Const.Const.ccp);
487: }
488: else
489: out_const (outfile, &Const);
490: }
491: }
492:
493:
494: wr_array_init (outfile, type, values)
495: FILE *outfile;
496: int type;
497: chainp values;
498: {
499: int size = typesize[type];
500: long index, main_index = 0;
501: int k;
502:
503: if (type == TYCHAR) {
504: nice_printf(outfile, "\"");
505: k = 0;
506: if (Ansi != 1)
507: ch_ar_dim = -1;
508: }
509: else
510: nice_printf (outfile, "{ ");
511: while (values) {
512: struct Constblock Const;
513:
514: index = ((long) ((chainp) values->datap)->datap) / size;
515: while (index > main_index) {
516:
517: /* Fill with zeros. The structure shorthand works because the compiler
518: will expand the "0" in braces to fill the size of the entire structure
519: */
520:
521: switch (type) {
522: case TYREAL:
523: case TYDREAL:
524: nice_printf (outfile, "0.0,");
525: break;
526: case TYCOMPLEX:
527: case TYDCOMPLEX:
528: nice_printf (outfile, "{0},");
529: break;
530: case TYCHAR:
531: nice_printf(outfile, " ");
532: break;
533: default:
534: nice_printf (outfile, "0,");
535: break;
536: } /* switch */
537: main_index++;
538: } /* while index > main_index */
539:
540: if (index < main_index)
541: overlapping();
542: else switch (type) {
543: case TYCHAR:
544: { int this_char;
545:
546: if (k == ch_ar_dim) {
547: nice_printf(outfile, "\" \"");
548: k = 0;
549: }
550: this_char = (int) ((chainp) values->datap)->
551: nextp->nextp->datap;
552: if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
553: main_index += this_char;
554: k += this_char;
555: while(--this_char >= 0)
556: nice_printf(outfile, " ");
557: values = values -> nextp;
558: continue;
559: }
560: nice_printf(outfile, str_fmt[this_char], this_char);
561: k++;
562: } /* case TYCHAR */
563: break;
564:
565: case TYINT1:
566: case TYSHORT:
567: case TYLONG:
568: #ifdef TYQUAD
569: case TYQUAD:
570: #endif
571: case TYREAL:
572: case TYDREAL:
573: case TYLOGICAL:
574: case TYLOGICAL1:
575: case TYLOGICAL2:
576: case TYCOMPLEX:
577: case TYDCOMPLEX:
578: make_one_const(type, &Const.Const, values);
579: Const.vtype = type;
580: Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
581: out_const(outfile, &Const);
582: break;
583: default:
584: erri("wr_array_init: bad type '%d'", type);
585: break;
586: } /* switch */
587: values = values->nextp;
588:
589: main_index++;
590: if (values && type != TYCHAR)
591: nice_printf (outfile, ",");
592: } /* while values */
593:
594: if (type == TYCHAR) {
595: nice_printf(outfile, "\"");
596: }
597: else
598: nice_printf (outfile, " }");
599: } /* wr_array_init */
600:
601:
602: static void
603: make_one_const(type, storage, values)
604: int type;
605: union Constant *storage;
606: chainp values;
607: {
608: union Constant *Const;
609: register char **L;
610:
611: if (type == TYCHAR) {
612: char *str, *str_ptr;
613: chainp v, prev;
614: int b = 0, k, main_index = 0;
615:
616: /* Find the max length of init string, by finding the highest offset
617: value stored in the list of initial values */
618:
619: for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
620: ;
621: if (prev != CHNULL)
622: k = ((int) (((chainp) prev->datap)->datap)) + 2;
623: /* + 2 above for null char at end */
624: str = Alloc (k);
625: for (str_ptr = str; values; str_ptr++) {
626: int index = (int) (((chainp) values->datap)->datap);
627:
628: if (index < main_index)
629: overlapping();
630: while (index > main_index++)
631: *str_ptr++ = ' ';
632:
633: k = (int) (((chainp) values->datap)->nextp->nextp->datap);
634: if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
635: b = k;
636: break;
637: }
638: *str_ptr = k;
639: values = values -> nextp;
640: } /* for str_ptr */
641: *str_ptr = '\0';
642: Const = storage;
643: Const -> ccp = str;
644: Const -> ccp1.blanks = b;
645: charlen = str_ptr - str;
646: } else {
647: int i = 0;
648: chainp vals;
649:
650: vals = ((chainp)values->datap)->nextp->nextp;
651: if (vals) {
652: L = (char **)storage;
653: do L[i++] = vals->datap;
654: while(vals = vals->nextp);
655: }
656:
657: } /* else */
658:
659: } /* make_one_const */
660:
661:
662:
663: rdname (infile, vargroupp, name)
664: FILE *infile;
665: int *vargroupp;
666: char *name;
667: {
668: register int i, c;
669:
670: c = getc (infile);
671:
672: if (feof (infile))
673: return NO;
674:
675: *vargroupp = c - '0';
676: for (i = 1;; i++) {
677: if (i >= NAME_MAX)
678: Fatal("rdname: oversize name");
679: c = getc (infile);
680: if (feof (infile))
681: return NO;
682: if (c == '\t')
683: break;
684: *name++ = c;
685: }
686: *name = 0;
687: return YES;
688: } /* rdname */
689:
690: rdlong (infile, n)
691: FILE *infile;
692: ftnint *n;
693: {
694: register int c;
695:
696: for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
697: ;
698:
699: if (feof (infile))
700: return NO;
701:
702: for (*n = 0; isdigit (c); c = getc (infile))
703: *n = 10 * (*n) + c - '0';
704: return YES;
705: } /* rdlong */
706:
707:
708: static int
709: memno2info (memno, info)
710: int memno;
711: Namep *info;
712: {
713: chainp this_var;
714: extern chainp new_vars;
715: extern struct Hashentry *hashtab, *lasthash;
716: struct Hashentry *entry;
717:
718: for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
719: Addrp var = (Addrp) this_var->datap;
720:
721: if (var == (Addrp) NULL)
722: Fatal("memno2info: null variable");
723: else if (var -> tag != TADDR)
724: Fatal("memno2info: bad tag");
725: if (memno == var -> memno) {
726: *info = (Namep) var;
727: return 1;
728: } /* if memno == var -> memno */
729: } /* for this_var = new_vars */
730:
731: for (entry = hashtab; entry < lasthash; ++entry) {
732: Namep var = entry -> varp;
733:
734: if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
735: *info = (Namep) var;
736: return 0;
737: } /* if entry -> vardesc.varno == memno */
738: } /* for entry = hashtab */
739:
740: Fatal("memno2info: couldn't find memno");
741: return 0;
742: } /* memno2info */
743:
744: static chainp
745: do_string(outfile, v, nloc)
746: FILEP outfile;
747: register chainp v;
748: ftnint *nloc;
749: {
750: register chainp cp, v0;
751: ftnint dloc, k, loc;
752: unsigned long uk;
753: char buf[8], *comma;
754:
755: nice_printf(outfile, "{");
756: cp = (chainp)v->datap;
757: loc = (ftnint)cp->datap;
758: comma = "";
759: for(v0 = v;;) {
760: switch((int)cp->nextp->datap) {
761: case TYBLANK:
762: k = (ftnint)cp->nextp->nextp->datap;
763: loc += k;
764: while(--k >= 0) {
765: nice_printf(outfile, "%s' '", comma);
766: comma = ", ";
767: }
768: break;
769: case TYCHAR:
770: uk = (ftnint)cp->nextp->nextp->datap;
771: sprintf(buf, chr_fmt[uk], uk);
772: nice_printf(outfile, "%s'%s'", comma, buf);
773: comma = ", ";
774: loc++;
775: break;
776: default:
777: goto done;
778: }
779: v0 = v;
780: if (!(v = v->nextp))
781: break;
782: cp = (chainp)v->datap;
783: dloc = (ftnint)cp->datap;
784: if (loc != dloc)
785: break;
786: }
787: done:
788: nice_printf(outfile, "}");
789: *nloc = loc;
790: return v0;
791: }
792:
793: static chainp
794: Ado_string(outfile, v, nloc)
795: FILEP outfile;
796: register chainp v;
797: ftnint *nloc;
798: {
799: register chainp cp, v0;
800: ftnint dloc, k, loc;
801:
802: nice_printf(outfile, "\"");
803: cp = (chainp)v->datap;
804: loc = (ftnint)cp->datap;
805: for(v0 = v;;) {
806: switch((int)cp->nextp->datap) {
807: case TYBLANK:
808: k = (ftnint)cp->nextp->nextp->datap;
809: loc += k;
810: while(--k >= 0)
811: nice_printf(outfile, " ");
812: break;
813: case TYCHAR:
814: k = (ftnint)cp->nextp->nextp->datap;
815: nice_printf(outfile, str_fmt[k], k);
816: loc++;
817: break;
818: default:
819: goto done;
820: }
821: v0 = v;
822: if (!(v = v->nextp))
823: break;
824: cp = (chainp)v->datap;
825: dloc = (ftnint)cp->datap;
826: if (loc != dloc)
827: break;
828: }
829: done:
830: nice_printf(outfile, "\"");
831: *nloc = loc;
832: return v0;
833: }
834:
835: static char *
836: Len(L,type)
837: long L;
838: int type;
839: {
840: static char buf[24];
841: if (L == 1 && type != TYCHAR)
842: return "";
843: sprintf(buf, "[%ld]", L);
844: return buf;
845: }
846:
847: wr_equiv_init(outfile, memno, Values, iscomm)
848: FILE *outfile;
849: int memno;
850: chainp *Values;
851: int iscomm;
852: {
853: struct Equivblock *eqv;
854: char *equiv_name ();
855: int curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
856: static char Blank[] = "";
857: register char *comma = Blank;
858: register chainp cp, v;
859: chainp sentinel, values, v1;
860: ftnint L, L1, dL, dloc, loc, loc0;
861: union Constant Const;
862: char imag_buf[50], real_buf[50];
863: int szshort = typesize[TYSHORT];
864: static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG,
865: #ifdef TYQUAD
866: TYQUAD,
867: #endif
868: TYREAL, TYDREAL, TYREAL, TYDREAL,
869: TYLOGICAL1, TYLOGICAL2,
870: TYLOGICAL, TYCHAR};
871: extern int htype;
872: char *z;
873:
874: /* add sentinel */
875: if (iscomm) {
876: L = extsymtab[memno].maxleng;
877: xtype = extsymtab[memno].extype;
878: }
879: else {
880: eqv = &eqvclass[memno];
881: L = eqv->eqvtop - eqv->eqvbottom;
882: xtype = eqv->eqvtype;
883: }
884:
885: if (halign && typealign[typepref[xtype]] < typealign[htype])
886: xtype = htype;
887:
888: if (xtype != TYCHAR) {
889:
890: /* unless the data include a value of the appropriate
891: * type, we add an extra element in an attempt
892: * to force correct alignment */
893:
894: for(v = *Values;;v = v->nextp) {
895: if (!v) {
896: dtype = typepref[xtype];
897: z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
898: k = typesize[dtype];
899: if (j = L % k)
900: L += k - j;
901: v = mkchain((char *)L,
902: mkchain((char *)LONG_CAST dtype,
903: mkchain(z, CHNULL)));
904: *Values = mkchain((char *)v, *Values);
905: L += k;
906: break;
907: }
908: if ((int)((chainp)v->datap)->nextp->datap == xtype)
909: break;
910: }
911: }
912:
913: sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
914: *Values = values = revchain(mkchain((char *)sentinel, *Values));
915:
916: /* use doublereal fillers only if there are doublereal values */
917:
918: k = TYLONG;
919: for(v = values; v; v = v->nextp)
920: if (ONEOF((int)((chainp)v->datap)->nextp->datap,
921: M(TYDREAL)|M(TYDCOMPLEX))) {
922: k = TYDREAL;
923: break;
924: }
925: type_choice[0] = k;
926:
927: nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
928: next_tab(outfile);
929: loc = loc0 = k = 0;
930: curtype = -1;
931: for(v = values; v; v = v->nextp) {
932: cp = (chainp)v->datap;
933: dloc = (ftnint)cp->datap;
934: L = dloc - loc;
935: if (L < 0) {
936: overlapping();
937: if ((int)cp->nextp->datap != TYERROR) {
938: v1 = cp;
939: frchain(&v1);
940: v->datap = 0;
941: }
942: continue;
943: }
944: dtype = (int)cp->nextp->datap;
945: if (dtype == TYBLANK) {
946: dtype = TYCHAR;
947: wasblank = 1;
948: }
949: else
950: wasblank = 0;
951: if (curtype != dtype || L > 0) {
952: if (curtype != -1) {
953: L1 = (loc - loc0)/dL;
954: nice_printf(outfile, "%s e_%d%s;\n",
955: typename[curtype], ++k,
956: Len(L1,curtype));
957: }
958: curtype = dtype;
959: loc0 = dloc;
960: }
961: if (L > 0) {
962: if (xtype == TYCHAR)
963: filltype = TYCHAR;
964: else {
965: filltype = L % szshort ? TYCHAR
966: : type_choice[L/szshort % 4];
967: filltype1 = loc % szshort ? TYCHAR
968: : type_choice[loc/szshort % 4];
969: if (typesize[filltype] > typesize[filltype1])
970: filltype = filltype1;
971: }
972: L1 = L / typesize[filltype];
973: nice_printf(outfile, "%s fill_%d[%ld];\n",
974: typename[filltype], ++k, L1);
975: loc = dloc;
976: }
977: if (wasblank) {
978: loc += (ftnint)cp->nextp->nextp->datap;
979: dL = 1;
980: }
981: else {
982: dL = typesize[dtype];
983: loc += dL;
984: }
985: }
986: nice_printf(outfile, "} %s = { ", iscomm
987: ? extsymtab[memno].cextname
988: : equiv_name(eqvmemno, CNULL));
989: loc = 0;
990: for(v = values; ; v = v->nextp) {
991: cp = (chainp)v->datap;
992: if (!cp)
993: continue;
994: dtype = (int)cp->nextp->datap;
995: if (dtype == TYERROR)
996: break;
997: dloc = (ftnint)cp->datap;
998: if (dloc > loc) {
999: nice_printf(outfile, "%s{0}", comma);
1000: comma = ", ";
1001: loc = dloc;
1002: }
1003: if (comma != Blank)
1004: nice_printf(outfile, ", ");
1005: comma = ", ";
1006: if (dtype == TYCHAR || dtype == TYBLANK) {
1007: v = Ansi == 1 ? Ado_string(outfile, v, &loc)
1008: : do_string(outfile, v, &loc);
1009: continue;
1010: }
1011: make_one_const(dtype, &Const, v);
1012: switch(dtype) {
1013: case TYLOGICAL:
1014: case TYLOGICAL2:
1015: case TYLOGICAL1:
1016: if (Const.ci < 0 || Const.ci > 1)
1017: errl(
1018: "wr_equiv_init: unexpected logical value %ld",
1019: Const.ci);
1020: nice_printf(outfile,
1021: Const.ci ? "TRUE_" : "FALSE_");
1022: break;
1023: case TYINT1:
1024: case TYSHORT:
1025: case TYLONG:
1026: #ifdef TYQUAD
1027: case TYQUAD:
1028: #endif
1029: nice_printf(outfile, "%ld", Const.ci);
1030: break;
1031: case TYREAL:
1032: nice_printf(outfile, "%s",
1033: flconst(real_buf, Const.cds[0]));
1034: break;
1035: case TYDREAL:
1036: nice_printf(outfile, "%s", Const.cds[0]);
1037: break;
1038: case TYCOMPLEX:
1039: nice_printf(outfile, "%s, %s",
1040: flconst(real_buf, Const.cds[0]),
1041: flconst(imag_buf, Const.cds[1]));
1042: break;
1043: case TYDCOMPLEX:
1044: nice_printf(outfile, "%s, %s",
1045: Const.cds[0], Const.cds[1]);
1046: break;
1047: default:
1048: erri("unexpected type %d in wr_equiv_init",
1049: dtype);
1050: }
1051: loc += typesize[dtype];
1052: }
1053: nice_printf(outfile, " };\n\n");
1054: prev_tab(outfile);
1055: frchain(&sentinel);
1056: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.