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 ****************************************************************/
24 /* Format.c -- this file takes an intermediate file (generated by pass 1
25 of the translator) and some state information about the contents of that
26 file, and generates C program text. */
35 int c_output_line_length = DEF_C_LINE_LENGTH;
37 int last_was_label; /* Boolean used to generate semicolons
38 when a label terminates a block */
39 static char this_proc_name[52]; /* Name of the current procedure. This is
40 probably too simplistic to handle
41 multiple entry points */
43 static int p1getd(), p1gets(), p1getf(), get_p1_token();
44 static int p1get_const(), p1getn();
45 static expptr do_format(), do_p1_name_pointer(), do_p1_const();
46 static expptr do_p1_expr(), do_p1_ident(), do_p1_charp(), do_p1_extern();
47 static expptr do_p1_head(), do_p1_list(), do_p1_literal();
48 static void do_p1_label(), do_p1_asgoto(), do_p1_goto();
49 static void do_p1_if(), do_p1_else(), do_p1_elif(), do_p1_endif();
50 static void do_p1_endelse(), do_p1_subr_ret(), do_p1_comp_goto();
51 static void do_p1_for(), do_p1_end_for(), do_p1_fortran();
52 static void do_p1_1while(), do_p1_2while();
53 static void do_p1_comment(), do_p1_set_line();
54 static expptr do_p1_addr(), expand_structure_refs();
56 void list_arg_types();
59 extern chainp assigned_fmts;
60 static long old_lineno;
61 static char filename[P1_FILENAME_MAX];
65 #define is_end_token(x) ((x) == P1_ENDIF || (x) == P1_ENDELSE || (x) == P1_ENDFOR)
70 static int wrote_one = 0;
71 extern int usedefsforcommon;
72 extern char *p1_file, *p1_bakfile;
74 this_proc_name[0] = '\0';
79 (void) fclose (pass1_file);
80 if ((infile = fopen (p1_file, binread)) == NULL)
81 Fatal("start_formatting: couldn't open the intermediate file\n");
84 nice_printf (c_file, "\n");
86 while (!feof (infile)) {
89 this_expr = do_format (infile, c_file);
91 out_and_free_statement (c_file, this_expr);
93 } /* while !feof infile */
95 (void) fclose (infile);
98 nice_printf (c_file, ";\n");
101 if (this_proc_name[0])
102 nice_printf (c_file, "} /* %s */\n", this_proc_name);
105 /* Write the #undefs for common variable reference */
107 if (usedefsforcommon) {
111 for (ext = extsymtab; ext < nextext; ext++)
112 if (ext -> extstg == STGCOMMON && ext -> used_here) {
113 ext -> used_here = 0;
115 nice_printf (c_file, "\n");
116 wr_abbrevs(c_file, 0, ext->extp);
118 ext -> extp = CHNULL;
122 nice_printf (c_file, "\n");
123 } /* if usedefsforcommon */
125 other_undefs(c_file);
129 /* For debugging only */
131 if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
132 if (infile = fopen (p1_file, binread)) {
133 ffilecopy (infile, pass1_file);
138 /* End of "debugging only" */
140 if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
141 err ("start_formatting: couldn't reopen the pass1 file");
143 } /* start_formatting */
146 static expptr expand_structure_refs (e)
151 else if (e -> tag == TADDR)
152 if (e -> addrblock.Field == NULL)
156 Constp p = mkconst(TYCHAR);
158 p -> vleng = ICON (strlen (e -> addrblock.Field));
159 p -> Const.ccp = e -> addrblock.Field;
160 p -> Const.ccp1.blanks = 0;
161 e -> addrblock.Field = NULL;
162 return mkexpr(OPDOT, e, (expptr)p);
164 else if (e -> tag != TEXPR)
167 e -> exprblock.leftp = expand_structure_refs (e -> exprblock.leftp);
168 e -> exprblock.rightp = expand_structure_refs (e -> exprblock.rightp);
171 } /* expand_structure_refs */
174 /* do_format -- takes an input stream (a file in pass1 format) and writes
175 the appropriate C code to outfile when possible. When reading an
176 expression, the expression tree is returned instead. */
178 static expptr do_format (infile, outfile)
179 FILE *infile, *outfile;
181 int gsave, token_type, was_c_token;
182 expptr retval = ENULL;
184 token_type = get_p1_token (infile);
185 if (is_end_token (token_type) && last_was_label) {
186 nice_printf (outfile, ";");
191 switch (token_type) {
193 do_p1_comment (infile, outfile);
197 do_p1_set_line (infile);
201 p1gets(infile, filename, P1_FILENAME_MAX);
204 case P1_NAME_POINTER:
205 retval = do_p1_name_pointer (infile);
208 retval = do_p1_const (infile);
211 retval = do_p1_expr (infile, outfile);
214 retval = do_p1_ident(infile);
217 retval = do_p1_charp(infile);
220 retval = do_p1_extern (infile);
225 retval = do_p1_head (infile, outfile);
229 retval = do_p1_list (infile, outfile);
232 retval = do_p1_literal (infile);
235 do_p1_label (infile, outfile);
236 /* last_was_label = 1; -- now set in do_p1_label */
240 do_p1_asgoto (infile, outfile);
243 do_p1_goto (infile, outfile);
246 do_p1_if (infile, outfile);
249 do_p1_else (outfile);
252 do_p1_elif (infile, outfile);
255 do_p1_endif (outfile);
258 do_p1_endelse (outfile);
261 retval = do_p1_addr (infile, outfile);
264 do_p1_subr_ret (infile, outfile);
267 do_p1_comp_goto (infile, outfile);
270 do_p1_for (infile, outfile);
273 do_p1_end_for (outfile);
276 do_p1_1while(outfile);
279 do_p1_2while(infile, outfile);
285 do_p1_fortran(infile, outfile);
291 Fatal("do_format: Unknown token type in intermediate file");
294 Fatal("do_format: Bad token type in intermediate file");
305 do_p1_comment (infile, outfile)
306 FILE *infile, *outfile;
308 extern int c_output_line_length, in_comment;
310 char storage[COMMENT_BUFFER_SIZE + 1];
313 if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
316 length = strlen (storage);
319 if (length > c_output_line_length - 6)
320 margin_printf (outfile, "/*%s*/\n", storage);
322 margin_printf (outfile, length ? "/* %s */\n" : "\n", storage);
324 } /* do_p1_comment */
327 do_p1_set_line (infile)
331 long new_line_number = -1;
333 status = p1getd (infile, &new_line_number);
336 err ("do_p1_set_line: Missing line number at end of file\n");
337 else if (status == 0 || new_line_number == -1)
338 errl("do_p1_set_line: Illegal line number in intermediate file: %ld\n",
341 lineno = new_line_number;
343 fprintf(c_file, "/*# %ld \"%s\"*/\n", lineno, filename);
345 } /* do_p1_set_line */
348 static expptr do_p1_name_pointer (infile)
351 Namep namep = (Namep) NULL;
354 status = p1getd (infile, (long *) &namep);
357 err ("do_p1_name_pointer: Missing pointer at end of file\n");
358 else if (status == 0 || namep == (Namep) NULL)
359 erri ("do_p1_name_pointer: Illegal name pointer in p1 file: '%x'\n",
362 return (expptr) namep;
363 } /* do_p1_name_pointer */
367 static expptr do_p1_const (infile)
370 struct Constblock *c = (struct Constblock *) NULL;
374 status = p1getd (infile, &type);
377 err ("do_p1_const: Missing constant type at end of file\n");
378 else if (status == 0)
379 errl("do_p1_const: Illegal constant type in p1 file: %ld\n", type);
381 status = p1get_const (infile, (int)type, &c);
384 err ("do_p1_const: Missing constant value at end of file\n");
385 c = (struct Constblock *) NULL;
386 } else if (status == 0) {
387 err ("do_p1_const: Illegal constant value in p1 file\n");
388 c = (struct Constblock *) NULL;
395 static expptr do_p1_literal (infile)
402 status = p1getd (infile, &memno);
405 err ("do_p1_literal: Missing memno at end of file");
406 else if (status == 0)
407 err ("do_p1_literal: Missing memno in p1 file");
409 struct Literal *litp, *lastlit;
410 extern struct Literal litpool[];
411 extern int nliterals;
413 addrp = ALLOC (Addrblock);
414 addrp -> tag = TADDR;
415 addrp -> vtype = TYUNKNOWN;
416 addrp -> Field = NULL;
418 lastlit = litpool + nliterals;
419 for (litp = litpool; litp < lastlit; litp++)
420 if (litp -> litnum == memno) {
421 addrp -> vtype = litp -> littype;
422 *((union Constant *) &(addrp -> user)) =
423 *((union Constant *) &(litp -> litval));
425 } /* if litp -> litnum == memno */
427 addrp -> memno = memno;
428 addrp -> vstg = STGMEMNO;
429 addrp -> uname_tag = UNAM_CONST;
432 return (expptr) addrp;
433 } /* do_p1_literal */
436 static void do_p1_label (infile, outfile)
437 FILE *infile, *outfile;
442 struct Labelblock *L;
445 status = p1getd (infile, &stateno);
448 err ("do_p1_label: Missing label at end of file");
449 else if (status == 0)
450 err ("do_p1_label: Missing label in p1 file ");
451 else if (stateno < 0) { /* entry */
452 margin_printf(outfile, "\n%s:\n", user_label(stateno));
456 L = labeltab + stateno;
463 margin_printf(outfile, fmt, user_label(L->stateno));
469 static void do_p1_asgoto (infile, outfile)
470 FILE *infile, *outfile;
474 expr = do_format (infile, outfile);
475 out_asgoto (outfile, expr);
480 static void do_p1_goto (infile, outfile)
481 FILE *infile, *outfile;
487 status = p1getd (infile, &stateno);
490 err ("do_p1_goto: Missing goto label at end of file");
491 else if (status == 0)
492 err ("do_p1_goto: Missing goto label in p1 file");
494 nice_printf (outfile, "goto %s;\n", user_label (stateno));
499 static void do_p1_if (infile, outfile)
500 FILE *infile, *outfile;
505 cond = do_format (infile, outfile);
506 } while (cond == ENULL);
508 out_if (outfile, cond);
512 static void do_p1_else (outfile)
519 static void do_p1_elif (infile, outfile)
520 FILE *infile, *outfile;
525 cond = do_format (infile, outfile);
526 } while (cond == ENULL);
528 elif_out (outfile, cond);
531 static void do_p1_endif (outfile)
538 static void do_p1_endelse (outfile)
541 end_else_out (outfile);
542 } /* do_p1_endelse */
545 static expptr do_p1_addr (infile, outfile)
546 FILE *infile, *outfile;
548 Addrp addrp = (Addrp) NULL;
551 status = p1getn (infile, sizeof (struct Addrblock), (char **) &addrp);
554 err ("do_p1_addr: Missing Addrp at end of file");
555 else if (status == 0)
556 err ("do_p1_addr: Missing Addrp in p1 file");
557 else if (addrp == (Addrp) NULL)
558 err ("do_p1_addr: Null addrp in p1 file");
559 else if (addrp -> tag != TADDR)
560 erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
562 addrp -> vleng = do_format (infile, outfile);
563 addrp -> memoffset = do_format (infile, outfile);
566 return (expptr) addrp;
571 static void do_p1_subr_ret (infile, outfile)
572 FILE *infile, *outfile;
576 nice_printf (outfile, "return ");
577 retval = do_format (infile, outfile);
580 expr_out (outfile, retval);
582 nice_printf (outfile, ";\n");
583 } /* do_p1_subr_ret */
587 static void do_p1_comp_goto (infile, outfile)
588 FILE *infile, *outfile;
593 index = do_format (infile, outfile);
595 if (index == ENULL) {
596 err ("do_p1_comp_goto: no expression for computed goto");
598 } /* if index == ENULL */
600 labels = do_format (infile, outfile);
602 if (labels && labels -> tag != TLIST)
603 erri ("do_p1_comp_goto: expected list, got tag '%d'", labels -> tag);
605 compgoto_out (outfile, index, labels);
606 } /* do_p1_comp_goto */
609 static void do_p1_for (infile, outfile)
610 FILE *infile, *outfile;
612 expptr init, test, inc;
614 init = do_format (infile, outfile);
615 test = do_format (infile, outfile);
616 inc = do_format (infile, outfile);
618 out_for (outfile, init, test, inc);
621 static void do_p1_end_for (outfile)
624 out_end_for (outfile);
625 } /* do_p1_end_for */
629 do_p1_fortran(infile, outfile)
630 FILE *infile, *outfile;
632 char buf[P1_STMTBUFSIZE];
633 if (!p1gets(infile, buf, P1_STMTBUFSIZE))
635 /* bypass nice_printf nonsense */
636 fprintf(outfile, "/*< %s >*/\n", buf+1); /* + 1 to skip by '$' */
640 static expptr do_p1_expr (infile, outfile)
641 FILE *infile, *outfile;
645 struct Exprblock *result = (struct Exprblock *) NULL;
647 status = p1getd (infile, &opcode);
650 err ("do_p1_expr: Missing expr opcode at end of file");
651 else if (status == 0)
652 err ("do_p1_expr: Missing expr opcode in p1 file");
655 status = p1getd (infile, &type);
658 err ("do_p1_expr: Missing expr type at end of file");
659 else if (status == 0)
660 err ("do_p1_expr: Missing expr type in p1 file");
661 else if (opcode == 0)
664 result = ALLOC (Exprblock);
666 result -> tag = TEXPR;
667 result -> vtype = type;
668 result -> opcode = opcode;
669 result -> vleng = do_format (infile, outfile);
671 if (is_unary_op (opcode))
672 result -> leftp = do_format (infile, outfile);
673 else if (is_binary_op (opcode)) {
674 result -> leftp = do_format (infile, outfile);
675 result -> rightp = do_format (infile, outfile);
677 errl("do_p1_expr: Illegal opcode %ld", opcode);
681 return (expptr) result;
685 static expptr do_p1_ident(infile)
692 addrp = ALLOC (Addrblock);
693 addrp -> tag = TADDR;
695 status = p1getd (infile, &vtype);
697 err ("do_p1_ident: Missing identifier type at end of file\n");
698 else if (status == 0 || vtype < 0 || vtype >= NTYPES)
699 errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype);
701 addrp -> vtype = vtype;
703 status = p1getd (infile, &vstg);
705 err ("do_p1_ident: Missing identifier storage at end of file\n");
706 else if (status == 0 || vstg < 0 || vstg > STGNULL)
707 errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype);
709 addrp -> vstg = vstg;
711 status = p1gets(infile, addrp->user.ident, IDENT_LEN);
714 err ("do_p1_ident: Missing ident string at end of file");
715 else if (status == 0)
716 err ("do_p1_ident: Missing ident string in intermediate file");
717 addrp->uname_tag = UNAM_IDENT;
718 return (expptr) addrp;
721 static expptr do_p1_charp(infile)
729 addrp = ALLOC (Addrblock);
730 addrp -> tag = TADDR;
732 status = p1getd (infile, &vtype);
734 err ("do_p1_ident: Missing identifier type at end of file\n");
735 else if (status == 0 || vtype < 0 || vtype >= NTYPES)
736 errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype);
738 addrp -> vtype = vtype;
740 status = p1getd (infile, &vstg);
742 err ("do_p1_ident: Missing identifier storage at end of file\n");
743 else if (status == 0 || vstg < 0 || vstg > STGNULL)
744 errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype);
746 addrp -> vstg = vstg;
748 status = p1gets(infile, buf, sizeof(buf));
751 err ("do_p1_ident: Missing charp ident string at end of file");
752 else if (status == 0)
753 err ("do_p1_ident: Missing charp ident string in intermediate file");
754 addrp->uname_tag = UNAM_CHARP;
755 addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
756 return (expptr) addrp;
760 static expptr do_p1_extern (infile)
765 addrp = ALLOC (Addrblock);
770 addrp->vstg = STGEXT;
771 addrp->uname_tag = UNAM_EXTERN;
772 status = p1getd (infile, &(addrp -> memno));
774 err ("do_p1_extern: Missing memno at end of file");
775 else if (status == 0)
776 err ("do_p1_extern: Missing memno in intermediate file");
777 if (addrp->vtype = extsymtab[addrp->memno].extype)
778 addrp->vclass = CLPROC;
781 return (expptr) addrp;
786 static expptr do_p1_head (infile, outfile)
787 FILE *infile, *outfile;
794 status = p1getd (infile, &class);
796 err ("do_p1_head: missing header class at end of file");
797 else if (status == 0)
798 err ("do_p1_head: missing header class in p1 file");
800 status = p1gets (infile, storage, sizeof(storage));
801 if (status == EOF || status == 0)
805 if (class == CLPROC || class == CLMAIN) {
809 lengths = length_comp(entries, add_n_);
811 if (!add_n_ && protofile && class != CLMAIN)
812 protowrite(protofile, proctype, storage, entries, lengths);
815 nice_printf (outfile, "/* Main program */ ");
817 nice_printf(outfile, "%s ", multitype ? "VOID"
818 : c_type_decl(proctype, 1));
820 nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
822 listargs(outfile, entries, add_n_, lengths);
823 nice_printf (outfile, "\n");
825 list_arg_types (outfile, entries, lengths, add_n_, "\n");
826 nice_printf (outfile, "{\n");
829 strcpy(this_proc_name, storage);
830 list_decls (outfile);
832 } else if (class == CLBLOCK)
835 errl("do_p1_head: got class %ld", class);
841 static expptr do_p1_list (infile, outfile)
842 FILE *infile, *outfile;
844 long tag, type, count;
848 status = p1getd (infile, &tag);
850 err ("do_p1_list: missing list tag at end of file");
851 else if (status == 0)
852 err ("do_p1_list: missing list tag in p1 file");
854 status = p1getd (infile, &type);
856 err ("do_p1_list: missing list type at end of file");
857 else if (status == 0)
858 err ("do_p1_list: missing list type in p1 file");
860 status = p1getd (infile, &count);
862 err ("do_p1_list: missing count at end of file");
863 else if (status == 0)
864 err ("do_p1_list: missing count in p1 file");
868 result = (expptr) ALLOC (Listblock);
873 result -> listblock.vtype = type;
875 /* Assume there will be enough data */
878 pointer = result->listblock.listp =
879 mkchain((char *)do_format(infile, outfile), CHNULL);
882 mkchain((char *)do_format(infile, outfile), CHNULL);
883 pointer = pointer -> nextp;
884 } /* while (count--) */
892 chainp length_comp(e, add_n) /* get lengths of characters args */
893 struct Entrypoint *e;
903 args = args1 = add_n ? allargs : e->arglist;
905 for (lengths = NULL; args; args = args -> nextp)
906 if ((arg = (Namep)args->datap)
907 && arg->vtype == TYCHAR
908 && arg->vclass != CLPROC) {
909 lengths = mkchain((char *)arg, lengths);
912 if (!add_n && (np = e->enamep)) {
913 /* one last check -- by now we know all we ever will
914 * about external args...
916 save_argtypes(e->arglist, &e->entryname->arginfo,
917 &np->arginfo, 0, np->fvarname, STGEXT, nchargs,
919 at = e->entryname->arginfo;
920 for(a = at->atypes; args1; a++, args1 = args1->nextp) {
922 if (arg = (Namep)args1->datap)
923 switch(arg->vclass) {
927 a->type = TYUNKNOWN + 200;
934 return revchain(lengths);
937 void listargs(outfile, entryp, add_n_, lengths)
939 struct Entrypoint *entryp;
948 nice_printf (outfile, "(");
951 nice_printf(outfile, "n__");
956 args = entryp->arglist;
960 nice_printf(outfile, ", ret_val");
964 else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
966 s = xretslot[proctype]->user.ident;
967 nice_printf(outfile, did_one ? ", %s" : "%s",
968 *s == '(' /*)*/ ? "r_v" : s);
970 if (proctype == TYCHAR)
971 nice_printf (outfile, ", ret_val_len");
973 for (; args; args = args -> nextp)
974 if (arg = (Namep)args->datap) {
975 nice_printf (outfile, "%s", did_one ? ", " : "");
976 out_name (outfile, arg);
980 for (args = lengths; args; args = args -> nextp)
981 nice_printf(outfile, ", %s",
982 new_arg_length((Namep)args->datap));
983 nice_printf (outfile, ")");
987 void list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
989 struct Entrypoint *entryp;
995 int last_type = -1, last_class = -1;
996 int did_one = 0, done_one;
997 char *s, *sep = "", *sep1;
999 if (outfile == (FILE *) NULL) {
1000 err ("list_arg_types: null output file");
1002 } else if (entryp == (struct Entrypoint *) NULL) {
1003 err ("list_arg_types: null procedure entry pointer");
1010 nice_printf(outfile, "(" /*)*/);
1016 args = entryp->arglist;
1018 nice_printf(outfile, "int n__");
1024 nice_printf(outfile, "%sMultitype *ret_val", sep);
1028 else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
1029 s = xretslot[proctype]->user.ident;
1030 nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
1031 *s == '(' /*)*/ ? "r_v" : s);
1034 if (proctype == TYCHAR)
1035 nice_printf (outfile, "%sftnlen ret_val_len", sep);
1036 } /* if ONEOF proctype */
1037 for (; args; args = args -> nextp) {
1038 Namep arg = (Namep) args->datap;
1040 /* Scalars are passed by reference, and arrays will have their lower bound
1041 adjusted, so nearly everything is printed with a star in front. The
1042 exception is character lengths, which are passed by value. */
1045 int type = arg -> vtype, class = arg -> vclass;
1047 if (class == CLPROC)
1049 type = Castargs ? TYUNKNOWN : TYSUBR;
1050 else if (type == TYREAL && forcedouble && !Castargs)
1053 if (type == last_type && class == last_class && did_one)
1054 nice_printf (outfile, ", ");
1056 if (class == CLPROC && Castargs)
1057 nice_printf(outfile, "%s%s ", sep,
1058 usedcasts[type] = casttypes[type]);
1060 nice_printf(outfile, "%s%s ", sep,
1061 c_type_decl(type, 0));
1062 if (class == CLPROC)
1064 out_name(outfile, arg);
1066 nice_printf(outfile, "(*");
1067 out_name(outfile, arg);
1068 nice_printf(outfile, ") %s", parens);
1071 nice_printf (outfile, "*");
1072 out_name (outfile, arg);
1080 } /* for args = entryp -> arglist */
1082 for (args = lengths; args; args = args -> nextp)
1083 nice_printf(outfile, "%sftnlen %s", sep,
1084 new_arg_length((Namep)args->datap));
1086 nice_printf (outfile, ";\n");
1088 nice_printf(outfile,
1089 /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
1091 } /* list_arg_types */
1094 write_formats(outfile)
1097 register struct Labelblock *lp;
1099 extern int in_string;
1102 for(lp = labeltab ; lp < highlabtab ; ++lp)
1103 if (lp->fmtlabused) {
1106 nice_printf(outfile, "/* Format strings */\n");
1108 nice_printf(outfile, "static char fmt_%ld[] = \"",
1111 if (!(fs = lp->fmtstring))
1113 nice_printf(outfile, "%s\"", fs);
1115 nice_printf(outfile, ";\n");
1118 nice_printf(outfile, "\n");
1122 write_ioblocks(outfile)
1125 register iob_data *L;
1126 register char *f, **s, *sep;
1128 nice_printf(outfile, "/* Fortran I/O blocks */\n");
1129 L = iob_list = (iob_data *)revchain((chainp)iob_list);
1131 nice_printf(outfile, "static %s %s = { ",
1134 for(s = L->fields; f = *s; s++) {
1136 nice_printf(outfile, sep);
1138 if (*f == '"') { /* kludge */
1139 nice_printf(outfile, "\"");
1141 nice_printf(outfile, "%s\"", f+1);
1145 nice_printf(outfile, "%s", f);
1147 nice_printf(outfile, " };\n");
1150 nice_printf(outfile, "\n\n");
1154 write_assigned_fmts(outfile)
1161 cp = assigned_fmts = revchain(assigned_fmts);
1162 nice_printf(outfile, "/* Assigned format variables */\nchar ");
1164 np = (Namep)cp->datap;
1166 nice_printf(outfile, ", ");
1168 nice_printf(outfile, "*%s_fmt", np->fvarname);
1170 while(cp = cp->nextp);
1171 nice_printf(outfile, ";\n\n");
1178 static char buf[64];
1179 register char *t = buf;
1181 while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
1186 /* This routine creates static structures representing a namelist.
1187 Declarations of the namelist and related structures are:
1192 Long *dims; /* laid out as struct dimensions below *//*
1195 typedef struct Vardesc Vardesc;
1205 long numberofdimensions;
1206 long numberofelements
1208 long span[numberofdimensions-1];
1211 If dims is not null, then the corner element of the array is at
1212 addr. However, the element with subscripts (i1,...,in) is at
1213 addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
1217 write_namelists(nmch, outfile)
1222 struct Hashentry *entry;
1223 struct Dimblock *dimp;
1229 nice_printf(outfile, "/* Namelist stuff */\n\n");
1230 for (entry = hashtab; entry < lasthash; ++entry) {
1231 if (!(v = entry->varp) || !v->vnamelist)
1235 if (dimp = v->vdim) {
1237 nice_printf(outfile,
1238 "static Long %s_dims[] = { %d, %ld, %ld",
1240 dimp->nelt->constblock.Const.ci,
1241 dimp->baseoffset->constblock.Const.ci);
1242 for(i = 0, --nd; i < nd; i++)
1243 nice_printf(outfile, ", %ld",
1244 dimp->dims[i].dimsize->constblock.Const.ci);
1245 nice_printf(outfile, " };\n");
1247 nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
1248 name, to_upper(name),
1249 type == TYCHAR ? "" : dimp ? "(char *)" : "(char *)&");
1250 out_name(outfile, v);
1251 nice_printf(outfile, dimp ? ", %s_dims" : ", (Long *)0", name);
1252 nice_printf(outfile, ", %ld };\n",
1253 type != TYCHAR ? (long)type
1254 : -v->vleng->constblock.Const.ci);
1258 var = (Namep)nmch->datap;
1259 name = var->cvarname;
1260 nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
1263 for(q = var->varxptr.namelist ; q ; q = q->nextp) {
1264 v = (Namep)q->datap;
1268 nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
1271 nice_printf(outfile, " };\n");
1272 nice_printf(outfile,
1273 "static Namelist %s = { \"%s\", %s_vl, %d };\n",
1274 name, to_upper(name), name, i);
1276 while(nmch = nmch->nextp);
1277 nice_printf(outfile, "\n");
1280 /* fixextype tries to infer from usage in previous procedures
1281 the type of an external procedure declared
1282 external and passed as an argument but never typed or invoked.
1291 extern void changedtype();
1294 e = &extsymtab[var->vardesc.varno];
1295 if ((type1 = e->extype) && type == TYUNKNOWN)
1296 return var->vtype = type1;
1298 if (e->exused && type != type1)
1306 list_decls (outfile)
1309 extern chainp used_builtins;
1310 extern struct Hashentry *hashtab;
1311 extern void wr_char_len();
1312 struct Hashentry *entry;
1313 int write_header = 1;
1314 int last_class = -1, last_stg = -1;
1316 int Alias, Define, did_one, last_type, type;
1317 extern int def_equivs, useauto;
1318 extern chainp new_vars; /* Compiler-generated locals */
1319 chainp namelists = 0;
1321 long lineno_save = lineno;
1322 int useauto1 = useauto && !saveall;
1324 lineno = old_lineno;
1326 /* First write out the statically initialized data */
1329 list_init_data(&initfile, initfname, outfile);
1331 /* Next come formats */
1332 write_formats(outfile);
1334 /* Now write out the system-generated identifiers */
1336 if (new_vars || nequiv) {
1337 chainp args, next_var, this_var;
1338 chainp nv[TYVOID], nv1[TYVOID];
1343 /* zap unused dimension variables */
1345 for(args = allargs; args; args = args->nextp) {
1346 arg = (Namep)args->datap;
1347 if (this_var = arg->vlastdim) {
1348 frexpr((tagptr)this_var->datap);
1349 this_var->datap = 0;
1353 /* sort new_vars by type, skipping entries just zapped */
1355 for(i = TYADDR; i < TYVOID; i++)
1357 for(this_var = new_vars; this_var; this_var = next_var) {
1358 next_var = this_var->nextp;
1359 if (Var = (Addrp)this_var->datap) {
1360 if (!(this_var->nextp = nv[j = Var->vtype]))
1365 this_var->nextp = 0;
1370 for(i = TYVOID; --i >= TYADDR;)
1371 if (this_var = nv[i]) {
1372 nv1[i]->nextp = new_vars;
1373 new_vars = this_var;
1376 /* write the declarations */
1381 for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
1382 Var = (Addrp) this_var->datap;
1384 if (Var == (Addrp) NULL)
1385 err ("list_decls: null variable");
1386 else if (Var -> tag != TADDR)
1387 erri ("list_decls: bad tag on new variable '%d'",
1390 type = nv_type (Var);
1391 if (Var->vstg == STGINIT
1392 || Var->uname_tag == UNAM_IDENT
1393 && *Var->user.ident == ' '
1397 nice_printf (outfile, "/* System generated locals */\n");
1399 if (last_type == type && did_one)
1400 nice_printf (outfile, ", ");
1403 nice_printf (outfile, ";\n");
1404 nice_printf (outfile, "%s ",
1405 c_type_decl (type, Var -> vclass == CLPROC));
1408 /* Character type is really a string type. Put out a '*' for parameters
1409 with unknown length and functions returning character */
1411 if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
1412 || Var -> vclass == CLPROC))
1413 nice_printf (outfile, "*");
1415 write_nv_ident(outfile, (Addrp)this_var->datap);
1416 if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
1417 ISICON((Var -> vleng))
1418 && (i = Var->vleng->constblock.Const.ci) > 0)
1419 nice_printf (outfile, "[%d]", i);
1422 last_type = nv_type (Var);
1423 } /* for this_var */
1425 /* Handle the uninitialized equivalences */
1427 do_uninit_equivs (outfile, &did_one);
1430 nice_printf (outfile, ";\n\n");
1433 /* Write out builtin declarations */
1435 if (used_builtins) {
1442 nice_printf (outfile, "/* Builtin functions */");
1444 for (cp = used_builtins; cp; cp = cp -> nextp) {
1445 Addrp e = (Addrp)cp->datap;
1447 switch(type = e->vtype) {
1450 /* if (forcedouble || e->dbl_builtin) */
1451 /* libF77 currently assumes everything double */
1460 ctype = c_type_decl(type, 0);
1463 if (did_one && last_type == type)
1464 nice_printf(outfile, ", ");
1466 nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
1468 extern_out(outfile, es = &extsymtab[e -> memno]);
1469 proto(outfile, es->arginfo, es->fextname);
1472 } /* for cp = used_builtins */
1474 nice_printf (outfile, ";\n\n");
1475 } /* if used_builtins */
1478 for (entry = hashtab; entry < lasthash; ++entry) {
1479 var = entry -> varp;
1482 int procclass = var -> vprocclass;
1483 char *comment = NULL;
1484 int stg = var -> vstg;
1485 int class = var -> vclass;
1486 type = var -> vtype;
1488 if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
1491 if (useauto1 && stg == STGBSS && !var->vsave)
1500 extsymtab[var->vardesc.varno].extype = type;
1506 err ("list_decls: unknown procedure class");
1509 if (stg == STGUNKNOWN) {
1511 "%.64s declared EXTERNAL but never used.",
1513 /* to retain names declared EXTERNAL */
1514 /* but not referenced, change
1515 /* "continue" to "stg = STGEXT" */
1519 type = fixexttype(var);
1523 /* declared but never used */
1529 namelists = mkchain((char *)var, namelists);
1532 erri("list_decls: can't handle class '%d' yet",
1534 Fatal(var->fvarname);
1538 /* Might be equivalenced to a common. If not, don't process */
1539 if (stg == STGCOMMON && !var->vcommequiv)
1542 /* Only write the header if system-generated locals, builtins, or
1543 uninitialized equivs were already output */
1545 if (write_header == 1 && (new_vars || nequiv || used_builtins)
1546 && oneof_stg ( var, stg,
1547 M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
1548 nice_printf (outfile, "/* Local variables */\n");
1553 Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
1554 if (Define = Alias && def_equivs) {
1556 nice_printf(outfile, ";\n");
1557 def_start(outfile, var->cvarname, CNULL, "(");
1560 else if (type == last_type && class == last_class &&
1561 stg == last_stg && !write_header)
1562 nice_printf (outfile, ", ");
1564 if (!write_header && ONEOF(stg, M(STGBSS)|
1565 M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
1566 nice_printf (outfile, ";\n");
1571 /* Part of the argument list, don't write them out
1573 continue; /* Go back to top of the loop */
1577 nice_printf (outfile, "static ");
1580 nice_printf (outfile, "extern ");
1586 /* Don't want to touch the initialized data, that will
1587 be handled elsewhere. Unknown data have
1588 already been complained about, so skip them */
1591 erri("list_decls: can't handle storage class %d",
1596 nice_printf (outfile, "%s ", c_type_decl (var -> vtype, var ->
1600 /* Character type is really a string type. Put out a '*' for variable
1601 length strings, and also for equivalences */
1603 if (var -> vtype == TYCHAR && var -> vclass != CLPROC
1604 && (!var->vleng || !ISICON (var -> vleng))
1605 || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
1606 nice_printf (outfile, "*%s", var->cvarname);
1608 nice_printf (outfile, "%s", var->cvarname);
1609 if (var -> vclass == CLPROC)
1610 proto(outfile, var->arginfo, var->fvarname);
1611 else if (var -> vtype == TYCHAR && ISICON ((var -> vleng)))
1612 wr_char_len(outfile, var->vdim,
1613 (int)var->vleng->constblock.Const.ci, 0);
1614 else if (var -> vdim &&
1615 !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
1616 comment = wr_ardecls(outfile, var->vdim, 1L);
1620 nice_printf (outfile, "%s", comment);
1623 char *amp, *lp, *name, *rp;
1624 char *equiv_name ();
1625 ftnint voff = var -> voffset;
1626 int et0, expr_type, k;
1628 struct Equivblock *eb;
1631 /* We DON'T want to use oneof_stg here, because we need to distinguish
1634 if (stg == STGEQUIV) {
1635 name = equiv_name(k = var->vardesc.varno, CNULL);
1648 E = &extsymtab[var->vardesc.varno];
1649 sprintf(name = buf, "%s%d", E->cextname, E->curno);
1656 nice_printf (outfile, " = ");
1659 switch((int)(voff % k)) {
1665 case SZSHORT+SZLONG:
1666 expr_type = TYSHORT;
1678 if (expr_type == type) {
1680 if (et0 == -1 && !voff)
1687 nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
1690 /* Now worry about computing the offset */
1693 if (expr_type == et0)
1694 nice_printf (outfile, "%s%s + %ld%s",
1695 lp, name, voff, rp);
1697 nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
1698 c_type_decl (expr_type, 0), amp,
1701 nice_printf(outfile, "%s%s", amp, name);
1702 /* Always put these at the end of the line */
1703 last_type = last_class = last_stg = -1;
1706 ind_printf(0, outfile, ")\n");
1710 } /* if oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)) */
1716 } /* for (entry = hashtab */
1719 nice_printf (outfile, ";\n\n");
1720 else if (write_header == 2)
1721 nice_printf(outfile, "\n");
1723 /* Next, namelists, which may reference equivs */
1726 write_namelists(namelists = revchain(namelists), outfile);
1727 frchain(&namelists);
1730 /* Finally, ioblocks (which may reference equivs and namelists) */
1732 write_ioblocks(outfile);
1734 write_assigned_fmts(outfile);
1735 lineno = lineno_save;
1738 do_uninit_equivs (outfile, did_one)
1743 struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
1744 int k, last_type = -1, t;
1746 for (eqv = eqvclass; eqv < lasteqv; eqv++)
1747 if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
1749 nice_printf (outfile, "/* System generated locals */\n");
1752 nice_printf (outfile, ", ");
1755 nice_printf (outfile, ";\n");
1756 nice_printf (outfile, "static %s ", c_type_decl(t, 0));
1759 nice_printf(outfile, "%s", equiv_name(eqv - eqvclass, CNULL));
1760 nice_printf(outfile, "[%ld]",
1761 (eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
1764 } /* if !eqv -> eqvinit */
1765 } /* do_uninit_equivs */
1768 /* wr_ardecls -- Writes the brackets and size for an array
1769 declaration. Because of the inner workings of the compiler,
1770 multi-dimensional arrays get mapped directly into a one-dimensional
1771 array, so we have to compute the size of the array here. When the
1772 dimension is greater than 1, a string comment about the original size
1775 char *wr_ardecls(outfile, dimp, size)
1777 struct Dimblock *dimp;
1781 static char buf[1000];
1783 if (dimp == (struct Dimblock *) NULL)
1786 sprintf(buf, "\t/* was "); /* would like to say k = sprintf(...), but */
1787 k = strlen(buf); /* BSD doesn't return char transmitted count */
1789 for (i = 0; i < dimp -> ndim; i++) {
1790 expptr this_size = dimp -> dims[i].dimsize;
1792 if (!ISICON (this_size))
1793 err ("wr_ardecls: nonconstant array size");
1795 size *= this_size -> constblock.Const.ci;
1796 sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci);
1797 k += strlen(buf+k); /* BSD prevents combining this with prev stmt */
1801 nice_printf (outfile, "[%ld]", size);
1802 strcat(buf+k, " */");
1804 return (i > 1) ? buf : NULL;
1809 /* ----------------------------------------------------------------------
1811 The following routines read from the p1 intermediate file. If
1812 that format changes, only these routines need be changed
1814 ---------------------------------------------------------------------- */
1816 static int get_p1_token (infile)
1819 int token = P1_UNKNOWN;
1821 /* NOT PORTABLE!! */
1823 if (fscanf (infile, "%d", &token) == EOF)
1826 /* Skip over the ": " */
1828 if (getc (infile) != '\n')
1832 } /* get_p1_token */
1836 /* Returns a (null terminated) string from the input file */
1838 static int p1gets (fp, str, size)
1849 if ((c = getc (fp)) != ' ')
1852 if (fgets (str, size, fp)) {
1855 str[size - 1] = '\0';
1856 length = strlen (str);
1858 /* Get rid of the newline */
1860 if (str[length - 1] == '\n')
1861 str[length - 1] = '\0';
1864 } else if (feof (fp))
1871 static int p1get_const (infile, type, resultp)
1874 struct Constblock **resultp;
1877 struct Constblock *result;
1879 if (type != TYCHAR) {
1880 *resultp = result = ALLOC(Constblock);
1881 result -> tag = TCONST;
1882 result -> vtype = type;
1889 status = p1getd (infile, &(result -> Const.ci));
1893 status = p1getf(infile, &result->Const.cds[0]);
1898 status = p1getf(infile, &result->Const.cds[0]);
1899 if (status && status != EOF)
1900 status = p1getf(infile, &result->Const.cds[1]);
1904 status = fscanf(infile, "%lx", resultp);
1907 erri ("p1get_const: bad constant type '%d'", type);
1915 static int p1getd (infile, result)
1919 return fscanf (infile, "%ld", result);
1923 p1getf(infile, result)
1931 k = fscanf (infile, "%s", buf);
1935 strcpy(*result = mem(strlen(buf)+1,0), buf);
1939 static int p1getn (infile, count, result)
1946 extern ptr ckalloc ();
1948 bufptr = (char *) ckalloc (count);
1953 for (; !feof (infile) && count > 0; count--)
1954 *bufptr++ = getc (infile);
1956 return feof (infile) ? EOF : 1;
1960 proto(outfile, at, fname)
1970 extern void bad_atypes();
1973 /* Correct types that we learn on the fly, e.g.
1974 subroutine gotcha(foo)
1976 call zap(...,foo,...)
1979 atypes = at->atypes;
1981 for(i = 0; i++ < n; atypes++) {
1982 if (!(cp = atypes->cp))
1986 np = (Namep)cp->datap;
1988 if (np->vclass == CLPROC) {
1989 if (!np->vimpltype && k)
1993 j = TYUNKNOWN + 200;
2000 || j == 200 && k >= 200)
2003 bad_atypes(at,fname,i,j,k,""," and");
2007 while(cp = cp->nextp);
2009 frchain(&atypes->cp);
2014 nice_printf(outfile, parens);
2018 if (!at || (n = at->nargs) < 0) {
2019 nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
2024 nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
2028 atypes = at->atypes;
2029 nice_printf(outfile, "(");
2031 for(; --n >= 0; atypes++) {
2034 nice_printf(outfile, "%schar **", comma);
2035 else if (k >= 200) {
2037 nice_printf(outfile, "%s%s", comma,
2038 usedcasts[k] = casttypes[k]);
2041 nice_printf(outfile, "%s%s", comma,
2042 c_type_decl(k-100, 0));
2044 nice_printf(outfile, "%s%s *", comma,
2048 nice_printf(outfile, ")");
2052 protowrite(protofile, type, name, e, lengths)
2055 struct Entrypoint *e;
2058 extern char used_rets[];
2060 nice_printf(protofile, "extern %s %s", protorettypes[type], name);
2061 list_arg_types(protofile, e, lengths, 0, ";\n");
2062 used_rets[type] = 1;
2066 do_p1_1while(outfile)
2070 nice_printf(outfile,
2071 "for(;;) { /* while(complicated condition) */\n" /*}*/ );
2075 nice_printf(outfile, "while(" /*)*/ );
2079 do_p1_2while(infile, outfile)
2080 FILE *infile, *outfile;
2084 test = do_format(infile, outfile);
2086 nice_printf(outfile, "if (!(");
2087 expr_out(outfile, test);
2089 nice_printf(outfile, "))\n\tbreak;\n");
2091 nice_printf(outfile, /*(*/ ") {\n");