1 /****************************************************************
2 Copyright 1990, 1992 - 1996 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 "iob.h"
28 
29 
30 /* Names generated by the translator are guaranteed to be unique from the
31    Fortan names because Fortran does not allow underscores in identifiers,
32    and all of the system generated names do have underscores.  The various
33    naming conventions are outlined below:
34 
35 	FORMAT		APPLICATION
36    ----------------------------------------------------------------------
37 	io_#		temporaries generated by IO calls; these will
38 			contain the device number (e.g. 5, 6, 0)
39 	ret_val		function return value, required for complex and
40 			character functions.
41 	ret_val_len	length of the return value in character functions
42 
43 	ssss_len	length of character argument "ssss"
44 
45 	c_#		member of the literal pool, where # is an
46 			arbitrary label assigned by the system
47 	cs_#		short integer constant in the literal pool
48 	t_#		expression temporary, # is the depth of arguments
49 			on the stack.
50 	L#		label "#", given by user in the Fortran program.
51 			This is unique because Fortran labels are numeric
52 	pad_#		label on an init field required for alignment
53 	xxx_init	label on a common block union, if a block data
54 			requires a separate declaration
55 */
56 
57 /* generate variable references */
58 
59  char *
60 #ifdef KR_headers
c_type_decl(type,is_extern)61 c_type_decl(type, is_extern)
62 	int type;
63 	int is_extern;
64 #else
65 c_type_decl(int type, int is_extern)
66 #endif
67 {
68     static char buff[100];
69 
70     switch (type) {
71 	case TYREAL:	if (!is_extern || !forcedouble)
72 				{ strcpy (buff, "real");break; }
73 	case TYDREAL:	strcpy (buff, "doublereal");	break;
74 	case TYCOMPLEX:	if (is_extern)
75 			    strcpy (buff, "/* Complex */ VOID");
76 			else
77 			    strcpy (buff, "complex");
78 			break;
79 	case TYDCOMPLEX:if (is_extern)
80 			    strcpy (buff, "/* Double Complex */ VOID");
81 			else
82 			    strcpy (buff, "doublecomplex");
83 			break;
84 	case TYADDR:
85 	case TYINT1:
86 	case TYSHORT:
87 	case TYLONG:
88 #ifdef TYQUAD
89 	case TYQUAD:
90 #endif
91 	case TYLOGICAL1:
92 	case TYLOGICAL2:
93 	case TYLOGICAL:	strcpy(buff, type_name[type]);
94 			break;
95 	case TYCHAR:	if (is_extern)
96 			    strcpy (buff, "/* Character */ VOID");
97 			else
98 			    strcpy (buff, "char");
99 			break;
100 
101         case TYUNKNOWN:	strcpy (buff, "UNKNOWN");
102 
103 /* If a procedure's type is unknown, assume it's a subroutine */
104 
105 			if (!is_extern)
106 			    break;
107 
108 /* Subroutines must return an INT, because they might return a label
109    value.  Even if one doesn't, the caller will EXPECT it to. */
110 
111 	case TYSUBR:	strcpy (buff, "/* Subroutine */ int");
112 							break;
113 	case TYERROR:	strcpy (buff, "ERROR");		break;
114 	case TYVOID:	strcpy (buff, "void");		break;
115 	case TYCILIST:	strcpy (buff, "cilist");	break;
116 	case TYICILIST:	strcpy (buff, "icilist");	break;
117 	case TYOLIST:	strcpy (buff, "olist");		break;
118 	case TYCLLIST:	strcpy (buff, "cllist");	break;
119 	case TYALIST:	strcpy (buff, "alist");		break;
120 	case TYINLIST:	strcpy (buff, "inlist");	break;
121 	case TYFTNLEN:	strcpy (buff, "ftnlen");	break;
122 	default:	sprintf (buff, "BAD DECL '%d'", type);
123 							break;
124     } /* switch */
125 
126     return buff;
127 } /* c_type_decl */
128 
129 
130  char *
new_func_length(Void)131 new_func_length(Void)
132 { return "ret_val_len"; }
133 
134  char *
135 #ifdef KR_headers
new_arg_length(arg)136 new_arg_length(arg)
137 	Namep arg;
138 #else
139 new_arg_length(Namep arg)
140 #endif
141 {
142 	static char buf[64];
143 	char *fmt = "%s_len", *s = arg->fvarname;
144 	switch(*s) {
145 	  case 'r':
146 		if (!strcmp(s+1, "et_val"))
147 			goto adjust_fmt;
148 		break;
149 	  case 'h':
150 	  case 'i':
151 		if (!s[1]) {
152  adjust_fmt:
153 			fmt = "%s_length"; /* avoid conflict with libF77 */
154 			}
155 	  }
156 	sprintf (buf, fmt, s);
157 	return buf;
158 } /* new_arg_length */
159 
160 
161 /* declare_new_addr -- Add a new local variable to the function, given a
162    pointer to an Addrblock structure (which must have the uname_tag set)
163    This list of idents will be printed in reverse (i.e., chronological)
164    order */
165 
166  void
167 #ifdef KR_headers
declare_new_addr(addrp)168 declare_new_addr(addrp)
169 	struct Addrblock *addrp;
170 #else
171 declare_new_addr(struct Addrblock *addrp)
172 #endif
173 {
174     extern chainp new_vars;
175 
176     new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
177 } /* declare_new_addr */
178 
179 
180  void
181 #ifdef KR_headers
wr_nv_ident_help(outfile,addrp)182 wr_nv_ident_help(outfile, addrp)
183 	FILE *outfile;
184 	struct Addrblock *addrp;
185 #else
186 wr_nv_ident_help(FILE *outfile, struct Addrblock *addrp)
187 #endif
188 {
189     int eltcount = 0;
190 
191     if (addrp == (struct Addrblock *) NULL)
192 	return;
193 
194     if (addrp -> isarray) {
195 	frexpr (addrp -> memoffset);
196 	addrp -> memoffset = ICON(0);
197 	eltcount = addrp -> ntempelt;
198 	addrp -> ntempelt = 0;
199 	addrp -> isarray = 0;
200     } /* if */
201     out_addr (outfile, addrp);
202     if (eltcount)
203 	nice_printf (outfile, "[%d]", eltcount);
204 } /* wr_nv_ident_help */
205 
206  int
207 #ifdef KR_headers
nv_type_help(addrp)208 nv_type_help(addrp)
209 	struct Addrblock *addrp;
210 #else
211 nv_type_help(struct Addrblock *addrp)
212 #endif
213 {
214     if (addrp == (struct Addrblock *) NULL)
215 	return -1;
216 
217     return addrp -> vtype;
218 } /* nv_type_help */
219 
220 
221 /* lit_name -- returns a unique identifier for the given literal.  Make
222    the label useful, when possible.  For example:
223 
224 	1 -> c_1		(constant 1)
225 	2 -> c_2		(constant 2)
226 	1000 -> c_1000		(constant 1000)
227 	1000000 -> c_b<memno>	(big constant number)
228 	1.2 -> c_1_2		(constant 1.2)
229 	1.234345 -> c_b<memno>	(big constant number)
230 	-1 -> c_n1		(constant -1)
231 	-1.0 -> c_n1_0		(constant -1.0)
232 	.true. -> c_true	(constant true)
233 	.false. -> c_false	(constant false)
234 	default -> c_b<memno>	(default label)
235 */
236 
237  char *
238 #ifdef KR_headers
lit_name(litp)239 lit_name(litp)
240 	struct Literal *litp;
241 #else
242 lit_name(struct Literal *litp)
243 #endif
244 {
245 	static char buf[CONST_IDENT_MAX];
246 	ftnint val;
247 	char *fmt;
248 
249 	if (litp == (struct Literal *) NULL)
250 		return NULL;
251 
252 	switch (litp -> littype) {
253 	case TYINT1:
254 		val = litp -> litval.litival;
255 		if (val >= 256 || val < -255)
256 			sprintf (buf, "ci1_b%ld", litp -> litnum);
257 		else if (val < 0)
258 			sprintf (buf, "ci1_n%ld", -val);
259 		else
260 			sprintf(buf, "ci1__%ld", val);
261 		break;
262         case TYSHORT:
263 		val = litp -> litval.litival;
264 		if (val >= 32768 || val <= -32769)
265 			sprintf (buf, "cs_b%ld", litp -> litnum);
266 		else if (val < 0)
267 			sprintf (buf, "cs_n%ld", -val);
268 		else
269 			sprintf (buf, "cs__%ld", val);
270 		break;
271 	case TYLONG:
272 #ifdef TYQUAD
273 	case TYQUAD:
274 #endif
275 		val = litp -> litval.litival;
276 		if (val >= 100000 || val <= -10000)
277 			sprintf (buf, "c_b%ld", litp -> litnum);
278 		else if (val < 0)
279 			sprintf (buf, "c_n%ld", -val);
280 		else
281 			sprintf (buf, "c__%ld", val);
282 		break;
283 	case TYLOGICAL1:
284 		fmt = "cl1_%s";
285 		goto spr_logical;
286 	case TYLOGICAL2:
287 		fmt = "cl2_%s";
288 		goto spr_logical;
289 	case TYLOGICAL:
290 		fmt = "c_%s";
291 	spr_logical:
292 		sprintf (buf, fmt, (litp -> litval.litival
293 					? "true" : "false"));
294 		break;
295 	case TYREAL:
296 	case TYDREAL:
297 		/* Given a limit of 6 or 8 character on external names,	*/
298 		/* few f.p. values can be meaningfully encoded in the	*/
299 		/* constant name.  Just going with the default cb_#	*/
300 		/* seems to be the best course for floating-point	*/
301 		/* constants.	*/
302 	case TYCHAR:
303 		/* Shouldn't be any of these */
304 	case TYADDR:
305 	case TYCOMPLEX:
306 	case TYDCOMPLEX:
307 	case TYSUBR:
308 	default:
309 		sprintf (buf, "c_b%ld", litp -> litnum);
310     } /* switch */
311     return buf;
312 } /* lit_name */
313 
314 
315 
316  char *
317 #ifdef KR_headers
comm_union_name(count)318 comm_union_name(count)
319 	int count;
320 #else
321 comm_union_name(int count)
322 #endif
323 {
324 	static char buf[12];
325 
326 	sprintf(buf, "%d", count);
327 	return buf;
328 	}
329 
330 
331 
332 
333 /* wr_globals -- after every function has been translated, we need to
334    output the global declarations, such as the static table of constant
335    values */
336 
337  void
338 #ifdef KR_headers
wr_globals(outfile)339 wr_globals(outfile)
340 	FILE *outfile;
341 #else
342 wr_globals(FILE *outfile)
343 #endif
344 {
345     struct Literal *litp, *lastlit;
346     extern int hsize;
347     char *litname;
348     int did_one, t;
349     struct Constblock cb;
350     ftnint x, y;
351 
352     if (nliterals == 0)
353 	return;
354 
355     lastlit = litpool + nliterals;
356     did_one = 0;
357     for (litp = litpool; litp < lastlit; litp++) {
358 	if (!litp->lituse)
359 		continue;
360 	litname = lit_name(litp);
361 	if (!did_one) {
362 		margin_printf(outfile, "/* Table of constant values */\n\n");
363 		did_one = 1;
364 		}
365 	cb.vtype = litp->littype;
366 	if (litp->littype == TYCHAR) {
367 		x = litp->litval.litival2[0] + litp->litval.litival2[1];
368 		if (y = x % hsize)
369 			x += y = hsize - y;
370 		nice_printf(outfile,
371 			"static struct { %s fill; char val[%ld+1];", halign, x);
372 		nice_printf(outfile, " char fill2[%ld];", hsize - 1);
373 		nice_printf(outfile, " } %s_st = { 0,", litname);
374 		cb.vleng = ICON(litp->litval.litival2[0]);
375 		cb.Const.ccp = litp->cds[0];
376 		cb.Const.ccp1.blanks = litp->litval.litival2[1] + y;
377 		cb.vtype = TYCHAR;
378 		out_const(outfile, &cb);
379 		frexpr(cb.vleng);
380 		nice_printf(outfile, " };\n");
381 		nice_printf(outfile, "#define %s %s_st.val\n", litname, litname);
382 		continue;
383 		}
384 	nice_printf(outfile, "static %s %s = ",
385 		c_type_decl(litp->littype,0), litname);
386 
387 	t = litp->littype;
388 	if (ONEOF(t, MSKREAL|MSKCOMPLEX)) {
389 		cb.vstg = 1;
390 		cb.Const.cds[0] = litp->cds[0];
391 		cb.Const.cds[1] = litp->cds[1];
392 		}
393 	else {
394 		memcpy((char *)&cb.Const, (char *)&litp->litval,
395 			sizeof(cb.Const));
396 		cb.vstg = 0;
397 		}
398 	out_const(outfile, &cb);
399 
400 	nice_printf (outfile, ";\n");
401     } /* for */
402     if (did_one)
403     	nice_printf (outfile, "\n");
404 } /* wr_globals */
405 
406  ftnint
407 #ifdef KR_headers
commlen(vl)408 commlen(vl)
409 	register chainp vl;
410 #else
411 commlen(register chainp vl)
412 #endif
413 {
414 	ftnint size;
415 	int type;
416 	struct Dimblock *t;
417 	Namep v;
418 
419 	while(vl->nextp)
420 		vl = vl->nextp;
421 	v = (Namep)vl->datap;
422 	type = v->vtype;
423 	if (type == TYCHAR)
424 		size = v->vleng->constblock.Const.ci;
425 	else
426 		size = typesize[type];
427 	if ((t = v->vdim) && ISCONST(t->nelt))
428 		size *= t->nelt->constblock.Const.ci;
429 	return size + v->voffset;
430 	}
431 
432  static void	/* Pad common block if an EQUIVALENCE extended it. */
433 #ifdef KR_headers
pad_common(c)434 pad_common(c)
435 	Extsym *c;
436 #else
437 pad_common(Extsym *c)
438 #endif
439 {
440 	register chainp cvl;
441 	register Namep v;
442 	long L = c->maxleng;
443 	int type;
444 	struct Dimblock *t;
445 	int szshort = typesize[TYSHORT];
446 
447 	for(cvl = c->allextp; cvl; cvl = cvl->nextp)
448 		if (commlen((chainp)cvl->datap) >= L)
449 			return;
450 	v = ALLOC(Nameblock);
451 	v->vtype = type = L % szshort ? TYCHAR
452 				      : type_choice[L/szshort % 4];
453 	v->vstg = STGCOMMON;
454 	v->vclass = CLVAR;
455 	v->tag = TNAME;
456 	v->vdim = t = ALLOC(Dimblock);
457 	t->ndim = 1;
458 	t->dims[0].dimsize = ICON(L / typesize[type]);
459 	v->fvarname = v->cvarname = "eqv_pad";
460 	if (type == TYCHAR)
461 		v->vleng = ICON(1);
462 	c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
463 	}
464 
465 
466 /* wr_common_decls -- outputs the common declarations in one of three
467    formats.  If all references to a common block look the same (field
468    names and types agree), only one actual declaration will appear.
469    Otherwise, the same block will require many structs.  If there is no
470    block data, these structs will be union'ed together (so the linker
471    knows the size of the largest one).  If there IS a block data, only
472    that version will be associated with the variable, others will only be
473    defined as types, so the pointer can be cast to it.  e.g.
474 
475 	FORTRAN				C
476 ----------------------------------------------------------------------
477 	common /com1/ a, b, c		struct { real a, b, c; } com1_;
478 
479 	common /com1/ a, b, c		union {
480 	common /com1/ i, j, k		    struct { real a, b, c; } _1;
481 					    struct { integer i, j, k; } _2;
482 					} com1_;
483 
484 	common /com1/ a, b, c		struct com1_1_ { real a, b, c; };
485 	block data			struct { integer i, j, k; } com1_ =
486 	common /com1/ i, j, k		  { 1, 2, 3 };
487 	data i/1/, j/2/, k/3/
488 
489 
490    All of these versions will be followed by #defines, since the code in
491    the function bodies can't know ahead of time which of these options
492    will be taken */
493 
494 /* Macros for deciding the output type */
495 
496 #define ONE_STRUCT 1
497 #define UNION_STRUCT 2
498 #define INIT_STRUCT 3
499 
500  void
501 #ifdef KR_headers
wr_common_decls(outfile)502 wr_common_decls(outfile)
503 	FILE *outfile;
504 #else
505 wr_common_decls(FILE *outfile)
506 #endif
507 {
508     Extsym *ext;
509     extern int extcomm;
510     static char *Extern[4] = {"", "Extern ", "extern "};
511     char *E, *E0 = Extern[extcomm];
512     int did_one = 0;
513 
514     for (ext = extsymtab; ext < nextext; ext++) {
515 	if (ext -> extstg == STGCOMMON && ext->allextp) {
516 	    chainp comm;
517 	    int count = 1;
518 	    int which;			/* which display to use;
519 					   ONE_STRUCT, UNION or INIT */
520 
521 	    if (!did_one)
522 		nice_printf (outfile, "/* Common Block Declarations */\n\n");
523 
524 	    pad_common(ext);
525 
526 /* Construct the proper, condensed list of structs; eliminate duplicates
527    from the initial list   ext -> allextp   */
528 
529 	    comm = ext->allextp = revchain(ext->allextp);
530 
531 	    if (ext -> extinit)
532 		which = INIT_STRUCT;
533 	    else if (comm->nextp) {
534 		which = UNION_STRUCT;
535 		nice_printf (outfile, "%sunion {\n", E0);
536 		next_tab (outfile);
537 		E = "";
538 		}
539 	    else {
540 		which = ONE_STRUCT;
541 		E = E0;
542 		}
543 
544 	    for (; comm; comm = comm -> nextp, count++) {
545 
546 		if (which == INIT_STRUCT)
547 		    nice_printf (outfile, "struct %s%d_ {\n",
548 			    ext->cextname, count);
549 		else
550 		    nice_printf (outfile, "%sstruct {\n", E);
551 
552 		next_tab (c_file);
553 
554 		wr_struct (outfile, (chainp) comm -> datap);
555 
556 		prev_tab (c_file);
557 		if (which == UNION_STRUCT)
558 		    nice_printf (outfile, "} _%d;\n", count);
559 		else if (which == ONE_STRUCT)
560 		    nice_printf (outfile, "} %s;\n", ext->cextname);
561 		else
562 		    nice_printf (outfile, "};\n");
563 	    } /* for */
564 
565 	    if (which == UNION_STRUCT) {
566 		prev_tab (c_file);
567 		nice_printf (outfile, "} %s;\n", ext->cextname);
568 	    } /* if */
569 	    did_one = 1;
570 	    nice_printf (outfile, "\n");
571 
572 	    for (count = 1, comm = ext -> allextp; comm;
573 		    comm = comm -> nextp, count++) {
574 		def_start(outfile, ext->cextname,
575 			comm_union_name(count), "");
576 		switch (which) {
577 		    case ONE_STRUCT:
578 		        extern_out (outfile, ext);
579 		        break;
580 		    case UNION_STRUCT:
581 		        nice_printf (outfile, "(");
582 			extern_out (outfile, ext);
583 			nice_printf(outfile, "._%d)", count);
584 		        break;
585 		    case INIT_STRUCT:
586 			nice_printf (outfile, "(*(struct ");
587 			extern_out (outfile, ext);
588 			nice_printf (outfile, "%d_ *) &", count);
589 			extern_out (outfile, ext);
590 			nice_printf (outfile, ")");
591 		        break;
592 		} /* switch */
593 		nice_printf (outfile, "\n");
594 	    } /* for count = 1, comm = ext -> allextp */
595 	    nice_printf (outfile, "\n");
596 	} /* if ext -> extstg == STGCOMMON */
597     } /* for ext = extsymtab */
598 } /* wr_common_decls */
599 
600  void
601 #ifdef KR_headers
wr_struct(outfile,var_list)602 wr_struct(outfile, var_list)
603 	FILE *outfile;
604 	chainp var_list;
605 #else
606 wr_struct(FILE *outfile, chainp var_list)
607 #endif
608 {
609     int last_type = -1;
610     int did_one = 0;
611     chainp this_var;
612 
613     for (this_var = var_list; this_var; this_var = this_var -> nextp) {
614 	Namep var = (Namep) this_var -> datap;
615 	int type;
616 	char *comment = NULL;
617 
618 	if (var == (Namep) NULL)
619 	    err ("wr_struct:  null variable");
620 	else if (var -> tag != TNAME)
621 	    erri ("wr_struct:  bad tag on variable '%d'",
622 		    var -> tag);
623 
624 	type = var -> vtype;
625 
626 	if (last_type == type && did_one)
627 	    nice_printf (outfile, ", ");
628 	else {
629 	    if (did_one)
630 		nice_printf (outfile, ";\n");
631 	    nice_printf (outfile, "%s ",
632 		    c_type_decl (type, var -> vclass == CLPROC));
633 	} /* else */
634 
635 /* Character type is really a string type.  Put out a '*' for parameters
636    with unknown length and functions returning character */
637 
638 	if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
639 		|| var -> vclass == CLPROC))
640 	    nice_printf (outfile, "*");
641 
642 	var -> vstg = STGAUTO;
643 	out_name (outfile, var);
644 	if (var -> vclass == CLPROC)
645 	    nice_printf (outfile, "()");
646 	else if (var -> vdim)
647 	    comment = wr_ardecls(outfile, var->vdim,
648 				var->vtype == TYCHAR && ISICON(var->vleng)
649 				? var->vleng->constblock.Const.ci : 1L);
650 	else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
651 	    ISICON ((var -> vleng)))
652 	    nice_printf (outfile, "[%ld]",
653 		    var -> vleng -> constblock.Const.ci);
654 
655 	if (comment)
656 	    nice_printf (outfile, "%s", comment);
657 	did_one = 1;
658 	last_type = type;
659     } /* for this_var */
660 
661     if (did_one)
662 	nice_printf (outfile, ";\n");
663 } /* wr_struct */
664 
665 
666  char *
667 #ifdef KR_headers
user_label(stateno)668 user_label(stateno)
669 	ftnint stateno;
670 #else
671 user_label(ftnint stateno)
672 #endif
673 {
674 	static char buf[USER_LABEL_MAX + 1];
675 	static char *Lfmt[2] = { "L_%ld", "L%ld" };
676 
677 	if (stateno >= 0)
678 		sprintf(buf, Lfmt[shiftcase], stateno);
679 	else
680 		sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname);
681 	return buf;
682 } /* user_label */
683 
684 
685  char *
686 #ifdef KR_headers
temp_name(starter,num,storage)687 temp_name(starter, num, storage)
688 	char *starter;
689 	int num;
690 	char *storage;
691 #else
692 temp_name(char *starter, int num, char *storage)
693 #endif
694 {
695     static char buf[IDENT_LEN];
696     char *pointer = buf;
697     char *prefix = "t";
698 
699     if (storage)
700 	pointer = storage;
701 
702     if (starter && *starter)
703 	prefix = starter;
704 
705     sprintf (pointer, "%s__%d", prefix, num);
706     return pointer;
707 } /* temp_name */
708 
709 
710  char *
711 #ifdef KR_headers
equiv_name(memno,store)712 equiv_name(memno, store)
713 	int memno;
714 	char *store;
715 #else
716 equiv_name(int memno, char *store)
717 #endif
718 {
719     static char buf[IDENT_LEN];
720     char *pointer = buf;
721 
722     if (store)
723 	pointer = store;
724 
725     sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno);
726     return pointer;
727 } /* equiv_name */
728 
729  void
730 #ifdef KR_headers
def_commons(of)731 def_commons(of)
732 	FILE *of;
733 #else
734 def_commons(FILE *of)
735 #endif
736 {
737 	Extsym *ext;
738 	int c, onefile, Union;
739 	chainp comm;
740 	extern int ext1comm;
741 	FILE *c_filesave = c_file;
742 
743 	if (ext1comm == 1) {
744 		onefile = 1;
745 		c_file = of;
746 		fprintf(of, "/*>>>'/dev/null'<<<*/\n\
747 #ifdef Define_COMMONs\n\
748 /*<<</dev/null>>>*/\n");
749 		}
750 	else
751 		onefile = 0;
752 	for(ext = extsymtab; ext < nextext; ext++)
753 		if (ext->extstg == STGCOMMON
754 		&& !ext->extinit && (comm = ext->allextp)) {
755 			sprintf(outbtail, "%scom.c", ext->cextname);
756 			if (onefile)
757 				fprintf(of, "/*>>>'%s'<<<*/\n",
758 					outbtail);
759 			else {
760 				c_file = of = fopen(outbuf,textwrite);
761 				if (!of)
762 					fatalstr("can't open %s", outbuf);
763 				}
764 			fprintf(of, "#include \"f2c.h\"\n");
765 			if (Ansi == 2)
766 				fprintf(of,
767 			 "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n");
768 			if (comm->nextp) {
769 				Union = 1;
770 				nice_printf(of, "union {\n");
771 				next_tab(of);
772 				}
773 			else
774 				Union = 0;
775 			for(c = 1; comm; comm = comm->nextp) {
776 				nice_printf(of, "struct {\n");
777 				next_tab(of);
778 				wr_struct(of, (chainp)comm->datap);
779 				prev_tab(of);
780 				if (Union)
781 					nice_printf(of, "} _%d;\n", c++);
782 				}
783 			if (Union)
784 				prev_tab(of);
785 			nice_printf(of, "} %s;\n", ext->cextname);
786 			if (Ansi == 2)
787 				fprintf(of,
788 			 "\n#ifdef __cplusplus\n}\n#endif\n");
789 			if (onefile)
790 				fprintf(of, "/*<<<%s>>>*/\n", outbtail);
791 			else
792 				fclose(of);
793 			}
794 	if (onefile)
795 		fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\
796 /*<<</dev/null>>>*/\n");
797 	c_file = c_filesave;
798 	}
799 
800 /* C Language keywords.  Needed to filter unwanted fortran identifiers like
801  * "int", etc.  Source:  Kernighan & Ritchie, eds. 1 and 2; Stroustrup.
802  * Also includes C++ keywords and types used for I/O in f2c.h .
803  * These keywords must be in alphabetical order (as defined by strcmp()).
804  */
805 
806 char *c_keywords[] = {
807 	"Long", "Multitype", "Namelist", "Vardesc", "abs", "acos",
808 	"addr", "address", "aerr", "alist", "asin", "asm", "atan",
809 	"atan2", "aunit", "auto", "break", "c", "case", "catch", "cerr",
810 	"char", "ciend", "cierr", "cifmt", "cilist", "cirec", "ciunit",
811 	"class", "cllist", "complex", "const", "continue", "cos",
812 	"cosh", "csta", "cunit", "d", "dabs", "default", "defined",
813 	"delete", "dims", "dmax", "dmin", "do", "double",
814 	"doublecomplex", "doublereal", "else", "entry", "enum", "exp",
815 	"extern", "far", "flag", "float", "for", "friend", "ftnint",
816 	"ftnlen", "goto", "h", "huge", "i", "iciend", "icierr",
817 	"icifmt", "icilist", "icirlen", "icirnum", "iciunit", "if",
818 	"inacc", "inacclen", "inblank", "inblanklen", "include",
819 	"indir", "indirlen", "inerr", "inex", "infile", "infilen",
820 	"infmt", "infmtlen", "inform", "informlen", "inline", "inlist",
821 	"inname", "innamed", "innamlen", "innrec", "innum", "inopen",
822 	"inrecl", "inseq", "inseqlen", "int", "integer", "integer1",
823 	"inunf", "inunflen", "inunit", "log", "logical", "logical1",
824 	"long", "longint", "max", "min", "name", "near", "new", "nvars",
825 	"oacc", "oblnk", "oerr", "ofm", "ofnm", "ofnmlen", "olist",
826 	"operator", "orl", "osta", "ounit", "overload", "private",
827 	"protected", "public", "r", "real", "register", "return",
828 	"short", "shortint", "shortlogical", "signed", "sin", "sinh",
829 	"sizeof", "sqrt", "static", "struct", "switch", "tan", "tanh",
830 	"template", "this", "try", "type", "typedef", "uinteger",
831 	"ulongint", "union", "unsigned", "vars", "virtual", "void",
832 	"volatile", "while", "z"
833 	}; /* c_keywords */
834 
835 int n_keywords = sizeof(c_keywords)/sizeof(char *);
836