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