projects / unix-history / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Moved ttyfree() to ifdef broken. See my reply on the sio change.
[unix-history] / usr.bin / f2c / formatdata.c
CommitLineData
f1525c23
WH		 1/****************************************************************
2Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore.
3
4Permission to use, copy, modify, and distribute this software
5and its documentation for any purpose and without fee is hereby
6granted, provided that the above copyright notice appear in all
7copies and that both that the copyright notice and this
8permission notice and warranty disclaimer appear in supporting
9documentation, and that the names of AT&T Bell Laboratories or
10Bellcore or any of their entities not be used in advertising or
11publicity pertaining to distribution of the software without
12specific, written prior permission.
13
14AT&T and Bellcore disclaim all warranties with regard to this
15software, including all implied warranties of merchantability
16and fitness. In no event shall AT&T or Bellcore be liable for
17any special, indirect or consequential damages or any damages
18whatsoever resulting from loss of use, data or profits, whether
19in an action of contract, negligence or other tortious action,
20arising out of or in connection with the use or performance of
21this 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
32static int memno2info();
33
34extern char *initbname;
35extern void def_start();
36
37void 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
73int do_init_data(outfile, infile)
74FILE *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
132wr_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
170write_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
217void wr_one_init (outfile, varname, Values, keepit)
218FILE *outfile;
219char *varname;
220chainp *Values;
221int 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
374chainp data_value (infile, offset, type)
375FILE *infile;
376ftnint offset;
377int type;
378{
379 char line[MAX_INIT_LINE + 1], *pointer;
380 chainp vals, prev_val;
381#ifndef atol
382 long atol();
383#endif
384 char *newval;
385
386 if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
387 err ("data_value: error reading from intermediate file");
388 return CHNULL;
389 } /* if fgets */
390
391/* Get rid of the trailing newline */
392
393 if (line[0])
394 line[strlen (line) - 1] = '\0';
395
396#define iswhite(x) (isspace (x) || (x) == ',')
397
398 pointer = line;
399 prev_val = vals = CHNULL;
400
401 while (*pointer) {
402 register char *end_ptr, old_val;
403
404/* Move pointer to the start of the next word */
405
406 while (*pointer && iswhite (*pointer))
407 pointer++;
408 if (*pointer == '\0')
409 break;
410
411/* Move end_ptr to the end of the current word */
412
413 for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
414 end_ptr++)
415 ;
416
417 old_val = *end_ptr;
418 *end_ptr = '\0';
419
420/* Add this value to the end of the list */
421
422 if (ONEOF(type, MSKREAL|MSKCOMPLEX))
423 newval = cpstring(pointer);
424 else
425 newval = (char *)atol(pointer);
426 if (vals) {
427 prev_val->nextp = mkchain(newval, CHNULL);
428 prev_val = prev_val -> nextp;
429 } else
430 prev_val = vals = mkchain(newval, CHNULL);
431 *end_ptr = old_val;
432 pointer = end_ptr;
433 } /* while *pointer */
434
435 return mkchain((char *)offset, mkchain((char *)LONG_CAST type, vals));
436} /* data_value */
437
438 static void
439overlapping()
440{
441 extern char *filename0;
442 static int warned = 0;
443
444 if (warned)
445 return;
446 warned = 1;
447
448 fprintf(stderr, "Error");
449 if (filename0)
450 fprintf(stderr, " in file %s", filename0);
451 fprintf(stderr, ": overlapping initializations\n");
452 nerr++;
453 }
454
455 static void make_one_const();
456 static long charlen;
457
458void wr_output_values (outfile, namep, values)
459FILE *outfile;
460Namep namep;
461chainp values;
462{
463 int type = TYUNKNOWN;
464 struct Constblock Const;
465 static expptr Vlen;
466
467 if (namep)
468 type = namep -> vtype;
469
470/* Handle array initializations away from scalars */
471
472 if (namep && namep -> vdim)
473 wr_array_init (outfile, namep -> vtype, values);
474
475 else if (values->nextp && type != TYCHAR)
476 overlapping();
477
478 else {
479 make_one_const(type, &Const.Const, values);
480 Const.vtype = type;
481 Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
482 if (type== TYCHAR) {
483 if (!Vlen)
484 Vlen = ICON(0);
485 Const.vleng = Vlen;
486 Vlen->constblock.Const.ci = charlen;
487 out_const (outfile, &Const);
488 free (Const.Const.ccp);
489 }
490 else
491 out_const (outfile, &Const);
492 }
493 }
494
495
496wr_array_init (outfile, type, values)
497FILE *outfile;
498int type;
499chainp values;
500{
501 int size = typesize[type];
502 long index, main_index = 0;
503 int k;
504
505 if (type == TYCHAR) {
506 nice_printf(outfile, "\"");
507 k = 0;
508 if (Ansi != 1)
509 ch_ar_dim = -1;
510 }
511 else
512 nice_printf (outfile, "{ ");
513 while (values) {
514 struct Constblock Const;
515
516 index = ((long) ((chainp) values->datap)->datap) / size;
517 while (index > main_index) {
518
519/* Fill with zeros. The structure shorthand works because the compiler
520 will expand the "0" in braces to fill the size of the entire structure
521 */
522
523 switch (type) {
524 case TYREAL:
525 case TYDREAL:
526 nice_printf (outfile, "0.0,");
527 break;
528 case TYCOMPLEX:
529 case TYDCOMPLEX:
530 nice_printf (outfile, "{0},");
531 break;
532 case TYCHAR:
533 nice_printf(outfile, " ");
534 break;
535 default:
536 nice_printf (outfile, "0,");
537 break;
538 } /* switch */
539 main_index++;
540 } /* while index > main_index */
541
542 if (index < main_index)
543 overlapping();
544 else switch (type) {
545 case TYCHAR:
546 { int this_char;
547
548 if (k == ch_ar_dim) {
549 nice_printf(outfile, "\" \"");
550 k = 0;
551 }
552 this_char = (int) ((chainp) values->datap)->
553 nextp->nextp->datap;
554 if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
555 main_index += this_char;
556 k += this_char;
557 while(--this_char >= 0)
558 nice_printf(outfile, " ");
559 values = values -> nextp;
560 continue;
561 }
562 nice_printf(outfile, str_fmt[this_char], this_char);
563 k++;
564 } /* case TYCHAR */
565 break;
566
567 case TYINT1:
568 case TYSHORT:
569 case TYLONG:
570#ifdef TYQUAD
571 case TYQUAD:
572#endif
573 case TYREAL:
574 case TYDREAL:
575 case TYLOGICAL:
576 case TYLOGICAL1:
577 case TYLOGICAL2:
578 case TYCOMPLEX:
579 case TYDCOMPLEX:
580 make_one_const(type, &Const.Const, values);
581 Const.vtype = type;
582 Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
583 out_const(outfile, &Const);
584 break;
585 default:
586 erri("wr_array_init: bad type '%d'", type);
587 break;
588 } /* switch */
589 values = values->nextp;
590
591 main_index++;
592 if (values && type != TYCHAR)
593 nice_printf (outfile, ",");
594 } /* while values */
595
596 if (type == TYCHAR) {
597 nice_printf(outfile, "\"");
598 }
599 else
600 nice_printf (outfile, " }");
601} /* wr_array_init */
602
603
604 static void
605make_one_const(type, storage, values)
606 int type;
607 union Constant *storage;
608 chainp values;
609{
610 union Constant *Const;
611 register char **L;
612
613 if (type == TYCHAR) {
614 char *str, *str_ptr;
615 chainp v, prev;
616 int b = 0, k, main_index = 0;
617
618/* Find the max length of init string, by finding the highest offset
619 value stored in the list of initial values */
620
621 for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
622 ;
623 if (prev != CHNULL)
624 k = ((int) (((chainp) prev->datap)->datap)) + 2;
625 /* + 2 above for null char at end */
626 str = Alloc (k);
627 for (str_ptr = str; values; str_ptr++) {
628 int index = (int) (((chainp) values->datap)->datap);
629
630 if (index < main_index)
631 overlapping();
632 while (index > main_index++)
633 *str_ptr++ = ' ';
634
635 k = (int) (((chainp) values->datap)->nextp->nextp->datap);
636 if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
637 b = k;
638 break;
639 }
640 *str_ptr = k;
641 values = values -> nextp;
642 } /* for str_ptr */
643 *str_ptr = '\0';
644 Const = storage;
645 Const -> ccp = str;
646 Const -> ccp1.blanks = b;
647 charlen = str_ptr - str;
648 } else {
649 int i = 0;
650 chainp vals;
651
652 vals = ((chainp)values->datap)->nextp->nextp;
653 if (vals) {
654 L = (char **)storage;
655 do L[i++] = vals->datap;
656 while(vals = vals->nextp);
657 }
658
659 } /* else */
660
661} /* make_one_const */
662
663
664
665rdname (infile, vargroupp, name)
666FILE *infile;
667int *vargroupp;
668char *name;
669{
670 register int i, c;
671
672 c = getc (infile);
673
674 if (feof (infile))
675 return NO;
676
677 *vargroupp = c - '0';
678 for (i = 1;; i++) {
679 if (i >= NAME_MAX)
680 Fatal("rdname: oversize name");
681 c = getc (infile);
682 if (feof (infile))
683 return NO;
684 if (c == '\t')
685 break;
686 *name++ = c;
687 }
688 *name = 0;
689 return YES;
690} /* rdname */
691
692rdlong (infile, n)
693FILE *infile;
694ftnint *n;
695{
696 register int c;
697
698 for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
699 ;
700
701 if (feof (infile))
702 return NO;
703
704 for (*n = 0; isdigit (c); c = getc (infile))
705 *n = 10 * (*n) + c - '0';
706 return YES;
707} /* rdlong */
708
709
710 static int
711memno2info (memno, info)
712 int memno;
713 Namep *info;
714{
715 chainp this_var;
716 extern chainp new_vars;
717 extern struct Hashentry *hashtab, *lasthash;
718 struct Hashentry *entry;
719
720 for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
721 Addrp var = (Addrp) this_var->datap;
722
723 if (var == (Addrp) NULL)
724 Fatal("memno2info: null variable");
725 else if (var -> tag != TADDR)
726 Fatal("memno2info: bad tag");
727 if (memno == var -> memno) {
728 *info = (Namep) var;
729 return 1;
730 } /* if memno == var -> memno */
731 } /* for this_var = new_vars */
732
733 for (entry = hashtab; entry < lasthash; ++entry) {
734 Namep var = entry -> varp;
735
736 if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
737 *info = (Namep) var;
738 return 0;
739 } /* if entry -> vardesc.varno == memno */
740 } /* for entry = hashtab */
741
742 Fatal("memno2info: couldn't find memno");
743 return 0;
744} /* memno2info */
745
746 static chainp
747do_string(outfile, v, nloc)
748 FILEP outfile;
749 register chainp v;
750 ftnint *nloc;
751{
752 register chainp cp, v0;
753 ftnint dloc, k, loc;
754 unsigned long uk;
755 char buf[8], *comma;
756
757 nice_printf(outfile, "{");
758 cp = (chainp)v->datap;
759 loc = (ftnint)cp->datap;
760 comma = "";
761 for(v0 = v;;) {
762 switch((int)cp->nextp->datap) {
763 case TYBLANK:
764 k = (ftnint)cp->nextp->nextp->datap;
765 loc += k;
766 while(--k >= 0) {
767 nice_printf(outfile, "%s' '", comma);
768 comma = ", ";
769 }
770 break;
771 case TYCHAR:
772 uk = (ftnint)cp->nextp->nextp->datap;
773 sprintf(buf, chr_fmt[uk], uk);
774 nice_printf(outfile, "%s'%s'", comma, buf);
775 comma = ", ";
776 loc++;
777 break;
778 default:
779 goto done;
780 }
781 v0 = v;
782 if (!(v = v->nextp))
783 break;
784 cp = (chainp)v->datap;
785 dloc = (ftnint)cp->datap;
786 if (loc != dloc)
787 break;
788 }
789 done:
790 nice_printf(outfile, "}");
791 *nloc = loc;
792 return v0;
793 }
794
795 static chainp
796Ado_string(outfile, v, nloc)
797 FILEP outfile;
798 register chainp v;
799 ftnint *nloc;
800{
801 register chainp cp, v0;
802 ftnint dloc, k, loc;
803
804 nice_printf(outfile, "\"");
805 cp = (chainp)v->datap;
806 loc = (ftnint)cp->datap;
807 for(v0 = v;;) {
808 switch((int)cp->nextp->datap) {
809 case TYBLANK:
810 k = (ftnint)cp->nextp->nextp->datap;
811 loc += k;
812 while(--k >= 0)
813 nice_printf(outfile, " ");
814 break;
815 case TYCHAR:
816 k = (ftnint)cp->nextp->nextp->datap;
817 nice_printf(outfile, str_fmt[k], k);
818 loc++;
819 break;
820 default:
821 goto done;
822 }
823 v0 = v;
824 if (!(v = v->nextp))
825 break;
826 cp = (chainp)v->datap;
827 dloc = (ftnint)cp->datap;
828 if (loc != dloc)
829 break;
830 }
831 done:
832 nice_printf(outfile, "\"");
833 *nloc = loc;
834 return v0;
835 }
836
837 static char *
838Len(L,type)
839 long L;
840 int type;
841{
842 static char buf[24];
843 if (L == 1 && type != TYCHAR)
844 return "";
845 sprintf(buf, "[%ld]", L);
846 return buf;
847 }
848
849wr_equiv_init(outfile, memno, Values, iscomm)
850 FILE *outfile;
851 int memno;
852 chainp *Values;
853 int iscomm;
854{
855 struct Equivblock *eqv;
856 char *equiv_name ();
857 int btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
858 static char Blank[] = "";
859 register char *comma = Blank;
860 register chainp cp, v;
861 chainp sentinel, values, v1, vlast;
862 ftnint L, L1, dL, dloc, loc, loc0;
863 union Constant Const;
864 char imag_buf[50], real_buf[50];
865 int szshort = typesize[TYSHORT];
866 static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG,
867#ifdef TYQUAD
868 TYQUAD,
869#endif
870 TYREAL, TYDREAL, TYREAL, TYDREAL,
871 TYLOGICAL1, TYLOGICAL2,
872 TYLOGICAL, TYCHAR};
873 static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG,
874#ifdef TYQUAD
875 TYDREAL,
876#endif
877 TYLONG, TYDREAL, TYLONG, TYDREAL,
878 TYCHAR, TYSHORT,
879 TYLONG, TYCHAR};
880 extern int htype;
881 char *z;
882
883 /* add sentinel */
884 if (iscomm) {
885 L = extsymtab[memno].maxleng;
886 xtype = extsymtab[memno].extype;
887 }
888 else {
889 eqv = &eqvclass[memno];
890 L = eqv->eqvtop - eqv->eqvbottom;
891 xtype = eqv->eqvtype;
892 }
893
894 if (halign && typealign[typepref[xtype]] < typealign[htype])
895 xtype = htype;
896 *Values = values = revchain(vlast = *Values);
897
898 if (xtype != TYCHAR) {
899
900 /* unless the data include a value of the appropriate
901 * type, we add an extra element in an attempt
902 * to force correct alignment */
903
904 btype = basetype[xtype];
905 loc = 0;
906 for(v = *Values;;v = v->nextp) {
907 if (!v) {
908 dtype = typepref[xtype];
909 z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
910 k = typesize[dtype];
911 if (j = L % k)
912 L += k - j;
913 v = mkchain((char *)L,
914 mkchain((char *)LONG_CAST dtype,
915 mkchain(z, CHNULL)));
916 vlast = vlast->nextp =
917 mkchain((char *)v, CHNULL);
918 L += k;
919 break;
920 }
921 cp = (chainp)v->datap;
922 if (basetype[(int)cp->nextp->datap] == btype)
923 break;
924 dloc = (ftnint)cp->datap;
925 L1 = dloc - loc;
926 if (L1 > 0
927 && !(L1 % szshort)
928 && !(loc % szshort)
929 && btype <= type_choice[L1/szshort % 4]
930 && btype <= type_choice[loc/szshort % 4])
931 break;
932 dtype = (int)cp->nextp->datap;
933 loc = dloc + dtype == TYBLANK
934 ? (ftnint)cp->nextp->nextp->datap
935 : typesize[dtype];
936 }
937 }
938 sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
939 vlast->nextp = mkchain((char *)sentinel, CHNULL);
940
941 /* use doublereal fillers only if there are doublereal values */
942
943 k = TYLONG;
944 for(v = values; v; v = v->nextp)
945 if (ONEOF((int)((chainp)v->datap)->nextp->datap,
946 M(TYDREAL)|M(TYDCOMPLEX))) {
947 k = TYDREAL;
948 break;
949 }
950 type_choice[0] = k;
951
952 nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
953 next_tab(outfile);
954 loc = loc0 = k = 0;
955 curtype = -1;
956 for(v = values; v; v = v->nextp) {
957 cp = (chainp)v->datap;
958 dloc = (ftnint)cp->datap;
959 L = dloc - loc;
960 if (L < 0) {
961 overlapping();
962 if ((int)cp->nextp->datap != TYERROR) {
963 v1 = cp;
964 frchain(&v1);
965 v->datap = 0;
966 }
967 continue;
968 }
969 dtype = (int)cp->nextp->datap;
970 if (dtype == TYBLANK) {
971 dtype = TYCHAR;
972 wasblank = 1;
973 }
974 else
975 wasblank = 0;
976 if (curtype != dtype || L > 0) {
977 if (curtype != -1) {
978 L1 = (loc - loc0)/dL;
979 nice_printf(outfile, "%s e_%d%s;\n",
980 typename[curtype], ++k,
981 Len(L1,curtype));
982 }
983 curtype = dtype;
984 loc0 = dloc;
985 }
986 if (L > 0) {
987 if (xtype == TYCHAR)
988 filltype = TYCHAR;
989 else {
990 filltype = L % szshort ? TYCHAR
991 : type_choice[L/szshort % 4];
992 filltype1 = loc % szshort ? TYCHAR
993 : type_choice[loc/szshort % 4];
994 if (typesize[filltype] > typesize[filltype1])
995 filltype = filltype1;
996 }
997 L1 = L / typesize[filltype];
998 nice_printf(outfile, "%s fill_%d[%ld];\n",
999 typename[filltype], ++k, L1);
1000 loc = dloc;
1001 }
1002 if (wasblank) {
1003 loc += (ftnint)cp->nextp->nextp->datap;
1004 dL = 1;
1005 }
1006 else {
1007 dL = typesize[dtype];
1008 loc += dL;
1009 }
1010 }
1011 nice_printf(outfile, "} %s = { ", iscomm
1012 ? extsymtab[memno].cextname
1013 : equiv_name(eqvmemno, CNULL));
1014 loc = 0;
1015 for(v = values; ; v = v->nextp) {
1016 cp = (chainp)v->datap;
1017 if (!cp)
1018 continue;
1019 dtype = (int)cp->nextp->datap;
1020 if (dtype == TYERROR)
1021 break;
1022 dloc = (ftnint)cp->datap;
1023 if (dloc > loc) {
1024 nice_printf(outfile, "%s{0}", comma);
1025 comma = ", ";
1026 loc = dloc;
1027 }
1028 if (comma != Blank)
1029 nice_printf(outfile, ", ");
1030 comma = ", ";
1031 if (dtype == TYCHAR || dtype == TYBLANK) {
1032 v = Ansi == 1 ? Ado_string(outfile, v, &loc)
1033 : do_string(outfile, v, &loc);
1034 continue;
1035 }
1036 make_one_const(dtype, &Const, v);
1037 switch(dtype) {
1038 case TYLOGICAL:
1039 case TYLOGICAL2:
1040 case TYLOGICAL1:
1041 if (Const.ci < 0 || Const.ci > 1)
1042 errl(
1043 "wr_equiv_init: unexpected logical value %ld",
1044 Const.ci);
1045 nice_printf(outfile,
1046 Const.ci ? "TRUE_" : "FALSE_");
1047 break;
1048 case TYINT1:
1049 case TYSHORT:
1050 case TYLONG:
1051#ifdef TYQUAD
1052 case TYQUAD:
1053#endif
1054 nice_printf(outfile, "%ld", Const.ci);
1055 break;
1056 case TYREAL:
1057 nice_printf(outfile, "%s",
1058 flconst(real_buf, Const.cds[0]));
1059 break;
1060 case TYDREAL:
1061 nice_printf(outfile, "%s", Const.cds[0]);
1062 break;
1063 case TYCOMPLEX:
1064 nice_printf(outfile, "%s, %s",
1065 flconst(real_buf, Const.cds[0]),
1066 flconst(imag_buf, Const.cds[1]));
1067 break;
1068 case TYDCOMPLEX:
1069 nice_printf(outfile, "%s, %s",
1070 Const.cds[0], Const.cds[1]);
1071 break;
1072 default:
1073 erri("unexpected type %d in wr_equiv_init",
1074 dtype);
1075 }
1076 loc += typesize[dtype];
1077 }
1078 nice_printf(outfile, " };\n\n");
1079 prev_tab(outfile);
1080 frchain(&sentinel);
1081 }
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.