1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
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.
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
22 ****************************************************************/
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:
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
41 ret_val_len length of the return value in character functions
43 ssss_len length of character argument "ssss"
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
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
57 /* generate variable references */
59 char *c_type_decl (type, is_extern)
62 static char buff[100];
65 case TYADDR: strcpy (buff, "address"); break;
66 case TYSHORT: strcpy (buff, "shortint"); break;
67 case TYLONG: strcpy (buff, "integer"); break;
68 case TYREAL: if (!is_extern || !forcedouble)
69 { strcpy (buff, "real");break; }
70 case TYDREAL: strcpy (buff, "doublereal"); break;
71 case TYCOMPLEX: if (is_extern)
72 strcpy (buff, Ansi ? "/* Complex */ VOID"
73 : "/* Complex */ int");
75 strcpy (buff, "complex");
77 case TYDCOMPLEX:if (is_extern)
78 strcpy (buff, Ansi ? "/* Double Complex */ VOID"
79 : "/* Double Complex */ int");
81 strcpy (buff, "doublecomplex");
83 case TYLOGICAL: strcpy(buff, typename[TYLOGICAL]);
85 case TYCHAR: if (is_extern)
86 strcpy (buff, Ansi ? "/* Character */ VOID"
87 : "/* Character */ int");
89 strcpy (buff, "char");
92 case TYUNKNOWN: strcpy (buff, "UNKNOWN");
94 /* If a procedure's type is unknown, assume it's a subroutine */
99 /* Subroutines must return an INT, because they might return a label
100 value. Even if one doesn't, the caller will EXPECT it to. */
102 case TYSUBR: strcpy (buff, "/* Subroutine */ int");
104 case TYERROR: strcpy (buff, "ERROR"); break;
105 case TYVOID: strcpy (buff, "void"); break;
106 case TYCILIST: strcpy (buff, "cilist"); break;
107 case TYICILIST: strcpy (buff, "icilist"); break;
108 case TYOLIST: strcpy (buff, "olist"); break;
109 case TYCLLIST: strcpy (buff, "cllist"); break;
110 case TYALIST: strcpy (buff, "alist"); break;
111 case TYINLIST: strcpy (buff, "inlist"); break;
112 case TYFTNLEN: strcpy (buff, "ftnlen"); break;
113 default: sprintf (buff, "BAD DECL '%d'", type);
121 char *new_func_length()
122 { return "ret_val_len"; }
124 char *new_arg_length(arg)
128 sprintf (buf, "%s_len", arg->fvarname);
131 } /* new_arg_length */
134 /* declare_new_addr -- Add a new local variable to the function, given a
135 pointer to an Addrblock structure (which must have the uname_tag set)
136 This list of idents will be printed in reverse (i.e., chronological)
140 declare_new_addr (addrp)
141 struct Addrblock *addrp;
143 extern chainp new_vars;
145 new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
146 } /* declare_new_addr */
149 wr_nv_ident_help (outfile, addrp)
151 struct Addrblock *addrp;
155 if (addrp == (struct Addrblock *) NULL)
158 if (addrp -> isarray) {
159 frexpr (addrp -> memoffset);
160 addrp -> memoffset = ICON(0);
161 eltcount = addrp -> ntempelt;
162 addrp -> ntempelt = 0;
163 addrp -> isarray = 0;
165 out_addr (outfile, addrp);
167 nice_printf (outfile, "[%d]", eltcount);
168 } /* wr_nv_ident_help */
170 int nv_type_help (addrp)
171 struct Addrblock *addrp;
173 if (addrp == (struct Addrblock *) NULL)
176 return addrp -> vtype;
180 /* lit_name -- returns a unique identifier for the given literal. Make
181 the label useful, when possible. For example:
183 1 -> c_1 (constant 1)
184 2 -> c_2 (constant 2)
185 1000 -> c_1000 (constant 1000)
186 1000000 -> c_b<memno> (big constant number)
187 1.2 -> c_1_2 (constant 1.2)
188 1.234345 -> c_b<memno> (big constant number)
189 -1 -> c_n1 (constant -1)
190 -1.0 -> c_n1_0 (constant -1.0)
191 .true. -> c_true (constant true)
192 .false. -> c_false (constant false)
193 default -> c_b<memno> (default label)
196 char *lit_name (litp)
197 struct Literal *litp;
199 static char buf[CONST_IDENT_MAX];
201 if (litp == (struct Literal *) NULL)
204 switch (litp -> littype) {
206 if (litp -> litval.litival < 32768 &&
207 litp -> litval.litival > -32769) {
208 ftnint val = litp -> litval.litival;
211 sprintf (buf, "cs_n%ld", -val);
213 sprintf (buf, "cs__%ld", val);
215 sprintf (buf, "c_b%d", litp -> litnum);
218 if (litp -> litval.litival < 100000 &&
219 litp -> litval.litival > -10000) {
220 ftnint val = litp -> litval.litival;
223 sprintf (buf, "c_n%ld", -val);
225 sprintf (buf, "c__%ld", val);
227 sprintf (buf, "c_b%d", litp -> litnum);
230 sprintf (buf, "c_%s", (litp -> litval.litival ? "true" : "false"));
234 /* Given a limit of 6 or 8 character on external names, */
235 /* few f.p. values can be meaningfully encoded in the */
236 /* constant name. Just going with the default cb_# */
237 /* seems to be the best course for floating-point */
240 /* Shouldn't be any of these */
246 sprintf (buf, "c_b%d", litp -> litnum);
255 comm_union_name(count)
260 sprintf(buf, "%d", count);
267 /* wr_globals -- after every function has been translated, we need to
268 output the global declarations, such as the static table of constant
274 struct Literal *litp, *lastlit;
275 extern struct Literal litpool[]; /* Table of constant values */
276 extern int nliterals; /* Number of constants in table */
277 extern char *lit_name ();
279 struct Constblock cb;
284 lastlit = litpool + nliterals;
286 for (litp = litpool; litp < lastlit; litp++) {
290 margin_printf(outfile, "/* Table of constant values */\n\n");
293 nice_printf (outfile, "static %s %s%s = ", c_type_decl (litp -> littype,
294 0), litp -> littype == TYCHAR ? "*" : "", lit_name (litp));
297 if (ONEOF(t, MSKREAL|MSKCOMPLEX)) {
299 cb.Const.cds[0] = litp->cds[0];
300 cb.Const.cds[1] = litp->cds[1];
303 memcpy((char *)&cb.Const, (char *)&litp->litval,
307 cb.vtype = litp->littype;
308 out_const (outfile, &cb);
310 nice_printf (outfile, ";\n");
313 nice_printf (outfile, "\n");
327 v = (Namep)vl->datap;
330 size = v->vleng->constblock.Const.ci;
332 size = typesize[type];
333 if ((t = v->vdim) && ISCONST(t->nelt))
334 size *= t->nelt->constblock.Const.ci;
335 return size + v->voffset;
338 static void /* Pad common block if an EQUIVALENCE extended it. */
347 int szshort = typesize[TYSHORT];
349 for(cvl = c->allextp; cvl; cvl = cvl->nextp)
350 if (commlen((chainp)cvl->datap) >= L)
352 v = ALLOC(Nameblock);
353 v->vtype = type = L % szshort ? TYCHAR
354 : type_choice[L/szshort % 4];
358 v->vdim = t = ALLOC(Dimblock);
360 t->dims[0].dimsize = ICON(L / typesize[type]);
361 v->fvarname = v->cvarname = "eqv_pad";
362 c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
366 /* wr_common_decls -- outputs the common declarations in one of three
367 formats. If all references to a common block look the same (field
368 names and types agree), only one actual declaration will appear.
369 Otherwise, the same block will require many structs. If there is no
370 block data, these structs will be union'ed together (so the linker
371 knows the size of the largest one). If there IS a block data, only
372 that version will be associated with the variable, others will only be
373 defined as types, so the pointer can be cast to it. e.g.
376 ----------------------------------------------------------------------
377 common /com1/ a, b, c struct { real a, b, c; } com1_;
379 common /com1/ a, b, c union {
380 common /com1/ i, j, k struct { real a, b, c; } _1;
381 struct { integer i, j, k; } _2;
384 common /com1/ a, b, c struct com1_1_ { real a, b, c; };
385 block data struct { integer i, j, k; } com1_ =
386 common /com1/ i, j, k { 1, 2, 3 };
387 data i/1/, j/2/, k/3/
390 All of these versions will be followed by #defines, since the code in
391 the function bodies can't know ahead of time which of these options
394 /* Macros for deciding the output type */
397 #define UNION_STRUCT 2
398 #define INIT_STRUCT 3
400 wr_common_decls(outfile)
405 static char *Extern[4] = {"", "Extern ", "extern "};
406 char *E, *E0 = Extern[extcomm];
409 for (ext = extsymtab; ext < nextext; ext++) {
410 if (ext -> extstg == STGCOMMON && ext->allextp) {
413 int which; /* which display to use;
414 ONE_STRUCT, UNION or INIT */
417 nice_printf (outfile, "/* Common Block Declarations */\n\n");
421 /* Construct the proper, condensed list of structs; eliminate duplicates
422 from the initial list ext -> allextp */
424 comm = ext->allextp = revchain(ext->allextp);
428 else if (comm->nextp) {
429 which = UNION_STRUCT;
430 nice_printf (outfile, "%sunion {\n", E0);
439 for (; comm; comm = comm -> nextp, count++) {
441 if (which == INIT_STRUCT)
442 nice_printf (outfile, "struct %s%d_ {\n",
443 ext->cextname, count);
445 nice_printf (outfile, "%sstruct {\n", E);
449 wr_struct (outfile, (chainp) comm -> datap);
452 if (which == UNION_STRUCT)
453 nice_printf (outfile, "} _%d;\n", count);
454 else if (which == ONE_STRUCT)
455 nice_printf (outfile, "} %s;\n", ext->cextname);
457 nice_printf (outfile, "};\n");
460 if (which == UNION_STRUCT) {
462 nice_printf (outfile, "} %s;\n", ext->cextname);
465 nice_printf (outfile, "\n");
467 for (count = 1, comm = ext -> allextp; comm;
468 comm = comm -> nextp, count++) {
469 def_start(outfile, ext->cextname,
470 comm_union_name(count), "");
473 extern_out (outfile, ext);
476 nice_printf (outfile, "(");
477 extern_out (outfile, ext);
478 nice_printf(outfile, "._%d)", count);
481 nice_printf (outfile, "(*(struct ");
482 extern_out (outfile, ext);
483 nice_printf (outfile, "%d_ *) &", count);
484 extern_out (outfile, ext);
485 nice_printf (outfile, ")");
488 nice_printf (outfile, "\n");
489 } /* for count = 1, comm = ext -> allextp */
490 nice_printf (outfile, "\n");
491 } /* if ext -> extstg == STGCOMMON */
492 } /* for ext = extsymtab */
493 } /* wr_common_decls */
496 wr_struct (outfile, var_list)
504 for (this_var = var_list; this_var; this_var = this_var -> nextp) {
505 Namep var = (Namep) this_var -> datap;
507 char *comment = NULL, *wr_ardecls ();
509 if (var == (Namep) NULL)
510 err ("wr_struct: null variable");
511 else if (var -> tag != TNAME)
512 erri ("wr_struct: bad tag on variable '%d'",
517 if (last_type == type && did_one)
518 nice_printf (outfile, ", ");
521 nice_printf (outfile, ";\n");
522 nice_printf (outfile, "%s ",
523 c_type_decl (type, var -> vclass == CLPROC));
526 /* Character type is really a string type. Put out a '*' for parameters
527 with unknown length and functions returning character */
529 if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
530 || var -> vclass == CLPROC))
531 nice_printf (outfile, "*");
533 var -> vstg = STGAUTO;
534 out_name (outfile, var);
535 if (var -> vclass == CLPROC)
536 nice_printf (outfile, "()");
537 else if (var -> vdim)
538 comment = wr_ardecls(outfile, var->vdim,
539 var->vtype == TYCHAR && ISICON(var->vleng)
540 ? var->vleng->constblock.Const.ci : 1L);
541 else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
542 ISICON ((var -> vleng)))
543 nice_printf (outfile, "[%ld]",
544 var -> vleng -> constblock.Const.ci);
547 nice_printf (outfile, "%s", comment);
553 nice_printf (outfile, ";\n");
557 char *user_label(stateno)
560 static char buf[USER_LABEL_MAX + 1];
563 sprintf(buf, "L%ld", stateno);
565 sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname);
570 char *temp_name (starter, num, storage)
575 static char buf[IDENT_LEN];
582 if (starter && *starter)
585 sprintf (pointer, "%s_%d", prefix, num);
590 char *equiv_name (memno, store)
594 static char buf[IDENT_LEN];
600 sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno);
609 int c, onefile, Union;
617 fprintf(of, "/*>>>'/dev/null'<<<*/\n\
618 #ifdef Define_COMMONs\n\
619 /*<<</dev/null>>>*/\n");
623 for(ext = extsymtab; ext < nextext; ext++)
624 if (ext->extstg == STGCOMMON && !ext->extinit) {
625 sprintf(buf, "%scom.c", ext->cextname);
627 fprintf(of, "/*>>>'%s'<<<*/\n",
630 c_file = of = fopen(buf,textwrite);
632 fatalstr("can't open %s", buf);
634 fprintf(of, "#include \"f2c.h\"\n");
638 nice_printf(of, "union {\n");
643 for(c = 1; comm; comm = comm->nextp) {
644 nice_printf(of, "struct {\n");
646 wr_struct(of, (chainp)comm->datap);
649 nice_printf(of, "} _%d;\n", c++);
653 nice_printf(of, "} %s;\n", ext->cextname);
655 fprintf(of, "/*<<<%s>>>*/\n", buf);
660 fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\
661 /*<<</dev/null>>>*/\n");
664 /* C Language keywords. Needed to filter unwanted fortran identifiers like
665 * "int", etc. Source: Kernighan & Ritchie, eds. 1 and 2; Stroustrup.
666 * Also includes C++ keywords and types used for I/O in f2c.h .
667 * These keywords must be in alphabetical order (as defined by strcmp()).
670 char *c_keywords[] = {
671 "abs", "acos", "alist", "asin", "asm", "atan", "atan2", "auto",
672 "break", "case", "catch", "char", "cilist", "class", "cllist",
673 "const", "continue", "cos", "cosh",
674 "dabs", "default", "defined", "delete",
675 "dmax", "dmin", "do", "double",
676 "else", "entry", "enum", "exp", "extern",
677 "flag", "float", "for", "friend", "ftnint", "ftnlen", "goto",
678 "icilist", "if", "include", "inline", "inlist", "int",
679 "log", "long", "max", "min", "new",
680 "olist", "operator", "overload", "private", "protected", "public",
681 "register", "return",
682 "short", "signed", "sin", "sinh", "sizeof", "sqrt",
683 "static", "struct", "switch",
684 "tan", "tanh", "template", "this", "try", "typedef",
685 "union", "unsigned", "virtual", "void", "volatile", "while"
688 int n_keywords = sizeof(c_keywords)/sizeof(char *);